LambdaHack 0.5.0.0 → 0.6.0.0

raw patch · 203 files changed

+30120/−22672 lines, 203 filesdep +base-compatdep +ghcjs-domdep +gtk3dep −arraydep −data-defaultdep −gtkdep ~assert-failuredep ~asyncdep ~basebinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: base-compat, ghcjs-dom, gtk3, sdl2, sdl2-ttf, time

Dependencies removed: array, data-default, gtk, mtl, old-time

Dependency ranges changed: assert-failure, async, base, binary, bytestring, containers, deepseq, directory, enummapset-th, filepath, ghc-prim, hashable, hscurses, hsini, keys, miniutter, pretty-show, random, stm, template-haskell, text, transformers, unordered-containers, vector, vector-binary-instances, vty, zlib

API changes (from Hackage documentation)

- Game.LambdaHack.Atomic: HitBlock :: !Int -> HitAtomic

- Game.LambdaHack.Atomic: HitClear :: HitAtomic

- Game.LambdaHack.Atomic: SfxActorStart :: !ActorId -> SfxAtomic

- Game.LambdaHack.Atomic: SfxCatch :: !ActorId -> !ItemId -> !CStore -> SfxAtomic

- Game.LambdaHack.Atomic: SfxMsgAll :: !Msg -> SfxAtomic

- Game.LambdaHack.Atomic: UpdAgeActor :: !ActorId -> !(Delta Time) -> UpdAtomic

- Game.LambdaHack.Atomic: UpdColorActor :: !ActorId -> !Color -> !Color -> UpdAtomic

- Game.LambdaHack.Atomic: UpdFidImpressedActor :: !ActorId -> !FactionId -> !FactionId -> UpdAtomic

- Game.LambdaHack.Atomic: UpdLearnSecrets :: !ActorId -> !Int -> !Int -> UpdAtomic

- Game.LambdaHack.Atomic: UpdRecordHistory :: !FactionId -> UpdAtomic

- Game.LambdaHack.Atomic: broadcastSfxAtomic :: MonadAtomic m => (FactionId -> SfxAtomic) -> m ()

- Game.LambdaHack.Atomic: broadcastUpdAtomic :: MonadAtomic m => (FactionId -> UpdAtomic) -> m ()

- Game.LambdaHack.Atomic: data HitAtomic

- Game.LambdaHack.Atomic: execAtomic :: MonadAtomic m => CmdAtomic -> m ()

- Game.LambdaHack.Atomic.BroadcastAtomicWrite: handleAndBroadcast :: MonadStateWrite m => Bool -> Pers -> (a -> FactionId -> LevelId -> m Perception) -> m a -> (FactionId -> ResponseAI -> m ()) -> (FactionId -> ResponseUI -> m ()) -> CmdAtomic -> m ()

- Game.LambdaHack.Atomic.CmdAtomic: HitBlock :: !Int -> HitAtomic

- Game.LambdaHack.Atomic.CmdAtomic: HitClear :: HitAtomic

- Game.LambdaHack.Atomic.CmdAtomic: SfxActorStart :: !ActorId -> SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: SfxCatch :: !ActorId -> !ItemId -> !CStore -> SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: SfxMsgAll :: !Msg -> SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: UpdAgeActor :: !ActorId -> !(Delta Time) -> UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: UpdColorActor :: !ActorId -> !Color -> !Color -> UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: UpdFidImpressedActor :: !ActorId -> !FactionId -> !FactionId -> UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: UpdLearnSecrets :: !ActorId -> !Int -> !Int -> UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: UpdRecordHistory :: !FactionId -> UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: data HitAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Binary CmdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Binary HitAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Binary SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Binary UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_0CmdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_0HitAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_0SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_0UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_10SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_10UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_11SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_11UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_12UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_13UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_14UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_15UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_16UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_17UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_18UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_19UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_1CmdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_1HitAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_1SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_1UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_20UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_21UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_22UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_23UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_24UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_25UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_26UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_27UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_28UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_29UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_2SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_2UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_30UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_31UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_32UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_33UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_34UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_35UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_36UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_37UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_38UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_39UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_3SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_3UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_40UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_41UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_42UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_43UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_44UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_45UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_46UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_47UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_48UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_49UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_4SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_4UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_5SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_5UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_6SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_6UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_7SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_7UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_8SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_8UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_9SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Constructor C1_9UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Datatype D1CmdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Datatype D1HitAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Datatype D1SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Datatype D1UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Eq CmdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Eq HitAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Eq SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Eq UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Generic CmdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Generic HitAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Generic SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Generic UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Show CmdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Show HitAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Show SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: instance Show UpdAtomic

- Game.LambdaHack.Atomic.HandleAtomicWrite: handleCmdAtomic :: MonadStateWrite m => CmdAtomic -> m ()

- Game.LambdaHack.Atomic.MonadAtomic: broadcastSfxAtomic :: MonadAtomic m => (FactionId -> SfxAtomic) -> m ()

- Game.LambdaHack.Atomic.MonadAtomic: broadcastUpdAtomic :: MonadAtomic m => (FactionId -> UpdAtomic) -> m ()

- Game.LambdaHack.Atomic.MonadAtomic: execAtomic :: MonadAtomic m => CmdAtomic -> m ()

- Game.LambdaHack.Atomic.MonadStateWrite: updatePrio :: (ActorPrio -> ActorPrio) -> Level -> Level

- Game.LambdaHack.Atomic.PosAtomicRead: breakSfxAtomic :: MonadStateRead m => SfxAtomic -> m [SfxAtomic]

- Game.LambdaHack.Atomic.PosAtomicRead: instance Eq PosAtomic

- Game.LambdaHack.Atomic.PosAtomicRead: instance Show PosAtomic

- Game.LambdaHack.Atomic.PosAtomicRead: loudUpdAtomic :: MonadStateRead m => Bool -> FactionId -> UpdAtomic -> m (Maybe Msg)

- Game.LambdaHack.Atomic.PosAtomicRead: resetsFovCmdAtomic :: UpdAtomic -> Bool

- Game.LambdaHack.Client: loopAI :: (MonadAtomic m, MonadClientReadResponse ResponseAI m, MonadClientWriteRequest RequestAI m) => DebugModeCli -> m ()

- Game.LambdaHack.Client: loopUI :: (MonadClientUI m, MonadAtomic m, MonadClientReadResponse ResponseUI m, MonadClientWriteRequest RequestUI m) => DebugModeCli -> m ()

- Game.LambdaHack.Client: srtFrontend :: (DebugModeCli -> SessionUI -> State -> StateClient -> chanServerUI -> IO ()) -> (DebugModeCli -> SessionUI -> State -> StateClient -> chanServerAI -> IO ()) -> KeyKind -> COps -> DebugModeCli -> ((FactionId -> chanServerUI -> IO ()) -> (FactionId -> chanServerAI -> IO ()) -> IO ()) -> IO ()

- Game.LambdaHack.Client.AI: pongAI :: MonadClient m => m RequestAI

- Game.LambdaHack.Client.AI: refreshTarget :: MonadClient m => (ActorId, Actor) -> m (Maybe (Target, PathEtc))

- Game.LambdaHack.Client.AI.ConditionClient: benAvailableItems :: MonadClient m => ActorId -> (Maybe Int -> ItemFull -> Actor -> [ItemFull] -> Bool) -> [CStore] -> m [((Maybe (Int, Int), (Int, CStore)), (ItemId, ItemFull))]

- Game.LambdaHack.Client.AI.ConditionClient: benGroundItems :: MonadClient m => ActorId -> m [((Maybe (Int, Int), (Int, CStore)), (ItemId, ItemFull))]

- Game.LambdaHack.Client.AI.ConditionClient: condAnyFoeAdjM :: MonadStateRead m => ActorId -> m Bool

- Game.LambdaHack.Client.AI.ConditionClient: condBlocksFriendsM :: MonadClient m => ActorId -> m Bool

- Game.LambdaHack.Client.AI.ConditionClient: condCanProjectM :: MonadClient m => Bool -> ActorId -> m Bool

- Game.LambdaHack.Client.AI.ConditionClient: condDesirableFloorItemM :: MonadClient m => ActorId -> m Bool

- Game.LambdaHack.Client.AI.ConditionClient: condEnoughGearM :: MonadClient m => ActorId -> m Bool

- Game.LambdaHack.Client.AI.ConditionClient: condFloorWeaponM :: MonadClient m => ActorId -> m Bool

- Game.LambdaHack.Client.AI.ConditionClient: condHpTooLowM :: MonadClient m => ActorId -> m Bool

- Game.LambdaHack.Client.AI.ConditionClient: condLightBetraysM :: MonadClient m => ActorId -> m Bool

- Game.LambdaHack.Client.AI.ConditionClient: condMeleeBadM :: MonadClient m => ActorId -> m Bool

- Game.LambdaHack.Client.AI.ConditionClient: condNoEqpWeaponM :: MonadClient m => ActorId -> m Bool

- Game.LambdaHack.Client.AI.ConditionClient: condNotCalmEnoughM :: MonadClient m => ActorId -> m Bool

- Game.LambdaHack.Client.AI.ConditionClient: condOnTriggerableM :: MonadStateRead m => ActorId -> m Bool

- Game.LambdaHack.Client.AI.ConditionClient: condTgtEnemyAdjFriendM :: MonadClient m => ActorId -> m Bool

- Game.LambdaHack.Client.AI.ConditionClient: condTgtEnemyPresentM :: MonadClient m => ActorId -> m Bool

- Game.LambdaHack.Client.AI.ConditionClient: condTgtEnemyRememberedM :: MonadClient m => ActorId -> m Bool

- Game.LambdaHack.Client.AI.ConditionClient: condTgtNonmovingM :: MonadClient m => ActorId -> m Bool

- Game.LambdaHack.Client.AI.ConditionClient: desirableItem :: Bool -> Maybe Int -> ItemFull -> Bool

- Game.LambdaHack.Client.AI.ConditionClient: fleeList :: MonadClient m => ActorId -> m ([(Int, Point)], [(Int, Point)])

- Game.LambdaHack.Client.AI.ConditionClient: hinders :: Bool -> Bool -> Bool -> Bool -> Actor -> [ItemFull] -> ItemFull -> Bool

- Game.LambdaHack.Client.AI.ConditionClient: threatDistList :: MonadClient m => ActorId -> m [(Int, (ActorId, Actor))]

- Game.LambdaHack.Client.AI.HandleAbilityClient: actionStrategy :: MonadClient m => ActorId -> m (Strategy RequestAnyAbility)

- Game.LambdaHack.Client.AI.HandleAbilityClient: instance Eq ApplyItemGroup

- Game.LambdaHack.Client.AI.PickActorClient: pickActorToMove :: MonadClient m => ((ActorId, Actor) -> m (Maybe (Target, PathEtc))) -> ActorId -> m (ActorId, Actor)

- Game.LambdaHack.Client.AI.PickTargetClient: createPath :: MonadClient m => ActorId -> Target -> m (Maybe (Target, PathEtc))

- Game.LambdaHack.Client.AI.PickTargetClient: targetStrategy :: MonadClient m => ActorId -> m (Strategy (Target, Maybe PathEtc))

- Game.LambdaHack.Client.AI.Preferences: effectToBenefit :: COps -> Actor -> [ItemFull] -> Faction -> Effect -> Int

- Game.LambdaHack.Client.AI.Preferences: totalUsefulness :: COps -> Actor -> [ItemFull] -> Faction -> ItemFull -> Maybe (Int, Int)

- Game.LambdaHack.Client.AI.Strategy: instance Alternative Strategy

- Game.LambdaHack.Client.AI.Strategy: instance Applicative Strategy

- Game.LambdaHack.Client.AI.Strategy: instance Foldable Strategy

- Game.LambdaHack.Client.AI.Strategy: instance Functor Strategy

- Game.LambdaHack.Client.AI.Strategy: instance Monad Strategy

- Game.LambdaHack.Client.AI.Strategy: instance MonadPlus Strategy

- Game.LambdaHack.Client.AI.Strategy: instance Show a => Show (Strategy a)

- Game.LambdaHack.Client.AI.Strategy: instance Traversable Strategy

- Game.LambdaHack.Client.Bfs: instance Bits BfsDistance

- Game.LambdaHack.Client.Bfs: instance Bounded BfsDistance

- Game.LambdaHack.Client.Bfs: instance Enum BfsDistance

- Game.LambdaHack.Client.Bfs: instance Eq BfsDistance

- Game.LambdaHack.Client.Bfs: instance Eq MoveLegal

- Game.LambdaHack.Client.Bfs: instance Ord BfsDistance

- Game.LambdaHack.Client.Bfs: instance Show BfsDistance

- Game.LambdaHack.Client.BfsClient: accessCacheBfs :: MonadClient m => ActorId -> Point -> m (Maybe Int)

- Game.LambdaHack.Client.BfsClient: closestFoes :: MonadClient m => [(ActorId, Actor)] -> ActorId -> m [(Int, (ActorId, Actor))]

- Game.LambdaHack.Client.BfsClient: closestItems :: MonadClient m => ActorId -> m [(Int, (Point, Maybe ItemBag))]

- Game.LambdaHack.Client.BfsClient: closestSmell :: MonadClient m => ActorId -> m [(Int, (Point, SmellTime))]

- Game.LambdaHack.Client.BfsClient: closestSuspect :: MonadClient m => ActorId -> m [Point]

- Game.LambdaHack.Client.BfsClient: closestTriggers :: MonadClient m => Maybe Bool -> ActorId -> m (Frequency Point)

- Game.LambdaHack.Client.BfsClient: closestUnknown :: MonadClient m => ActorId -> m (Maybe Point)

- Game.LambdaHack.Client.BfsClient: furthestKnown :: MonadClient m => ActorId -> m Point

- Game.LambdaHack.Client.BfsClient: getCacheBfs :: MonadClient m => ActorId -> m (Array BfsDistance)

- Game.LambdaHack.Client.BfsClient: getCacheBfsAndPath :: MonadClient m => ActorId -> Point -> m (Array BfsDistance, Maybe [Point])

- Game.LambdaHack.Client.BfsClient: invalidateBfs :: ActorId -> EnumMap ActorId (Bool, Array BfsDistance, Point, Int, Maybe [Point]) -> EnumMap ActorId (Bool, Array BfsDistance, Point, Int, Maybe [Point])

- Game.LambdaHack.Client.BfsClient: unexploredDepth :: MonadClient m => m (Int -> LevelId -> Bool)

- Game.LambdaHack.Client.CommonClient: activeItemsClient :: MonadClient m => ActorId -> m [ItemFull]

- Game.LambdaHack.Client.CommonClient: actorSkillsClient :: MonadClient m => ActorId -> m Skills

- Game.LambdaHack.Client.CommonClient: aidTgtAims :: MonadClient m => ActorId -> LevelId -> Maybe Target -> m (Either Msg Int)

- Game.LambdaHack.Client.CommonClient: aidTgtToPos :: MonadClient m => ActorId -> LevelId -> Maybe Target -> m (Maybe Point)

- Game.LambdaHack.Client.CommonClient: fullAssocsClient :: MonadClient m => ActorId -> [CStore] -> m [(ItemId, ItemFull)]

- Game.LambdaHack.Client.CommonClient: getPerFid :: MonadClient m => LevelId -> m Perception

- Game.LambdaHack.Client.CommonClient: itemToFullClient :: MonadClient m => m (ItemId -> ItemQuant -> ItemFull)

- Game.LambdaHack.Client.CommonClient: makeLine :: MonadClient m => Bool -> Actor -> Point -> Int -> m (Maybe Int)

- Game.LambdaHack.Client.CommonClient: partActorLeader :: MonadClient m => ActorId -> Actor -> m Part

- Game.LambdaHack.Client.CommonClient: partAidLeader :: MonadClient m => ActorId -> m Part

- Game.LambdaHack.Client.CommonClient: partPronounLeader :: MonadClient m => ActorId -> Actor -> m Part

- Game.LambdaHack.Client.CommonClient: pickWeaponClient :: MonadClient m => ActorId -> ActorId -> m (Maybe (RequestTimed AbMelee))

- Game.LambdaHack.Client.CommonClient: sumOrganEqpClient :: MonadClient m => EqpSlot -> ActorId -> m Int

- Game.LambdaHack.Client.CommonClient: updateItemSlot :: MonadClient m => CStore -> Maybe ActorId -> ItemId -> m SlotChar

- Game.LambdaHack.Client.HandleAtomicClient: cmdAtomicFilterCli :: MonadClient m => UpdAtomic -> m [UpdAtomic]

- Game.LambdaHack.Client.HandleAtomicClient: cmdAtomicSemCli :: MonadClient m => UpdAtomic -> m ()

- Game.LambdaHack.Client.HandleResponseClient: handleResponseAI :: (MonadAtomic m, MonadClientWriteRequest RequestAI m) => ResponseAI -> m ()

- Game.LambdaHack.Client.HandleResponseClient: handleResponseUI :: (MonadClientUI m, MonadAtomic m, MonadClientWriteRequest RequestUI m) => ResponseUI -> m ()

- Game.LambdaHack.Client.ItemSlot: SlotChar :: Int -> Char -> SlotChar

- Game.LambdaHack.Client.ItemSlot: allSlots :: Int -> [SlotChar]

- Game.LambdaHack.Client.ItemSlot: assignSlot :: CStore -> Item -> FactionId -> Maybe Actor -> ItemSlots -> SlotChar -> State -> SlotChar

- Game.LambdaHack.Client.ItemSlot: data SlotChar

- Game.LambdaHack.Client.ItemSlot: instance Binary SlotChar

- Game.LambdaHack.Client.ItemSlot: instance Enum SlotChar

- Game.LambdaHack.Client.ItemSlot: instance Eq SlotChar

- Game.LambdaHack.Client.ItemSlot: instance Ord SlotChar

- Game.LambdaHack.Client.ItemSlot: instance Show SlotChar

- Game.LambdaHack.Client.ItemSlot: slotChar :: SlotChar -> Char

- Game.LambdaHack.Client.ItemSlot: slotLabel :: SlotChar -> Part

- Game.LambdaHack.Client.ItemSlot: slotPrefix :: SlotChar -> Int

- Game.LambdaHack.Client.ItemSlot: slotRange :: [SlotChar] -> Text

- Game.LambdaHack.Client.ItemSlot: type ItemSlots = (EnumMap SlotChar ItemId, EnumMap SlotChar ItemId)

- Game.LambdaHack.Client.Key: Alt :: Modifier

- Game.LambdaHack.Client.Key: BackSpace :: Key

- Game.LambdaHack.Client.Key: BackTab :: Key

- Game.LambdaHack.Client.Key: Begin :: Key

- Game.LambdaHack.Client.Key: Char :: !Char -> Key

- Game.LambdaHack.Client.Key: Control :: Modifier

- Game.LambdaHack.Client.Key: Delete :: Key

- Game.LambdaHack.Client.Key: Down :: Key

- Game.LambdaHack.Client.Key: End :: Key

- Game.LambdaHack.Client.Key: Esc :: Key

- Game.LambdaHack.Client.Key: Home :: Key

- Game.LambdaHack.Client.Key: Insert :: Key

- Game.LambdaHack.Client.Key: KM :: !Key -> !Modifier -> !(Maybe Point) -> KM

- Game.LambdaHack.Client.Key: KP :: !Char -> Key

- Game.LambdaHack.Client.Key: Left :: Key

- Game.LambdaHack.Client.Key: LeftButtonPress :: Key

- Game.LambdaHack.Client.Key: MiddleButtonPress :: Key

- Game.LambdaHack.Client.Key: NoModifier :: Modifier

- Game.LambdaHack.Client.Key: PgDn :: Key

- Game.LambdaHack.Client.Key: PgUp :: Key

- Game.LambdaHack.Client.Key: Return :: Key

- Game.LambdaHack.Client.Key: Right :: Key

- Game.LambdaHack.Client.Key: RightButtonPress :: Key

- Game.LambdaHack.Client.Key: Shift :: Modifier

- Game.LambdaHack.Client.Key: Space :: Key

- Game.LambdaHack.Client.Key: Tab :: Key

- Game.LambdaHack.Client.Key: Unknown :: !Text -> Key

- Game.LambdaHack.Client.Key: Up :: Key

- Game.LambdaHack.Client.Key: data KM

- Game.LambdaHack.Client.Key: data Key

- Game.LambdaHack.Client.Key: data Modifier

- Game.LambdaHack.Client.Key: dirAllKey :: Bool -> Bool -> [Key]

- Game.LambdaHack.Client.Key: escKM :: KM

- Game.LambdaHack.Client.Key: handleDir :: Bool -> Bool -> KM -> (Vector -> a) -> a -> a

- Game.LambdaHack.Client.Key: instance Binary KM

- Game.LambdaHack.Client.Key: instance Binary Key

- Game.LambdaHack.Client.Key: instance Binary Modifier

- Game.LambdaHack.Client.Key: instance Constructor C1_0KM

- Game.LambdaHack.Client.Key: instance Constructor C1_0Key

- Game.LambdaHack.Client.Key: instance Constructor C1_0Modifier

- Game.LambdaHack.Client.Key: instance Constructor C1_10Key

- Game.LambdaHack.Client.Key: instance Constructor C1_11Key

- Game.LambdaHack.Client.Key: instance Constructor C1_12Key

- Game.LambdaHack.Client.Key: instance Constructor C1_13Key

- Game.LambdaHack.Client.Key: instance Constructor C1_14Key

- Game.LambdaHack.Client.Key: instance Constructor C1_15Key

- Game.LambdaHack.Client.Key: instance Constructor C1_16Key

- Game.LambdaHack.Client.Key: instance Constructor C1_17Key

- Game.LambdaHack.Client.Key: instance Constructor C1_18Key

- Game.LambdaHack.Client.Key: instance Constructor C1_19Key

- Game.LambdaHack.Client.Key: instance Constructor C1_1Key

- Game.LambdaHack.Client.Key: instance Constructor C1_1Modifier

- Game.LambdaHack.Client.Key: instance Constructor C1_20Key

- Game.LambdaHack.Client.Key: instance Constructor C1_21Key

- Game.LambdaHack.Client.Key: instance Constructor C1_22Key

- Game.LambdaHack.Client.Key: instance Constructor C1_2Key

- Game.LambdaHack.Client.Key: instance Constructor C1_2Modifier

- Game.LambdaHack.Client.Key: instance Constructor C1_3Key

- Game.LambdaHack.Client.Key: instance Constructor C1_3Modifier

- Game.LambdaHack.Client.Key: instance Constructor C1_4Key

- Game.LambdaHack.Client.Key: instance Constructor C1_5Key

- Game.LambdaHack.Client.Key: instance Constructor C1_6Key

- Game.LambdaHack.Client.Key: instance Constructor C1_7Key

- Game.LambdaHack.Client.Key: instance Constructor C1_8Key

- Game.LambdaHack.Client.Key: instance Constructor C1_9Key

- Game.LambdaHack.Client.Key: instance Datatype D1KM

- Game.LambdaHack.Client.Key: instance Datatype D1Key

- Game.LambdaHack.Client.Key: instance Datatype D1Modifier

- Game.LambdaHack.Client.Key: instance Eq KM

- Game.LambdaHack.Client.Key: instance Eq Key

- Game.LambdaHack.Client.Key: instance Eq Modifier

- Game.LambdaHack.Client.Key: instance Generic KM

- Game.LambdaHack.Client.Key: instance Generic Key

- Game.LambdaHack.Client.Key: instance Generic Modifier

- Game.LambdaHack.Client.Key: instance NFData KM

- Game.LambdaHack.Client.Key: instance NFData Key

- Game.LambdaHack.Client.Key: instance NFData Modifier

- Game.LambdaHack.Client.Key: instance Ord KM

- Game.LambdaHack.Client.Key: instance Ord Key

- Game.LambdaHack.Client.Key: instance Ord Modifier

- Game.LambdaHack.Client.Key: instance Read KM

- Game.LambdaHack.Client.Key: instance Read Key

- Game.LambdaHack.Client.Key: instance Read Modifier

- Game.LambdaHack.Client.Key: instance Selector S1_0_0KM

- Game.LambdaHack.Client.Key: instance Selector S1_0_1KM

- Game.LambdaHack.Client.Key: instance Selector S1_0_2KM

- Game.LambdaHack.Client.Key: instance Show KM

- Game.LambdaHack.Client.Key: key :: KM -> !Key

- Game.LambdaHack.Client.Key: keyTranslate :: String -> Key

- Game.LambdaHack.Client.Key: leftButtonKM :: KM

- Game.LambdaHack.Client.Key: mkKM :: String -> KM

- Game.LambdaHack.Client.Key: modifier :: KM -> !Modifier

- Game.LambdaHack.Client.Key: moveBinding :: Bool -> Bool -> (Vector -> a) -> (Vector -> a) -> [(KM, a)]

- Game.LambdaHack.Client.Key: pgdnKM :: KM

- Game.LambdaHack.Client.Key: pgupKM :: KM

- Game.LambdaHack.Client.Key: pointer :: KM -> !(Maybe Point)

- Game.LambdaHack.Client.Key: returnKM :: KM

- Game.LambdaHack.Client.Key: rightButtonKM :: KM

- Game.LambdaHack.Client.Key: showKM :: KM -> Text

- Game.LambdaHack.Client.Key: showKey :: Key -> Text

- Game.LambdaHack.Client.Key: spaceKM :: KM

- Game.LambdaHack.Client.Key: toKM :: Modifier -> Key -> KM

- Game.LambdaHack.Client.LoopClient: loopAI :: (MonadAtomic m, MonadClientReadResponse ResponseAI m, MonadClientWriteRequest RequestAI m) => DebugModeCli -> m ()

- Game.LambdaHack.Client.LoopClient: loopUI :: (MonadClientUI m, MonadAtomic m, MonadClientReadResponse ResponseUI m, MonadClientWriteRequest RequestUI m) => DebugModeCli -> m ()

- Game.LambdaHack.Client.MonadClient: debugPrint :: MonadClient m => Text -> m ()

- Game.LambdaHack.Client.MonadClient: removeServerSave :: MonadClient m => m ()

- Game.LambdaHack.Client.MonadClient: restoreGame :: MonadClient m => m (Maybe (State, StateClient))

- Game.LambdaHack.Client.MonadClient: saveChanClient :: MonadClient m => m (ChanSave (State, StateClient))

- Game.LambdaHack.Client.MonadClient: saveName :: FactionId -> Bool -> String

- Game.LambdaHack.Client.ProtocolClient: class MonadClient m => MonadClientReadResponse resp m | m -> resp

- Game.LambdaHack.Client.ProtocolClient: class MonadClient m => MonadClientWriteRequest req m | m -> req

- Game.LambdaHack.Client.ProtocolClient: receiveResponse :: MonadClientReadResponse resp m => m resp

- Game.LambdaHack.Client.ProtocolClient: sendRequest :: MonadClientWriteRequest req m => req -> m ()

- Game.LambdaHack.Client.State: EscAIExited :: EscAI

- Game.LambdaHack.Client.State: EscAIMenu :: EscAI

- Game.LambdaHack.Client.State: EscAINothing :: EscAI

- Game.LambdaHack.Client.State: EscAIStarted :: EscAI

- Game.LambdaHack.Client.State: RunParams :: !ActorId -> ![ActorId] -> !Bool -> !(Maybe Text) -> !Int -> RunParams

- Game.LambdaHack.Client.State: TgtMode :: LevelId -> TgtMode

- Game.LambdaHack.Client.State: _sleader :: StateClient -> !(Maybe ActorId)

- Game.LambdaHack.Client.State: _sside :: StateClient -> !FactionId

- Game.LambdaHack.Client.State: data EscAI

- Game.LambdaHack.Client.State: data RunParams

- Game.LambdaHack.Client.State: defStateClient :: History -> Report -> FactionId -> Bool -> StateClient

- Game.LambdaHack.Client.State: defaultHistory :: Int -> IO History

- Game.LambdaHack.Client.State: instance Binary RunParams

- Game.LambdaHack.Client.State: instance Binary StateClient

- Game.LambdaHack.Client.State: instance Binary TgtMode

- Game.LambdaHack.Client.State: instance Eq EscAI

- Game.LambdaHack.Client.State: instance Eq TgtMode

- Game.LambdaHack.Client.State: instance Show EscAI

- Game.LambdaHack.Client.State: instance Show RunParams

- Game.LambdaHack.Client.State: instance Show StateClient

- Game.LambdaHack.Client.State: instance Show TgtMode

- Game.LambdaHack.Client.State: newtype TgtMode

- Game.LambdaHack.Client.State: runInitial :: RunParams -> !Bool

- Game.LambdaHack.Client.State: runLeader :: RunParams -> !ActorId

- Game.LambdaHack.Client.State: runMembers :: RunParams -> ![ActorId]

- Game.LambdaHack.Client.State: runStopMsg :: RunParams -> !(Maybe Text)

- Game.LambdaHack.Client.State: runWaiting :: RunParams -> !Int

- Game.LambdaHack.Client.State: sbfsD :: StateClient -> !(EnumMap ActorId (Bool, Array BfsDistance, Point, Int, Maybe [Point]))

- Game.LambdaHack.Client.State: scurDiff :: StateClient -> !Int

- Game.LambdaHack.Client.State: scursor :: StateClient -> !Target

- Game.LambdaHack.Client.State: sdebugCli :: StateClient -> !DebugModeCli

- Game.LambdaHack.Client.State: sdiscoEffect :: StateClient -> !DiscoveryEffect

- Game.LambdaHack.Client.State: sdiscoKind :: StateClient -> !DiscoveryKind

- Game.LambdaHack.Client.State: sdisplayed :: StateClient -> !(EnumMap LevelId Time)

- Game.LambdaHack.Client.State: seps :: StateClient -> !Int

- Game.LambdaHack.Client.State: sescAI :: StateClient -> !EscAI

- Game.LambdaHack.Client.State: sexplored :: StateClient -> !(EnumSet LevelId)

- Game.LambdaHack.Client.State: sfper :: StateClient -> !FactionPers

- Game.LambdaHack.Client.State: shistory :: StateClient -> !History

- Game.LambdaHack.Client.State: sisAI :: StateClient -> !Bool

- Game.LambdaHack.Client.State: slastKM :: StateClient -> !KM

- Game.LambdaHack.Client.State: slastLost :: StateClient -> !(EnumSet ActorId)

- Game.LambdaHack.Client.State: slastPlay :: StateClient -> ![KM]

- Game.LambdaHack.Client.State: slastRecord :: StateClient -> !LastRecord

- Game.LambdaHack.Client.State: slastSlot :: StateClient -> !SlotChar

- Game.LambdaHack.Client.State: slastStore :: StateClient -> !CStore

- Game.LambdaHack.Client.State: smarkSmell :: StateClient -> !Bool

- Game.LambdaHack.Client.State: smarkSuspect :: StateClient -> !Bool

- Game.LambdaHack.Client.State: smarkVision :: StateClient -> !Bool

- Game.LambdaHack.Client.State: snxtDiff :: StateClient -> !Int

- Game.LambdaHack.Client.State: squit :: StateClient -> !Bool

- Game.LambdaHack.Client.State: srandom :: StateClient -> !StdGen

- Game.LambdaHack.Client.State: sreport :: StateClient -> !Report

- Game.LambdaHack.Client.State: srunning :: StateClient -> !(Maybe RunParams)

- Game.LambdaHack.Client.State: sselected :: StateClient -> !(EnumSet ActorId)

- Game.LambdaHack.Client.State: sslots :: StateClient -> !ItemSlots

- Game.LambdaHack.Client.State: stargetD :: StateClient -> !(EnumMap ActorId (Target, Maybe PathEtc))

- Game.LambdaHack.Client.State: stgtMode :: StateClient -> !(Maybe TgtMode)

- Game.LambdaHack.Client.State: sundo :: StateClient -> ![CmdAtomic]

- Game.LambdaHack.Client.State: swaitTimes :: StateClient -> !Int

- Game.LambdaHack.Client.State: tgtLevelId :: TgtMode -> LevelId

- Game.LambdaHack.Client.State: toggleMarkSmell :: StateClient -> StateClient

- Game.LambdaHack.Client.State: toggleMarkSuspect :: StateClient -> StateClient

- Game.LambdaHack.Client.State: toggleMarkVision :: StateClient -> StateClient

- Game.LambdaHack.Client.State: type LastRecord = ([KM], [KM], Int)

- Game.LambdaHack.Client.State: type PathEtc = ([Point], (Point, Int))

- Game.LambdaHack.Client.UI: displayMore :: MonadClientUI m => ColorMode -> Msg -> m Bool

- Game.LambdaHack.Client.UI: pongUI :: MonadClientUI m => m RequestUI

- Game.LambdaHack.Client.UI: srtFrontend :: (DebugModeCli -> SessionUI -> State -> StateClient -> chanServerUI -> IO ()) -> (DebugModeCli -> SessionUI -> State -> StateClient -> chanServerAI -> IO ()) -> KeyKind -> COps -> DebugModeCli -> ((FactionId -> chanServerUI -> IO ()) -> (FactionId -> chanServerAI -> IO ()) -> IO ()) -> IO ()

- Game.LambdaHack.Client.UI.Animation: SingleFrame :: ![ScreenLine] -> !Overlay -> ![ScreenLine] -> !Bool -> SingleFrame

- Game.LambdaHack.Client.UI.Animation: data SingleFrame

- Game.LambdaHack.Client.UI.Animation: decodeLine :: ScreenLine -> [AttrChar]

- Game.LambdaHack.Client.UI.Animation: encodeLine :: [AttrChar] -> ScreenLine

- Game.LambdaHack.Client.UI.Animation: instance Binary SingleFrame

- Game.LambdaHack.Client.UI.Animation: instance Constructor C1_0SingleFrame

- Game.LambdaHack.Client.UI.Animation: instance Datatype D1SingleFrame

- Game.LambdaHack.Client.UI.Animation: instance Eq Animation

- Game.LambdaHack.Client.UI.Animation: instance Eq SingleFrame

- Game.LambdaHack.Client.UI.Animation: instance Generic SingleFrame

- Game.LambdaHack.Client.UI.Animation: instance Monoid Animation

- Game.LambdaHack.Client.UI.Animation: instance Selector S1_0_0SingleFrame

- Game.LambdaHack.Client.UI.Animation: instance Selector S1_0_1SingleFrame

- Game.LambdaHack.Client.UI.Animation: instance Selector S1_0_2SingleFrame

- Game.LambdaHack.Client.UI.Animation: instance Selector S1_0_3SingleFrame

- Game.LambdaHack.Client.UI.Animation: instance Show Animation

- Game.LambdaHack.Client.UI.Animation: instance Show SingleFrame

- Game.LambdaHack.Client.UI.Animation: moveProj :: (Point, Point, Point) -> Char -> Color -> Animation

- Game.LambdaHack.Client.UI.Animation: overlayOverlay :: SingleFrame -> SingleFrame

- Game.LambdaHack.Client.UI.Animation: restrictAnim :: EnumSet Point -> Animation -> Animation

- Game.LambdaHack.Client.UI.Animation: sfBlank :: SingleFrame -> !Bool

- Game.LambdaHack.Client.UI.Animation: sfBottom :: SingleFrame -> ![ScreenLine]

- Game.LambdaHack.Client.UI.Animation: sfLevel :: SingleFrame -> ![ScreenLine]

- Game.LambdaHack.Client.UI.Animation: sfTop :: SingleFrame -> !Overlay

- Game.LambdaHack.Client.UI.Animation: type Frames = [Maybe SingleFrame]

- Game.LambdaHack.Client.UI.Config: configColorIsBold :: Config -> !Bool

- Game.LambdaHack.Client.UI.Config: configCommands :: Config -> ![(KM, ([CmdCategory], HumanCmd))]

- Game.LambdaHack.Client.UI.Config: configFont :: Config -> !String

- Game.LambdaHack.Client.UI.Config: configHeroNames :: Config -> ![(Int, (Text, Text))]

- Game.LambdaHack.Client.UI.Config: configHistoryMax :: Config -> !Int

- Game.LambdaHack.Client.UI.Config: configLaptop :: Config -> !Bool

- Game.LambdaHack.Client.UI.Config: configMaxFps :: Config -> !Int

- Game.LambdaHack.Client.UI.Config: configNoAnim :: Config -> !Bool

- Game.LambdaHack.Client.UI.Config: configRunStopMsgs :: Config -> !Bool

- Game.LambdaHack.Client.UI.Config: configVi :: Config -> !Bool

- Game.LambdaHack.Client.UI.Config: instance Constructor C1_0Config

- Game.LambdaHack.Client.UI.Config: instance Datatype D1Config

- Game.LambdaHack.Client.UI.Config: instance Generic Config

- Game.LambdaHack.Client.UI.Config: instance NFData Config

- Game.LambdaHack.Client.UI.Config: instance Selector S1_0_0Config

- Game.LambdaHack.Client.UI.Config: instance Selector S1_0_1Config

- Game.LambdaHack.Client.UI.Config: instance Selector S1_0_2Config

- Game.LambdaHack.Client.UI.Config: instance Selector S1_0_3Config

- Game.LambdaHack.Client.UI.Config: instance Selector S1_0_4Config

- Game.LambdaHack.Client.UI.Config: instance Selector S1_0_5Config

- Game.LambdaHack.Client.UI.Config: instance Selector S1_0_6Config

- Game.LambdaHack.Client.UI.Config: instance Selector S1_0_7Config

- Game.LambdaHack.Client.UI.Config: instance Selector S1_0_8Config

- Game.LambdaHack.Client.UI.Config: instance Selector S1_0_9Config

- Game.LambdaHack.Client.UI.Config: instance Show Config

- Game.LambdaHack.Client.UI.Content.KeyKind: data KeyKind

- Game.LambdaHack.Client.UI.Content.KeyKind: macroLeftButtonPress :: HumanCmd

- Game.LambdaHack.Client.UI.Content.KeyKind: macroShiftLeftButtonPress :: HumanCmd

- Game.LambdaHack.Client.UI.Content.KeyKind: rhumanCommands :: KeyKind -> ![(KM, ([CmdCategory], HumanCmd))]

- Game.LambdaHack.Client.UI.DisplayAtomicClient: displayRespSfxAtomicUI :: MonadClientUI m => Bool -> SfxAtomic -> m ()

- Game.LambdaHack.Client.UI.DisplayAtomicClient: displayRespUpdAtomicUI :: MonadClientUI m => Bool -> State -> StateClient -> UpdAtomic -> m ()

- Game.LambdaHack.Client.UI.DrawClient: ColorBW :: ColorMode

- Game.LambdaHack.Client.UI.DrawClient: ColorFull :: ColorMode

- Game.LambdaHack.Client.UI.DrawClient: data ColorMode

- Game.LambdaHack.Client.UI.DrawClient: draw :: MonadClient m => ColorMode -> LevelId -> Maybe Point -> Maybe Point -> Maybe (Array BfsDistance, Maybe [Point]) -> (Text, Maybe Text) -> (Text, Maybe Text) -> Overlay -> m SingleFrame

- Game.LambdaHack.Client.UI.Frontend: FrontAutoYes :: !Bool -> FrontReq

- Game.LambdaHack.Client.UI.Frontend: FrontDelay :: FrontReq

- Game.LambdaHack.Client.UI.Frontend: FrontFinish :: FrontReq

- Game.LambdaHack.Client.UI.Frontend: FrontKey :: ![KM] -> !SingleFrame -> FrontReq

- Game.LambdaHack.Client.UI.Frontend: FrontNormalFrame :: !SingleFrame -> FrontReq

- Game.LambdaHack.Client.UI.Frontend: FrontSlides :: ![KM] -> ![SingleFrame] -> !(Maybe Bool) -> FrontReq

- Game.LambdaHack.Client.UI.Frontend: data ChanFrontend

- Game.LambdaHack.Client.UI.Frontend: frontClear :: FrontReq -> ![KM]

- Game.LambdaHack.Client.UI.Frontend: frontFr :: FrontReq -> !SingleFrame

- Game.LambdaHack.Client.UI.Frontend: frontFrame :: FrontReq -> !SingleFrame

- Game.LambdaHack.Client.UI.Frontend: frontFromTop :: FrontReq -> !(Maybe Bool)

- Game.LambdaHack.Client.UI.Frontend: frontKM :: FrontReq -> ![KM]

- Game.LambdaHack.Client.UI.Frontend: frontSlides :: FrontReq -> ![SingleFrame]

- Game.LambdaHack.Client.UI.Frontend: requestF :: ChanFrontend -> !(TQueue FrontReq)

- Game.LambdaHack.Client.UI.Frontend: responseF :: ChanFrontend -> !(TQueue KM)

- Game.LambdaHack.Client.UI.Frontend: startupF :: DebugModeCli -> (Maybe (MVar ()) -> (ChanFrontend -> IO ()) -> IO ()) -> IO ()

- Game.LambdaHack.Client.UI.Frontend.Chosen: RawFrontend :: (Maybe SingleFrame -> IO ()) -> (SingleFrame -> IO KM) -> IO () -> !(Maybe (MVar ())) -> !DebugModeCli -> RawFrontend

- Game.LambdaHack.Client.UI.Frontend.Chosen: chosenStartup :: DebugModeCli -> (RawFrontend -> IO ()) -> IO ()

- Game.LambdaHack.Client.UI.Frontend.Chosen: data RawFrontend

- Game.LambdaHack.Client.UI.Frontend.Chosen: fdebugCli :: RawFrontend -> !DebugModeCli

- Game.LambdaHack.Client.UI.Frontend.Chosen: fdisplay :: RawFrontend -> Maybe SingleFrame -> IO ()

- Game.LambdaHack.Client.UI.Frontend.Chosen: fescMVar :: RawFrontend -> !(Maybe (MVar ()))

- Game.LambdaHack.Client.UI.Frontend.Chosen: fpromptGetKey :: RawFrontend -> SingleFrame -> IO KM

- Game.LambdaHack.Client.UI.Frontend.Chosen: fsyncFrames :: RawFrontend -> IO ()

- Game.LambdaHack.Client.UI.Frontend.Chosen: nullStartup :: DebugModeCli -> (RawFrontend -> IO ()) -> IO ()

- Game.LambdaHack.Client.UI.Frontend.Chosen: stdStartup :: DebugModeCli -> (RawFrontend -> IO ()) -> IO ()

- Game.LambdaHack.Client.UI.Frontend.Std: data FrontendSession

- Game.LambdaHack.Client.UI.Frontend.Std: fdisplay :: FrontendSession -> Maybe SingleFrame -> IO ()

- Game.LambdaHack.Client.UI.Frontend.Std: fpromptGetKey :: FrontendSession -> SingleFrame -> IO KM

- Game.LambdaHack.Client.UI.Frontend.Std: frontendName :: String

- Game.LambdaHack.Client.UI.Frontend.Std: fsyncFrames :: FrontendSession -> IO ()

- Game.LambdaHack.Client.UI.Frontend.Std: startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()

- Game.LambdaHack.Client.UI.HandleHumanClient: cmdHumanSem :: MonadClientUI m => HumanCmd -> m (SlideOrCmd RequestUI)

- Game.LambdaHack.Client.UI.HandleHumanGlobalClient: alterDirHuman :: MonadClientUI m => [Trigger] -> m (SlideOrCmd (RequestTimed AbAlter))

- Game.LambdaHack.Client.UI.HandleHumanGlobalClient: applyHuman :: MonadClientUI m => [Trigger] -> m (SlideOrCmd (RequestTimed AbApply))

- Game.LambdaHack.Client.UI.HandleHumanGlobalClient: automateHuman :: MonadClientUI m => m (SlideOrCmd RequestUI)

- Game.LambdaHack.Client.UI.HandleHumanGlobalClient: continueToCursorHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)

- Game.LambdaHack.Client.UI.HandleHumanGlobalClient: describeItemHuman :: MonadClientUI m => ItemDialogMode -> m (SlideOrCmd (RequestTimed AbMoveItem))

- Game.LambdaHack.Client.UI.HandleHumanGlobalClient: gameExitHuman :: MonadClientUI m => m (SlideOrCmd RequestUI)

- Game.LambdaHack.Client.UI.HandleHumanGlobalClient: gameRestartHuman :: MonadClientUI m => GroupName ModeKind -> m (SlideOrCmd RequestUI)

- Game.LambdaHack.Client.UI.HandleHumanGlobalClient: gameSaveHuman :: MonadClientUI m => m RequestUI

- Game.LambdaHack.Client.UI.HandleHumanGlobalClient: moveItemHuman :: MonadClientUI m => [CStore] -> CStore -> Maybe Part -> Bool -> m (SlideOrCmd (RequestTimed AbMoveItem))

- Game.LambdaHack.Client.UI.HandleHumanGlobalClient: moveOnceToCursorHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)

- Game.LambdaHack.Client.UI.HandleHumanGlobalClient: moveRunHuman :: MonadClientUI m => Bool -> Bool -> Bool -> Bool -> Vector -> m (SlideOrCmd RequestAnyAbility)

- Game.LambdaHack.Client.UI.HandleHumanGlobalClient: projectHuman :: MonadClientUI m => [Trigger] -> m (SlideOrCmd (RequestTimed AbProject))

- Game.LambdaHack.Client.UI.HandleHumanGlobalClient: runOnceAheadHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)

- Game.LambdaHack.Client.UI.HandleHumanGlobalClient: runOnceToCursorHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)

- Game.LambdaHack.Client.UI.HandleHumanGlobalClient: tacticHuman :: MonadClientUI m => m (SlideOrCmd RequestUI)

- Game.LambdaHack.Client.UI.HandleHumanGlobalClient: triggerTileHuman :: MonadClientUI m => [Trigger] -> m (SlideOrCmd (RequestTimed AbTrigger))

- Game.LambdaHack.Client.UI.HandleHumanGlobalClient: waitHuman :: MonadClientUI m => m (RequestTimed AbWait)

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: acceptHuman :: MonadClientUI m => m Slideshow -> m Slideshow

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: cancelHuman :: MonadClientUI m => m Slideshow -> m Slideshow

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: clearHuman :: Monad m => m ()

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: cursorItemHuman :: MonadClientUI m => m Slideshow

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: cursorPointerEnemyHuman :: MonadClientUI m => m ()

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: cursorPointerFloorHuman :: MonadClientUI m => m ()

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: cursorStairHuman :: MonadClientUI m => Bool -> m Slideshow

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: cursorUnknownHuman :: MonadClientUI m => m Slideshow

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: epsIncrHuman :: MonadClientUI m => Bool -> m Slideshow

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: gameDifficultyCycle :: MonadClientUI m => m ()

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: helpHuman :: MonadClientUI m => m Slideshow

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: historyHuman :: MonadClientUI m => m Slideshow

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: macroHuman :: MonadClient m => [String] -> m ()

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: mainMenuHuman :: MonadClientUI m => m Slideshow

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: markSmellHuman :: MonadClientUI m => m ()

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: markSuspectHuman :: MonadClientUI m => m ()

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: markVisionHuman :: MonadClientUI m => m ()

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: memberBackHuman :: MonadClientUI m => m Slideshow

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: memberCycleHuman :: MonadClientUI m => m Slideshow

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: moveCursorHuman :: MonadClientUI m => Vector -> Int -> m Slideshow

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: pickLeaderHuman :: MonadClientUI m => Int -> m Slideshow

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: recordHuman :: MonadClientUI m => m Slideshow

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: repeatHuman :: MonadClient m => Int -> m ()

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: selectActorHuman :: MonadClientUI m => m ()

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: selectNoneHuman :: (MonadClientUI m, MonadClient m) => m ()

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: selectWithPointer :: MonadClientUI m => m ()

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: stopIfTgtModeHuman :: MonadClientUI m => m ()

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: tgtAscendHuman :: MonadClientUI m => Int -> m Slideshow

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: tgtClearHuman :: MonadClientUI m => m Slideshow

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: tgtEnemyHuman :: MonadClientUI m => m Slideshow

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: tgtFloorHuman :: MonadClientUI m => m Slideshow

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: tgtPointerEnemyHuman :: MonadClientUI m => m Slideshow

- Game.LambdaHack.Client.UI.HandleHumanLocalClient: tgtPointerFloorHuman :: MonadClientUI m => m Slideshow

- Game.LambdaHack.Client.UI.HumanCmd: CmdAuto :: CmdCategory

- Game.LambdaHack.Client.UI.HumanCmd: CmdMenu :: CmdCategory

- Game.LambdaHack.Client.UI.HumanCmd: CmdTgt :: CmdCategory

- Game.LambdaHack.Client.UI.HumanCmd: ContinueToCursor :: HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: CursorItem :: HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: CursorPointerEnemy :: HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: CursorPointerFloor :: HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: CursorStair :: !Bool -> HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: CursorUnknown :: HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: DescribeItem :: !ItemDialogMode -> HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: GameDifficultyCycle :: HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: Move :: !Vector -> HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: MoveCursor :: !Vector -> !Int -> HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: MoveOnceToCursor :: HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: Run :: !Vector -> HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: RunOnceToCursor :: HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: StopIfTgtMode :: HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: TgtAscend :: !Int -> HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: TgtEnemy :: HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: TgtFloor :: HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: TgtPointerEnemy :: HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: TgtPointerFloor :: HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: TriggerFeature :: !Part -> !Part -> !Feature -> Trigger

- Game.LambdaHack.Client.UI.HumanCmd: TriggerTile :: ![Trigger] -> HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: cmdDescription :: HumanCmd -> Text

- Game.LambdaHack.Client.UI.HumanCmd: feature :: Trigger -> !Feature

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_0CmdCategory

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_0HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_0Trigger

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_10HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_11HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_12HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_13HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_14HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_15HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_16HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_17HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_18HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_19HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_1CmdCategory

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_1HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_1Trigger

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_20HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_21HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_22HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_23HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_24HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_25HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_26HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_27HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_28HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_29HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_2CmdCategory

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_2HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_2Trigger

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_30HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_31HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_32HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_33HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_34HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_35HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_36HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_37HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_38HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_39HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_3CmdCategory

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_3HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_40HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_41HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_42HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_43HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_44HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_45HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_46HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_47HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_48HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_49HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_4CmdCategory

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_4HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_50HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_5CmdCategory

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_5HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_6CmdCategory

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_6HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_7CmdCategory

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_7HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_8CmdCategory

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_8HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_9CmdCategory

- Game.LambdaHack.Client.UI.HumanCmd: instance Constructor C1_9HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Datatype D1CmdCategory

- Game.LambdaHack.Client.UI.HumanCmd: instance Datatype D1HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Datatype D1Trigger

- Game.LambdaHack.Client.UI.HumanCmd: instance Eq CmdCategory

- Game.LambdaHack.Client.UI.HumanCmd: instance Eq HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Eq Trigger

- Game.LambdaHack.Client.UI.HumanCmd: instance Generic CmdCategory

- Game.LambdaHack.Client.UI.HumanCmd: instance Generic HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Generic Trigger

- Game.LambdaHack.Client.UI.HumanCmd: instance NFData CmdCategory

- Game.LambdaHack.Client.UI.HumanCmd: instance NFData HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance NFData Trigger

- Game.LambdaHack.Client.UI.HumanCmd: instance Ord HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Ord Trigger

- Game.LambdaHack.Client.UI.HumanCmd: instance Read CmdCategory

- Game.LambdaHack.Client.UI.HumanCmd: instance Read HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Read Trigger

- Game.LambdaHack.Client.UI.HumanCmd: instance Selector S1_0_0Trigger

- Game.LambdaHack.Client.UI.HumanCmd: instance Selector S1_0_1Trigger

- Game.LambdaHack.Client.UI.HumanCmd: instance Selector S1_0_2Trigger

- Game.LambdaHack.Client.UI.HumanCmd: instance Selector S1_1_0Trigger

- Game.LambdaHack.Client.UI.HumanCmd: instance Selector S1_1_1Trigger

- Game.LambdaHack.Client.UI.HumanCmd: instance Selector S1_1_2Trigger

- Game.LambdaHack.Client.UI.HumanCmd: instance Selector S1_2_0Trigger

- Game.LambdaHack.Client.UI.HumanCmd: instance Selector S1_2_1Trigger

- Game.LambdaHack.Client.UI.HumanCmd: instance Selector S1_2_2Trigger

- Game.LambdaHack.Client.UI.HumanCmd: instance Show CmdCategory

- Game.LambdaHack.Client.UI.HumanCmd: instance Show HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: instance Show Trigger

- Game.LambdaHack.Client.UI.HumanCmd: object :: Trigger -> !Part

- Game.LambdaHack.Client.UI.HumanCmd: symbol :: Trigger -> !Char

- Game.LambdaHack.Client.UI.HumanCmd: verb :: Trigger -> !Part

- Game.LambdaHack.Client.UI.InventoryClient: SuitsEverything :: Suitability

- Game.LambdaHack.Client.UI.InventoryClient: SuitsNothing :: Msg -> Suitability

- Game.LambdaHack.Client.UI.InventoryClient: SuitsSomething :: (ItemFull -> Bool) -> Suitability

- Game.LambdaHack.Client.UI.InventoryClient: cursorPointerEnemy :: MonadClientUI m => Bool -> Bool -> m Slideshow

- Game.LambdaHack.Client.UI.InventoryClient: cursorPointerFloor :: MonadClientUI m => Bool -> Bool -> m Slideshow

- Game.LambdaHack.Client.UI.InventoryClient: data Suitability

- Game.LambdaHack.Client.UI.InventoryClient: describeItemC :: MonadClientUI m => ItemDialogMode -> m (SlideOrCmd (RequestTimed AbMoveItem))

- Game.LambdaHack.Client.UI.InventoryClient: doLook :: MonadClientUI m => Bool -> m Slideshow

- Game.LambdaHack.Client.UI.InventoryClient: epsIncrHuman :: MonadClientUI m => Bool -> m Slideshow

- Game.LambdaHack.Client.UI.InventoryClient: getAnyItems :: MonadClientUI m => m Suitability -> Text -> Text -> [CStore] -> [CStore] -> Bool -> Bool -> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode))

- Game.LambdaHack.Client.UI.InventoryClient: getGroupItem :: MonadClientUI m => m Suitability -> Text -> Text -> Bool -> [CStore] -> [CStore] -> m (SlideOrCmd ((ItemId, ItemFull), ItemDialogMode))

- Game.LambdaHack.Client.UI.InventoryClient: getStoreItem :: MonadClientUI m => (Actor -> [ItemFull] -> ItemDialogMode -> Text) -> ItemDialogMode -> m (SlideOrCmd ((ItemId, ItemFull), ItemDialogMode))

- Game.LambdaHack.Client.UI.InventoryClient: instance Eq ItemDialogState

- Game.LambdaHack.Client.UI.InventoryClient: instance Show ItemDialogState

- Game.LambdaHack.Client.UI.InventoryClient: memberBack :: MonadClientUI m => Bool -> m Slideshow

- Game.LambdaHack.Client.UI.InventoryClient: memberCycle :: MonadClientUI m => Bool -> m Slideshow

- Game.LambdaHack.Client.UI.InventoryClient: moveCursorHuman :: MonadClientUI m => Vector -> Int -> m Slideshow

- Game.LambdaHack.Client.UI.InventoryClient: pickLeader :: MonadClientUI m => Bool -> ActorId -> m Bool

- Game.LambdaHack.Client.UI.InventoryClient: tgtClearHuman :: MonadClientUI m => m Slideshow

- Game.LambdaHack.Client.UI.InventoryClient: tgtEnemyHuman :: MonadClientUI m => m Slideshow

- Game.LambdaHack.Client.UI.InventoryClient: tgtFloorHuman :: MonadClientUI m => m Slideshow

- Game.LambdaHack.Client.UI.KeyBindings: bcmdList :: Binding -> ![(KM, (Text, [CmdCategory], HumanCmd))]

- Game.LambdaHack.Client.UI.KeyBindings: bcmdMap :: Binding -> !(Map KM (Text, [CmdCategory], HumanCmd))

- Game.LambdaHack.Client.UI.KeyBindings: brevMap :: Binding -> !(Map HumanCmd KM)

- Game.LambdaHack.Client.UI.MonadClientUI: ColorBW :: ColorMode

- Game.LambdaHack.Client.UI.MonadClientUI: ColorFull :: ColorMode

- Game.LambdaHack.Client.UI.MonadClientUI: SessionUI :: !ChanFrontend -> !Binding -> !(Maybe (MVar ())) -> !Config -> SessionUI

- Game.LambdaHack.Client.UI.MonadClientUI: askBinding :: MonadClientUI m => m Binding

- Game.LambdaHack.Client.UI.MonadClientUI: askConfig :: MonadClientUI m => m Config

- Game.LambdaHack.Client.UI.MonadClientUI: cursorToPos :: MonadClientUI m => m (Maybe Point)

- Game.LambdaHack.Client.UI.MonadClientUI: data ColorMode

- Game.LambdaHack.Client.UI.MonadClientUI: data SessionUI

- Game.LambdaHack.Client.UI.MonadClientUI: displayActorStart :: MonadClientUI m => Actor -> Frames -> m ()

- Game.LambdaHack.Client.UI.MonadClientUI: displayDelay :: MonadClientUI m => m ()

- Game.LambdaHack.Client.UI.MonadClientUI: displayFrame :: MonadClientUI m => Maybe SingleFrame -> m ()

- Game.LambdaHack.Client.UI.MonadClientUI: drawOverlay :: MonadClientUI m => Bool -> ColorMode -> Overlay -> m SingleFrame

- Game.LambdaHack.Client.UI.MonadClientUI: getInitConfirms :: MonadClientUI m => ColorMode -> [KM] -> Slideshow -> m Bool

- Game.LambdaHack.Client.UI.MonadClientUI: getKeyOverlayCommand :: MonadClientUI m => Maybe Bool -> Overlay -> m KM

- Game.LambdaHack.Client.UI.MonadClientUI: leaderTgtAims :: MonadClientUI m => m (Either Text Int)

- Game.LambdaHack.Client.UI.MonadClientUI: promptGetKey :: MonadClientUI m => [KM] -> SingleFrame -> m KM

- Game.LambdaHack.Client.UI.MonadClientUI: sbinding :: SessionUI -> !Binding

- Game.LambdaHack.Client.UI.MonadClientUI: schanF :: SessionUI -> !ChanFrontend

- Game.LambdaHack.Client.UI.MonadClientUI: sconfig :: SessionUI -> !Config

- Game.LambdaHack.Client.UI.MonadClientUI: sescMVar :: SessionUI -> !(Maybe (MVar ()))

- Game.LambdaHack.Client.UI.MonadClientUI: stopPlayBack :: MonadClientUI m => m ()

- Game.LambdaHack.Client.UI.MonadClientUI: syncFrames :: MonadClientUI m => m ()

- Game.LambdaHack.Client.UI.MonadClientUI: targetDescCursor :: MonadClientUI m => m (Text, Maybe Text)

- Game.LambdaHack.Client.UI.MonadClientUI: targetDescLeader :: MonadClientUI m => ActorId -> m (Text, Maybe Text)

- Game.LambdaHack.Client.UI.MonadClientUI: tryTakeMVarSescMVar :: MonadClientUI m => m Bool

- Game.LambdaHack.Client.UI.MonadClientUI: viewedLevel :: MonadClientUI m => m LevelId

- Game.LambdaHack.Client.UI.MsgClient: failMsg :: MonadClientUI m => Msg -> m Slideshow

- Game.LambdaHack.Client.UI.MsgClient: failSer :: MonadClientUI m => ReqFailure -> m (SlideOrCmd a)

- Game.LambdaHack.Client.UI.MsgClient: failSlides :: MonadClientUI m => Slideshow -> m (SlideOrCmd a)

- Game.LambdaHack.Client.UI.MsgClient: failWith :: MonadClientUI m => Msg -> m (SlideOrCmd a)

- Game.LambdaHack.Client.UI.MsgClient: itemOverlay :: MonadClient m => CStore -> LevelId -> ItemBag -> m Overlay

- Game.LambdaHack.Client.UI.MsgClient: lookAt :: MonadClientUI m => Bool -> Text -> Bool -> Point -> ActorId -> Text -> m Text

- Game.LambdaHack.Client.UI.MsgClient: msgAdd :: MonadClientUI m => Msg -> m ()

- Game.LambdaHack.Client.UI.MsgClient: msgReset :: MonadClientUI m => Msg -> m ()

- Game.LambdaHack.Client.UI.MsgClient: recordHistory :: MonadClientUI m => m ()

- Game.LambdaHack.Client.UI.MsgClient: type SlideOrCmd a = Either Slideshow a

- Game.LambdaHack.Client.UI.RunClient: continueRun :: MonadClient m => LevelId -> RunParams -> m (Either Msg RequestAnyAbility)

- Game.LambdaHack.Client.UI.StartupFrontendClient: srtFrontend :: (DebugModeCli -> SessionUI -> State -> StateClient -> chanServerUI -> IO ()) -> (DebugModeCli -> SessionUI -> State -> StateClient -> chanServerAI -> IO ()) -> KeyKind -> COps -> DebugModeCli -> ((FactionId -> chanServerUI -> IO ()) -> (FactionId -> chanServerAI -> IO ()) -> IO ()) -> IO ()

- Game.LambdaHack.Client.UI.WidgetClient: animate :: MonadClientUI m => LevelId -> Animation -> m Frames

- Game.LambdaHack.Client.UI.WidgetClient: describeMainKeys :: MonadClientUI m => m Msg

- Game.LambdaHack.Client.UI.WidgetClient: displayChoiceUI :: MonadClientUI m => Msg -> Overlay -> [KM] -> m (Either Slideshow KM)

- Game.LambdaHack.Client.UI.WidgetClient: displayMore :: MonadClientUI m => ColorMode -> Msg -> m Bool

- Game.LambdaHack.Client.UI.WidgetClient: displayPush :: MonadClientUI m => Msg -> m ()

- Game.LambdaHack.Client.UI.WidgetClient: displayYesNo :: MonadClientUI m => ColorMode -> Msg -> m Bool

- Game.LambdaHack.Client.UI.WidgetClient: fadeOutOrIn :: MonadClientUI m => Bool -> m ()

- Game.LambdaHack.Client.UI.WidgetClient: overlayToBlankSlideshow :: MonadClientUI m => Bool -> Msg -> Overlay -> m Slideshow

- Game.LambdaHack.Client.UI.WidgetClient: overlayToSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow

- Game.LambdaHack.Client.UI.WidgetClient: promptToSlideshow :: MonadClientUI m => Msg -> m Slideshow

- Game.LambdaHack.Common.Ability: AbTrigger :: Ability

- Game.LambdaHack.Common.Ability: instance Binary Ability

- Game.LambdaHack.Common.Ability: instance Bounded Ability

- Game.LambdaHack.Common.Ability: instance Constructor C1_0Ability

- Game.LambdaHack.Common.Ability: instance Constructor C1_1Ability

- Game.LambdaHack.Common.Ability: instance Constructor C1_2Ability

- Game.LambdaHack.Common.Ability: instance Constructor C1_3Ability

- Game.LambdaHack.Common.Ability: instance Constructor C1_4Ability

- Game.LambdaHack.Common.Ability: instance Constructor C1_5Ability

- Game.LambdaHack.Common.Ability: instance Constructor C1_6Ability

- Game.LambdaHack.Common.Ability: instance Constructor C1_7Ability

- Game.LambdaHack.Common.Ability: instance Constructor C1_8Ability

- Game.LambdaHack.Common.Ability: instance Datatype D1Ability

- Game.LambdaHack.Common.Ability: instance Enum Ability

- Game.LambdaHack.Common.Ability: instance Eq Ability

- Game.LambdaHack.Common.Ability: instance Generic Ability

- Game.LambdaHack.Common.Ability: instance Hashable Ability

- Game.LambdaHack.Common.Ability: instance Ord Ability

- Game.LambdaHack.Common.Ability: instance Read Ability

- Game.LambdaHack.Common.Ability: instance Show Ability

- Game.LambdaHack.Common.Actor: actorNewBorn :: Actor -> Bool

- Game.LambdaHack.Common.Actor: bcalm :: Actor -> !Int64

- Game.LambdaHack.Common.Actor: bcalmDelta :: Actor -> !ResDelta

- Game.LambdaHack.Common.Actor: bcolor :: Actor -> !Color

- Game.LambdaHack.Common.Actor: beqp :: Actor -> !ItemBag

- Game.LambdaHack.Common.Actor: bfid :: Actor -> !FactionId

- Game.LambdaHack.Common.Actor: bfidImpressed :: Actor -> !FactionId

- Game.LambdaHack.Common.Actor: bfidOriginal :: Actor -> !FactionId

- Game.LambdaHack.Common.Actor: bhp :: Actor -> !Int64

- Game.LambdaHack.Common.Actor: bhpDelta :: Actor -> !ResDelta

- Game.LambdaHack.Common.Actor: binv :: Actor -> !ItemBag

- Game.LambdaHack.Common.Actor: blid :: Actor -> !LevelId

- Game.LambdaHack.Common.Actor: bname :: Actor -> !Text

- Game.LambdaHack.Common.Actor: boldlid :: Actor -> !LevelId

- Game.LambdaHack.Common.Actor: boldpos :: Actor -> !(Maybe Point)

- Game.LambdaHack.Common.Actor: borgan :: Actor -> !ItemBag

- Game.LambdaHack.Common.Actor: bpos :: Actor -> !Point

- Game.LambdaHack.Common.Actor: bproj :: Actor -> !Bool

- Game.LambdaHack.Common.Actor: bpronoun :: Actor -> !Text

- Game.LambdaHack.Common.Actor: bsymbol :: Actor -> !Char

- Game.LambdaHack.Common.Actor: btime :: Actor -> !Time

- Game.LambdaHack.Common.Actor: btrajectory :: Actor -> !(Maybe ([Vector], Speed))

- Game.LambdaHack.Common.Actor: btrunk :: Actor -> !ItemId

- Game.LambdaHack.Common.Actor: bwait :: Actor -> !Bool

- Game.LambdaHack.Common.Actor: calmEnough10 :: Actor -> [ItemFull] -> Bool

- Game.LambdaHack.Common.Actor: hpEnough10 :: Actor -> [ItemFull] -> Bool

- Game.LambdaHack.Common.Actor: hpHuge :: Actor -> Bool

- Game.LambdaHack.Common.Actor: instance Binary Actor

- Game.LambdaHack.Common.Actor: instance Binary ResDelta

- Game.LambdaHack.Common.Actor: instance Eq Actor

- Game.LambdaHack.Common.Actor: instance Eq ResDelta

- Game.LambdaHack.Common.Actor: instance Show Actor

- Game.LambdaHack.Common.Actor: instance Show ResDelta

- Game.LambdaHack.Common.Actor: keySelected :: (ActorId, Actor) -> (Bool, Bool, Char, Color, ActorId)

- Game.LambdaHack.Common.Actor: minusM :: Int64

- Game.LambdaHack.Common.Actor: minusTwoM :: Int64

- Game.LambdaHack.Common.Actor: oneM :: Int64

- Game.LambdaHack.Common.Actor: partActor :: Actor -> Part

- Game.LambdaHack.Common.Actor: partPronoun :: Actor -> Part

- Game.LambdaHack.Common.Actor: ppCStore :: CStore -> (Text, Text)

- Game.LambdaHack.Common.Actor: ppCStoreIn :: CStore -> Text

- Game.LambdaHack.Common.Actor: ppContainer :: Container -> Text

- Game.LambdaHack.Common.Actor: resCurrentTurn :: ResDelta -> !Int64

- Game.LambdaHack.Common.Actor: resPreviousTurn :: ResDelta -> !Int64

- Game.LambdaHack.Common.Actor: unoccupied :: [Actor] -> Point -> Bool

- Game.LambdaHack.Common.Actor: verbCStore :: CStore -> Text

- Game.LambdaHack.Common.Actor: xM :: Int -> Int64

- Game.LambdaHack.Common.ActorState: actorAssocsLvl :: (FactionId -> Bool) -> Level -> ActorDict -> [(ActorId, Actor)]

- Game.LambdaHack.Common.ActorState: actorList :: (FactionId -> Bool) -> LevelId -> State -> [Actor]

- Game.LambdaHack.Common.ActorState: actorRegularAssocsLvl :: (FactionId -> Bool) -> Level -> ActorDict -> [(ActorId, Actor)]

- Game.LambdaHack.Common.ActorState: actorRegularList :: (FactionId -> Bool) -> LevelId -> State -> [Actor]

- Game.LambdaHack.Common.ActorState: eqpFreeN :: Actor -> Int

- Game.LambdaHack.Common.ActorState: eqpOverfull :: Actor -> Int -> Bool

- Game.LambdaHack.Common.ActorState: fidActorNotProjList :: FactionId -> State -> [Actor]

- Game.LambdaHack.Common.ActorState: getActorBag :: ActorId -> CStore -> State -> ItemBag

- Game.LambdaHack.Common.ActorState: getBodyActorBag :: Actor -> CStore -> State -> ItemBag

- Game.LambdaHack.Common.ActorState: getCBag :: Container -> State -> ItemBag

- Game.LambdaHack.Common.ActorState: goesIntoEqp :: ItemFull -> Bool

- Game.LambdaHack.Common.ActorState: goesIntoInv :: ItemFull -> Bool

- Game.LambdaHack.Common.ActorState: goesIntoSha :: ItemFull -> Bool

- Game.LambdaHack.Common.ActorState: hasCharge :: Time -> ItemFull -> Bool

- Game.LambdaHack.Common.ActorState: isMelee :: ItemFull -> Bool

- Game.LambdaHack.Common.ActorState: isMeleeEqp :: ItemFull -> Bool

- Game.LambdaHack.Common.ActorState: itemPrice :: (Item, Int) -> Int

- Game.LambdaHack.Common.ActorState: itemToFull :: COps -> DiscoveryKind -> DiscoveryEffect -> ItemId -> Item -> ItemQuant -> ItemFull

- Game.LambdaHack.Common.ActorState: posToActors :: Point -> LevelId -> State -> [(ActorId, Actor)]

- Game.LambdaHack.Common.ActorState: strongestMelee :: Bool -> Time -> [(ItemId, ItemFull)] -> [(Int, (ItemId, ItemFull))]

- Game.LambdaHack.Common.ActorState: tryFindHeroK :: FactionId -> Int -> State -> Maybe (ActorId, Actor)

- Game.LambdaHack.Common.ActorState: whereTo :: LevelId -> Point -> Int -> Dungeon -> (LevelId, Point)

- Game.LambdaHack.Common.ClientOptions: instance Binary DebugModeCli

- Game.LambdaHack.Common.ClientOptions: instance Constructor C1_0DebugModeCli

- Game.LambdaHack.Common.ClientOptions: instance Datatype D1DebugModeCli

- Game.LambdaHack.Common.ClientOptions: instance Eq DebugModeCli

- Game.LambdaHack.Common.ClientOptions: instance Generic DebugModeCli

- Game.LambdaHack.Common.ClientOptions: instance Selector S1_0_0DebugModeCli

- Game.LambdaHack.Common.ClientOptions: instance Selector S1_0_10DebugModeCli

- Game.LambdaHack.Common.ClientOptions: instance Selector S1_0_11DebugModeCli

- Game.LambdaHack.Common.ClientOptions: instance Selector S1_0_1DebugModeCli

- Game.LambdaHack.Common.ClientOptions: instance Selector S1_0_2DebugModeCli

- Game.LambdaHack.Common.ClientOptions: instance Selector S1_0_3DebugModeCli

- Game.LambdaHack.Common.ClientOptions: instance Selector S1_0_4DebugModeCli

- Game.LambdaHack.Common.ClientOptions: instance Selector S1_0_5DebugModeCli

- Game.LambdaHack.Common.ClientOptions: instance Selector S1_0_6DebugModeCli

- Game.LambdaHack.Common.ClientOptions: instance Selector S1_0_7DebugModeCli

- Game.LambdaHack.Common.ClientOptions: instance Selector S1_0_8DebugModeCli

- Game.LambdaHack.Common.ClientOptions: instance Selector S1_0_9DebugModeCli

- Game.LambdaHack.Common.ClientOptions: instance Show DebugModeCli

- Game.LambdaHack.Common.ClientOptions: sbenchmark :: DebugModeCli -> !Bool

- Game.LambdaHack.Common.ClientOptions: scolorIsBold :: DebugModeCli -> !(Maybe Bool)

- Game.LambdaHack.Common.ClientOptions: sdbgMsgCli :: DebugModeCli -> !Bool

- Game.LambdaHack.Common.ClientOptions: sdisableAutoYes :: DebugModeCli -> !Bool

- Game.LambdaHack.Common.ClientOptions: sfont :: DebugModeCli -> !(Maybe String)

- Game.LambdaHack.Common.ClientOptions: sfrontendNull :: DebugModeCli -> !Bool

- Game.LambdaHack.Common.ClientOptions: sfrontendStd :: DebugModeCli -> !Bool

- Game.LambdaHack.Common.ClientOptions: smaxFps :: DebugModeCli -> !(Maybe Int)

- Game.LambdaHack.Common.ClientOptions: snewGameCli :: DebugModeCli -> !Bool

- Game.LambdaHack.Common.ClientOptions: snoAnim :: DebugModeCli -> !(Maybe Bool)

- Game.LambdaHack.Common.ClientOptions: snoDelay :: DebugModeCli -> !Bool

- Game.LambdaHack.Common.ClientOptions: ssavePrefixCli :: DebugModeCli -> !(Maybe String)

- Game.LambdaHack.Common.Color: acAttr :: AttrChar -> !Attr

- Game.LambdaHack.Common.Color: acChar :: AttrChar -> !Char

- Game.LambdaHack.Common.Color: bg :: Attr -> !Color

- Game.LambdaHack.Common.Color: defBG :: Color

- Game.LambdaHack.Common.Color: fg :: Attr -> !Color

- Game.LambdaHack.Common.Color: instance Binary Color

- Game.LambdaHack.Common.Color: instance Bounded Color

- Game.LambdaHack.Common.Color: instance Constructor C1_0Color

- Game.LambdaHack.Common.Color: instance Constructor C1_10Color

- Game.LambdaHack.Common.Color: instance Constructor C1_11Color

- Game.LambdaHack.Common.Color: instance Constructor C1_12Color

- Game.LambdaHack.Common.Color: instance Constructor C1_13Color

- Game.LambdaHack.Common.Color: instance Constructor C1_14Color

- Game.LambdaHack.Common.Color: instance Constructor C1_15Color

- Game.LambdaHack.Common.Color: instance Constructor C1_1Color

- Game.LambdaHack.Common.Color: instance Constructor C1_2Color

- Game.LambdaHack.Common.Color: instance Constructor C1_3Color

- Game.LambdaHack.Common.Color: instance Constructor C1_4Color

- Game.LambdaHack.Common.Color: instance Constructor C1_5Color

- Game.LambdaHack.Common.Color: instance Constructor C1_6Color

- Game.LambdaHack.Common.Color: instance Constructor C1_7Color

- Game.LambdaHack.Common.Color: instance Constructor C1_8Color

- Game.LambdaHack.Common.Color: instance Constructor C1_9Color

- Game.LambdaHack.Common.Color: instance Datatype D1Color

- Game.LambdaHack.Common.Color: instance Enum Attr

- Game.LambdaHack.Common.Color: instance Enum AttrChar

- Game.LambdaHack.Common.Color: instance Enum Color

- Game.LambdaHack.Common.Color: instance Eq Attr

- Game.LambdaHack.Common.Color: instance Eq AttrChar

- Game.LambdaHack.Common.Color: instance Eq Color

- Game.LambdaHack.Common.Color: instance Generic Color

- Game.LambdaHack.Common.Color: instance Hashable Color

- Game.LambdaHack.Common.Color: instance Ord Attr

- Game.LambdaHack.Common.Color: instance Ord AttrChar

- Game.LambdaHack.Common.Color: instance Ord Color

- Game.LambdaHack.Common.Color: instance Show Attr

- Game.LambdaHack.Common.Color: instance Show AttrChar

- Game.LambdaHack.Common.Color: instance Show Color

- Game.LambdaHack.Common.Color: legalBG :: [Color]

- Game.LambdaHack.Common.ContentDef: content :: ContentDef a -> ![a]

- Game.LambdaHack.Common.ContentDef: getFreq :: ContentDef a -> a -> Freqs a

- Game.LambdaHack.Common.ContentDef: getName :: ContentDef a -> a -> Text

- Game.LambdaHack.Common.ContentDef: getSymbol :: ContentDef a -> a -> Char

- Game.LambdaHack.Common.ContentDef: validateAll :: ContentDef a -> [a] -> [Text]

- Game.LambdaHack.Common.ContentDef: validateSingle :: ContentDef a -> a -> [Text]

- Game.LambdaHack.Common.Dice: ds :: Int -> Dice

- Game.LambdaHack.Common.Dice: instance Binary Dice

- Game.LambdaHack.Common.Dice: instance Binary DiceXY

- Game.LambdaHack.Common.Dice: instance Constructor C1_0Dice

- Game.LambdaHack.Common.Dice: instance Constructor C1_0DiceXY

- Game.LambdaHack.Common.Dice: instance Datatype D1Dice

- Game.LambdaHack.Common.Dice: instance Datatype D1DiceXY

- Game.LambdaHack.Common.Dice: instance Eq Dice

- Game.LambdaHack.Common.Dice: instance Eq DiceXY

- Game.LambdaHack.Common.Dice: instance Generic Dice

- Game.LambdaHack.Common.Dice: instance Generic DiceXY

- Game.LambdaHack.Common.Dice: instance Hashable Dice

- Game.LambdaHack.Common.Dice: instance Hashable DiceXY

- Game.LambdaHack.Common.Dice: instance NFData Dice

- Game.LambdaHack.Common.Dice: instance Num Dice

- Game.LambdaHack.Common.Dice: instance Num SimpleDice

- Game.LambdaHack.Common.Dice: instance Ord Dice

- Game.LambdaHack.Common.Dice: instance Ord DiceXY

- Game.LambdaHack.Common.Dice: instance Read Dice

- Game.LambdaHack.Common.Dice: instance Selector S1_0_0Dice

- Game.LambdaHack.Common.Dice: instance Selector S1_0_1Dice

- Game.LambdaHack.Common.Dice: instance Selector S1_0_2Dice

- Game.LambdaHack.Common.Dice: instance Show Dice

- Game.LambdaHack.Common.Dice: instance Show DiceXY

- Game.LambdaHack.Common.EffectDescription: aspectToSuffix :: Aspect Int -> Text

- Game.LambdaHack.Common.EffectDescription: effectToSuffix :: Effect -> Text

- Game.LambdaHack.Common.EffectDescription: featureToSuff :: Feature -> Text

- Game.LambdaHack.Common.EffectDescription: kindAspectToSuffix :: Aspect Dice -> Text

- Game.LambdaHack.Common.EffectDescription: kindEffectToSuffix :: Effect -> Text

- Game.LambdaHack.Common.Faction: gcolor :: Faction -> !Color

- Game.LambdaHack.Common.Faction: gdipl :: Faction -> !Dipl

- Game.LambdaHack.Common.Faction: gleader :: Faction -> !(Maybe (ActorId, Maybe Target))

- Game.LambdaHack.Common.Faction: gname :: Faction -> !Text

- Game.LambdaHack.Common.Faction: gplayer :: Faction -> !(Player Int)

- Game.LambdaHack.Common.Faction: gquit :: Faction -> !(Maybe Status)

- Game.LambdaHack.Common.Faction: gsha :: Faction -> !ItemBag

- Game.LambdaHack.Common.Faction: gvictims :: Faction -> !(EnumMap (Id ItemKind) Int)

- Game.LambdaHack.Common.Faction: instance Binary Diplomacy

- Game.LambdaHack.Common.Faction: instance Binary Faction

- Game.LambdaHack.Common.Faction: instance Binary Status

- Game.LambdaHack.Common.Faction: instance Binary Target

- Game.LambdaHack.Common.Faction: instance Enum Diplomacy

- Game.LambdaHack.Common.Faction: instance Eq Diplomacy

- Game.LambdaHack.Common.Faction: instance Eq Faction

- Game.LambdaHack.Common.Faction: instance Eq Status

- Game.LambdaHack.Common.Faction: instance Eq Target

- Game.LambdaHack.Common.Faction: instance Ord Diplomacy

- Game.LambdaHack.Common.Faction: instance Ord Faction

- Game.LambdaHack.Common.Faction: instance Ord Status

- Game.LambdaHack.Common.Faction: instance Ord Target

- Game.LambdaHack.Common.Faction: instance Show Diplomacy

- Game.LambdaHack.Common.Faction: instance Show Faction

- Game.LambdaHack.Common.Faction: instance Show Status

- Game.LambdaHack.Common.Faction: instance Show Target

- Game.LambdaHack.Common.Faction: stDepth :: Status -> !Int

- Game.LambdaHack.Common.Faction: stNewGame :: Status -> !(Maybe (GroupName ModeKind))

- Game.LambdaHack.Common.Faction: stOutcome :: Status -> !Outcome

- Game.LambdaHack.Common.File: appDataDir :: IO FilePath

- Game.LambdaHack.Common.File: tryCopyDataFiles :: FilePath -> (FilePath -> IO FilePath) -> [(FilePath, FilePath)] -> IO ()

- Game.LambdaHack.Common.Flavour: instance Binary FancyName

- Game.LambdaHack.Common.Flavour: instance Binary Flavour

- Game.LambdaHack.Common.Flavour: instance Constructor C1_0FancyName

- Game.LambdaHack.Common.Flavour: instance Constructor C1_0Flavour

- Game.LambdaHack.Common.Flavour: instance Constructor C1_1FancyName

- Game.LambdaHack.Common.Flavour: instance Constructor C1_2FancyName

- Game.LambdaHack.Common.Flavour: instance Datatype D1FancyName

- Game.LambdaHack.Common.Flavour: instance Datatype D1Flavour

- Game.LambdaHack.Common.Flavour: instance Eq FancyName

- Game.LambdaHack.Common.Flavour: instance Eq Flavour

- Game.LambdaHack.Common.Flavour: instance Generic FancyName

- Game.LambdaHack.Common.Flavour: instance Generic Flavour

- Game.LambdaHack.Common.Flavour: instance Hashable FancyName

- Game.LambdaHack.Common.Flavour: instance Hashable Flavour

- Game.LambdaHack.Common.Flavour: instance Ord FancyName

- Game.LambdaHack.Common.Flavour: instance Ord Flavour

- Game.LambdaHack.Common.Flavour: instance Selector S1_0_0Flavour

- Game.LambdaHack.Common.Flavour: instance Selector S1_0_1Flavour

- Game.LambdaHack.Common.Flavour: instance Show FancyName

- Game.LambdaHack.Common.Flavour: instance Show Flavour

- Game.LambdaHack.Common.Frequency: instance Alternative Frequency

- Game.LambdaHack.Common.Frequency: instance Applicative Frequency

- Game.LambdaHack.Common.Frequency: instance Binary a => Binary (Frequency a)

- Game.LambdaHack.Common.Frequency: instance Constructor C1_0Frequency

- Game.LambdaHack.Common.Frequency: instance Datatype D1Frequency

- Game.LambdaHack.Common.Frequency: instance Eq a => Eq (Frequency a)

- Game.LambdaHack.Common.Frequency: instance Foldable Frequency

- Game.LambdaHack.Common.Frequency: instance Functor Frequency

- Game.LambdaHack.Common.Frequency: instance Generic (Frequency a)

- Game.LambdaHack.Common.Frequency: instance Hashable a => Hashable (Frequency a)

- Game.LambdaHack.Common.Frequency: instance Monad Frequency

- Game.LambdaHack.Common.Frequency: instance MonadPlus Frequency

- Game.LambdaHack.Common.Frequency: instance NFData a => NFData (Frequency a)

- Game.LambdaHack.Common.Frequency: instance Ord a => Ord (Frequency a)

- Game.LambdaHack.Common.Frequency: instance Read a => Read (Frequency a)

- Game.LambdaHack.Common.Frequency: instance Selector S1_0_0Frequency

- Game.LambdaHack.Common.Frequency: instance Selector S1_0_1Frequency

- Game.LambdaHack.Common.Frequency: instance Show a => Show (Frequency a)

- Game.LambdaHack.Common.Frequency: instance Traversable Frequency

- Game.LambdaHack.Common.HighScore: instance Binary ClockTime

- Game.LambdaHack.Common.HighScore: instance Binary ScoreRecord

- Game.LambdaHack.Common.HighScore: instance Binary ScoreTable

- Game.LambdaHack.Common.HighScore: instance Constructor C1_0ScoreRecord

- Game.LambdaHack.Common.HighScore: instance Datatype D1ScoreRecord

- Game.LambdaHack.Common.HighScore: instance Eq ScoreRecord

- Game.LambdaHack.Common.HighScore: instance Eq ScoreTable

- Game.LambdaHack.Common.HighScore: instance Generic ScoreRecord

- Game.LambdaHack.Common.HighScore: instance Ord ScoreRecord

- Game.LambdaHack.Common.HighScore: instance Selector S1_0_0ScoreRecord

- Game.LambdaHack.Common.HighScore: instance Selector S1_0_1ScoreRecord

- Game.LambdaHack.Common.HighScore: instance Selector S1_0_2ScoreRecord

- Game.LambdaHack.Common.HighScore: instance Selector S1_0_3ScoreRecord

- Game.LambdaHack.Common.HighScore: instance Selector S1_0_4ScoreRecord

- Game.LambdaHack.Common.HighScore: instance Selector S1_0_5ScoreRecord

- Game.LambdaHack.Common.HighScore: instance Selector S1_0_6ScoreRecord

- Game.LambdaHack.Common.HighScore: instance Selector S1_0_7ScoreRecord

- Game.LambdaHack.Common.HighScore: instance Show ScoreRecord

- Game.LambdaHack.Common.HighScore: instance Show ScoreTable

- Game.LambdaHack.Common.Item: ItemAspectEffect :: ![Aspect Int] -> ![Effect] -> ItemAspectEffect

- Game.LambdaHack.Common.Item: data ItemAspectEffect

- Game.LambdaHack.Common.Item: instance Binary Item

- Game.LambdaHack.Common.Item: instance Binary ItemAspectEffect

- Game.LambdaHack.Common.Item: instance Binary ItemId

- Game.LambdaHack.Common.Item: instance Binary ItemKindIx

- Game.LambdaHack.Common.Item: instance Binary ItemSeed

- Game.LambdaHack.Common.Item: instance Constructor C1_0Item

- Game.LambdaHack.Common.Item: instance Constructor C1_0ItemAspectEffect

- Game.LambdaHack.Common.Item: instance Datatype D1Item

- Game.LambdaHack.Common.Item: instance Datatype D1ItemAspectEffect

- Game.LambdaHack.Common.Item: instance Enum ItemId

- Game.LambdaHack.Common.Item: instance Enum ItemKindIx

- Game.LambdaHack.Common.Item: instance Enum ItemSeed

- Game.LambdaHack.Common.Item: instance Eq Item

- Game.LambdaHack.Common.Item: instance Eq ItemAspectEffect

- Game.LambdaHack.Common.Item: instance Eq ItemId

- Game.LambdaHack.Common.Item: instance Eq ItemKindIx

- Game.LambdaHack.Common.Item: instance Eq ItemSeed

- Game.LambdaHack.Common.Item: instance Generic Item

- Game.LambdaHack.Common.Item: instance Generic ItemAspectEffect

- Game.LambdaHack.Common.Item: instance Hashable Item

- Game.LambdaHack.Common.Item: instance Hashable ItemAspectEffect

- Game.LambdaHack.Common.Item: instance Hashable ItemKindIx

- Game.LambdaHack.Common.Item: instance Hashable ItemSeed

- Game.LambdaHack.Common.Item: instance Ix ItemKindIx

- Game.LambdaHack.Common.Item: instance Ord ItemId

- Game.LambdaHack.Common.Item: instance Ord ItemKindIx

- Game.LambdaHack.Common.Item: instance Ord ItemSeed

- Game.LambdaHack.Common.Item: instance Selector S1_0_0Item

- Game.LambdaHack.Common.Item: instance Selector S1_0_0ItemAspectEffect

- Game.LambdaHack.Common.Item: instance Selector S1_0_1Item

- Game.LambdaHack.Common.Item: instance Selector S1_0_1ItemAspectEffect

- Game.LambdaHack.Common.Item: instance Selector S1_0_2Item

- Game.LambdaHack.Common.Item: instance Selector S1_0_3Item

- Game.LambdaHack.Common.Item: instance Selector S1_0_4Item

- Game.LambdaHack.Common.Item: instance Selector S1_0_5Item

- Game.LambdaHack.Common.Item: instance Selector S1_0_6Item

- Game.LambdaHack.Common.Item: instance Show Item

- Game.LambdaHack.Common.Item: instance Show ItemAspectEffect

- Game.LambdaHack.Common.Item: instance Show ItemDisco

- Game.LambdaHack.Common.Item: instance Show ItemFull

- Game.LambdaHack.Common.Item: instance Show ItemId

- Game.LambdaHack.Common.Item: instance Show ItemKindIx

- Game.LambdaHack.Common.Item: instance Show ItemSeed

- Game.LambdaHack.Common.Item: itemAE :: ItemDisco -> !(Maybe ItemAspectEffect)

- Game.LambdaHack.Common.Item: itemBase :: ItemFull -> !Item

- Game.LambdaHack.Common.Item: itemDisco :: ItemFull -> !(Maybe ItemDisco)

- Game.LambdaHack.Common.Item: itemK :: ItemFull -> !Int

- Game.LambdaHack.Common.Item: itemKind :: ItemDisco -> !ItemKind

- Game.LambdaHack.Common.Item: itemKindId :: ItemDisco -> !(Id ItemKind)

- Game.LambdaHack.Common.Item: itemNoAE :: ItemFull -> ItemFull

- Game.LambdaHack.Common.Item: itemTimer :: ItemFull -> !ItemTimer

- Game.LambdaHack.Common.Item: jaspects :: ItemAspectEffect -> ![Aspect Int]

- Game.LambdaHack.Common.Item: jeffects :: ItemAspectEffect -> ![Effect]

- Game.LambdaHack.Common.Item: jfeature :: Item -> ![Feature]

- Game.LambdaHack.Common.Item: jflavour :: Item -> !Flavour

- Game.LambdaHack.Common.Item: jkindIx :: Item -> !ItemKindIx

- Game.LambdaHack.Common.Item: jlid :: Item -> !LevelId

- Game.LambdaHack.Common.Item: jname :: Item -> !Text

- Game.LambdaHack.Common.Item: jsymbol :: Item -> !Char

- Game.LambdaHack.Common.Item: jweight :: Item -> !Int

- Game.LambdaHack.Common.Item: seedToAspectsEffects :: ItemSeed -> ItemKind -> AbsDepth -> AbsDepth -> ItemAspectEffect

- Game.LambdaHack.Common.Item: type DiscoveryEffect = EnumMap ItemId ItemAspectEffect

- Game.LambdaHack.Common.Item: type ItemKnown = (ItemKindIx, ItemAspectEffect)

- Game.LambdaHack.Common.ItemDescription: itemDesc :: CStore -> Time -> ItemFull -> Overlay

- Game.LambdaHack.Common.ItemDescription: partItem :: CStore -> Time -> ItemFull -> (Bool, Part, Part)

- Game.LambdaHack.Common.ItemDescription: partItemAW :: CStore -> Time -> ItemFull -> Part

- Game.LambdaHack.Common.ItemDescription: partItemMediumAW :: CStore -> Time -> ItemFull -> Part

- Game.LambdaHack.Common.ItemDescription: partItemN :: Int -> Int -> CStore -> Time -> ItemFull -> (Bool, Part, Part)

- Game.LambdaHack.Common.ItemDescription: partItemWownW :: Part -> CStore -> Time -> ItemFull -> Part

- Game.LambdaHack.Common.ItemDescription: partItemWs :: Int -> CStore -> Time -> ItemFull -> Part

- Game.LambdaHack.Common.ItemDescription: textAllAE :: Int -> Bool -> CStore -> ItemFull -> [Text]

- Game.LambdaHack.Common.ItemDescription: viewItem :: Item -> (Char, Attr)

- Game.LambdaHack.Common.ItemStrongest: allRecharging :: [Effect] -> [Effect]

- Game.LambdaHack.Common.ItemStrongest: strengthFromEqpSlot :: EqpSlot -> ItemFull -> Maybe Int

- Game.LambdaHack.Common.ItemStrongest: strongestSlotNoFilter :: EqpSlot -> [(ItemId, ItemFull)] -> [(Int, (ItemId, ItemFull))]

- Game.LambdaHack.Common.ItemStrongest: sumSkills :: [ItemFull] -> Skills

- Game.LambdaHack.Common.ItemStrongest: sumSlotNoFilter :: EqpSlot -> [ItemFull] -> Int

- Game.LambdaHack.Common.Kind: cocave :: COps -> !(Ops CaveKind)

- Game.LambdaHack.Common.Kind: coitem :: COps -> !(Ops ItemKind)

- Game.LambdaHack.Common.Kind: comode :: COps -> !(Ops ModeKind)

- Game.LambdaHack.Common.Kind: coplace :: COps -> !(Ops PlaceKind)

- Game.LambdaHack.Common.Kind: corule :: COps -> !(Ops RuleKind)

- Game.LambdaHack.Common.Kind: cotile :: COps -> !(Ops TileKind)

- Game.LambdaHack.Common.Kind: instance Binary (Id c)

- Game.LambdaHack.Common.Kind: instance Bounded (Id c)

- Game.LambdaHack.Common.Kind: instance Enum (Id c)

- Game.LambdaHack.Common.Kind: instance Eq (Id c)

- Game.LambdaHack.Common.Kind: instance Eq COps

- Game.LambdaHack.Common.Kind: instance Ix (Id c)

- Game.LambdaHack.Common.Kind: instance Ord (Id c)

- Game.LambdaHack.Common.Kind: instance Show (Id c)

- Game.LambdaHack.Common.Kind: instance Show COps

- Game.LambdaHack.Common.Kind: obounds :: Ops a -> !(Id a, Id a)

- Game.LambdaHack.Common.Kind: ofoldrGroup :: Ops a -> forall b. GroupName a -> (Int -> Id a -> a -> b -> b) -> b -> b

- Game.LambdaHack.Common.Kind: ofoldrWithKey :: Ops a -> forall b. (Id a -> a -> b -> b) -> b -> b

- Game.LambdaHack.Common.Kind: okind :: Ops a -> Id a -> a

- Game.LambdaHack.Common.Kind: opick :: Ops a -> GroupName a -> (a -> Bool) -> Rnd (Maybe (Id a))

- Game.LambdaHack.Common.Kind: ospeedup :: Ops a -> !(Maybe (Speedup a))

- Game.LambdaHack.Common.Kind: ouniqGroup :: Ops a -> GroupName a -> Id a

- Game.LambdaHack.Common.LQueue: dropStartLQueue :: LQueue (Maybe a) -> LQueue (Maybe a)

- Game.LambdaHack.Common.LQueue: lastLQueue :: LQueue (Maybe a) -> Maybe a

- Game.LambdaHack.Common.LQueue: lengthLQueue :: LQueue a -> Int

- Game.LambdaHack.Common.LQueue: newLQueue :: LQueue a

- Game.LambdaHack.Common.LQueue: nullLQueue :: LQueue a -> Bool

- Game.LambdaHack.Common.LQueue: toListLQueue :: LQueue a -> [a]

- Game.LambdaHack.Common.LQueue: trimLQueue :: LQueue (Maybe a) -> LQueue (Maybe a)

- Game.LambdaHack.Common.LQueue: tryReadLQueue :: LQueue a -> Maybe (a, LQueue a)

- Game.LambdaHack.Common.LQueue: type LQueue a = ([a], [a])

- Game.LambdaHack.Common.LQueue: writeLQueue :: LQueue a -> a -> LQueue a

- Game.LambdaHack.Common.Level: accessible :: COps -> Level -> Point -> Point -> Bool

- Game.LambdaHack.Common.Level: accessibleDir :: COps -> Level -> Point -> Vector -> Bool

- Game.LambdaHack.Common.Level: accessibleUnknown :: COps -> Level -> Point -> Point -> Bool

- Game.LambdaHack.Common.Level: checkAccess :: COps -> Level -> Maybe (Point -> Point -> Bool)

- Game.LambdaHack.Common.Level: checkDoorAccess :: COps -> Level -> Maybe (Point -> Point -> Bool)

- Game.LambdaHack.Common.Level: hideTile :: COps -> Level -> Point -> Id TileKind

- Game.LambdaHack.Common.Level: instance Binary Level

- Game.LambdaHack.Common.Level: instance Eq Level

- Game.LambdaHack.Common.Level: instance Show Level

- Game.LambdaHack.Common.Level: isSecretPos :: Level -> Point -> Bool

- Game.LambdaHack.Common.Level: knownLsecret :: Level -> Bool

- Game.LambdaHack.Common.Level: lactorCoeff :: Level -> !Int

- Game.LambdaHack.Common.Level: lactorFreq :: Level -> !(Freqs ItemKind)

- Game.LambdaHack.Common.Level: lclear :: Level -> !Int

- Game.LambdaHack.Common.Level: ldepth :: Level -> !AbsDepth

- Game.LambdaHack.Common.Level: ldesc :: Level -> !Text

- Game.LambdaHack.Common.Level: lembed :: Level -> !ItemFloor

- Game.LambdaHack.Common.Level: lescape :: Level -> ![Point]

- Game.LambdaHack.Common.Level: lfloor :: Level -> !ItemFloor

- Game.LambdaHack.Common.Level: lhidden :: Level -> !Int

- Game.LambdaHack.Common.Level: litemFreq :: Level -> !(Freqs ItemKind)

- Game.LambdaHack.Common.Level: litemNum :: Level -> !Int

- Game.LambdaHack.Common.Level: lprio :: Level -> !ActorPrio

- Game.LambdaHack.Common.Level: lsecret :: Level -> !Int

- Game.LambdaHack.Common.Level: lseen :: Level -> !Int

- Game.LambdaHack.Common.Level: lsmell :: Level -> !SmellMap

- Game.LambdaHack.Common.Level: lstair :: Level -> !([Point], [Point])

- Game.LambdaHack.Common.Level: ltile :: Level -> !TileMap

- Game.LambdaHack.Common.Level: ltime :: Level -> !Time

- Game.LambdaHack.Common.Level: lxsize :: Level -> !X

- Game.LambdaHack.Common.Level: lysize :: Level -> !Y

- Game.LambdaHack.Common.Level: mapDungeonActors_ :: Monad m => (ActorId -> m a) -> Dungeon -> m ()

- Game.LambdaHack.Common.Level: mapLevelActors_ :: Monad m => (ActorId -> m a) -> Level -> m ()

- Game.LambdaHack.Common.Level: type ActorPrio = EnumMap Time [ActorId]

- Game.LambdaHack.Common.Misc: divUp :: Integral a => a -> a -> a

- Game.LambdaHack.Common.Misc: instance (Binary k, Binary v, Eq k, Hashable k) => Binary (HashMap k v)

- Game.LambdaHack.Common.Misc: instance (Enum k, Binary k) => Binary (EnumSet k)

- Game.LambdaHack.Common.Misc: instance (Enum k, Binary k, Binary e) => Binary (EnumMap k e)

- Game.LambdaHack.Common.Misc: instance (Enum k, Hashable k, Hashable e) => Hashable (EnumMap k e)

- Game.LambdaHack.Common.Misc: instance Binary (GroupName a)

- Game.LambdaHack.Common.Misc: instance Binary AbsDepth

- Game.LambdaHack.Common.Misc: instance Binary ActorId

- Game.LambdaHack.Common.Misc: instance Binary CStore

- Game.LambdaHack.Common.Misc: instance Binary Container

- Game.LambdaHack.Common.Misc: instance Binary FactionId

- Game.LambdaHack.Common.Misc: instance Binary LevelId

- Game.LambdaHack.Common.Misc: instance Binary Tactic

- Game.LambdaHack.Common.Misc: instance Bounded CStore

- Game.LambdaHack.Common.Misc: instance Bounded Tactic

- Game.LambdaHack.Common.Misc: instance Constructor C1_0CStore

- Game.LambdaHack.Common.Misc: instance Constructor C1_0Container

- Game.LambdaHack.Common.Misc: instance Constructor C1_0GroupName

- Game.LambdaHack.Common.Misc: instance Constructor C1_0ItemDialogMode

- Game.LambdaHack.Common.Misc: instance Constructor C1_0Tactic

- Game.LambdaHack.Common.Misc: instance Constructor C1_1CStore

- Game.LambdaHack.Common.Misc: instance Constructor C1_1Container

- Game.LambdaHack.Common.Misc: instance Constructor C1_1ItemDialogMode

- Game.LambdaHack.Common.Misc: instance Constructor C1_1Tactic

- Game.LambdaHack.Common.Misc: instance Constructor C1_2CStore

- Game.LambdaHack.Common.Misc: instance Constructor C1_2Container

- Game.LambdaHack.Common.Misc: instance Constructor C1_2ItemDialogMode

- Game.LambdaHack.Common.Misc: instance Constructor C1_2Tactic

- Game.LambdaHack.Common.Misc: instance Constructor C1_3CStore

- Game.LambdaHack.Common.Misc: instance Constructor C1_3Container

- Game.LambdaHack.Common.Misc: instance Constructor C1_3Tactic

- Game.LambdaHack.Common.Misc: instance Constructor C1_4CStore

- Game.LambdaHack.Common.Misc: instance Constructor C1_4Tactic

- Game.LambdaHack.Common.Misc: instance Constructor C1_5Tactic

- Game.LambdaHack.Common.Misc: instance Constructor C1_6Tactic

- Game.LambdaHack.Common.Misc: instance Constructor C1_7Tactic

- Game.LambdaHack.Common.Misc: instance Datatype D1CStore

- Game.LambdaHack.Common.Misc: instance Datatype D1Container

- Game.LambdaHack.Common.Misc: instance Datatype D1GroupName

- Game.LambdaHack.Common.Misc: instance Datatype D1ItemDialogMode

- Game.LambdaHack.Common.Misc: instance Datatype D1Tactic

- Game.LambdaHack.Common.Misc: instance Enum ActorId

- Game.LambdaHack.Common.Misc: instance Enum CStore

- Game.LambdaHack.Common.Misc: instance Enum FactionId

- Game.LambdaHack.Common.Misc: instance Enum LevelId

- Game.LambdaHack.Common.Misc: instance Enum Tactic

- Game.LambdaHack.Common.Misc: instance Enum k => Adjustable (EnumMap k)

- Game.LambdaHack.Common.Misc: instance Enum k => FoldableWithKey (EnumMap k)

- Game.LambdaHack.Common.Misc: instance Enum k => Indexable (EnumMap k)

- Game.LambdaHack.Common.Misc: instance Enum k => Keyed (EnumMap k)

- Game.LambdaHack.Common.Misc: instance Enum k => Lookup (EnumMap k)

- Game.LambdaHack.Common.Misc: instance Enum k => TraversableWithKey (EnumMap k)

- Game.LambdaHack.Common.Misc: instance Enum k => ZipWithKey (EnumMap k)

- Game.LambdaHack.Common.Misc: instance Eq (GroupName a)

- Game.LambdaHack.Common.Misc: instance Eq AbsDepth

- Game.LambdaHack.Common.Misc: instance Eq ActorId

- Game.LambdaHack.Common.Misc: instance Eq CStore

- Game.LambdaHack.Common.Misc: instance Eq Container

- Game.LambdaHack.Common.Misc: instance Eq FactionId

- Game.LambdaHack.Common.Misc: instance Eq ItemDialogMode

- Game.LambdaHack.Common.Misc: instance Eq LevelId

- Game.LambdaHack.Common.Misc: instance Eq Tactic

- Game.LambdaHack.Common.Misc: instance Generic (GroupName a)

- Game.LambdaHack.Common.Misc: instance Generic CStore

- Game.LambdaHack.Common.Misc: instance Generic Container

- Game.LambdaHack.Common.Misc: instance Generic ItemDialogMode

- Game.LambdaHack.Common.Misc: instance Generic Tactic

- Game.LambdaHack.Common.Misc: instance Hashable (GroupName a)

- Game.LambdaHack.Common.Misc: instance Hashable AbsDepth

- Game.LambdaHack.Common.Misc: instance Hashable CStore

- Game.LambdaHack.Common.Misc: instance Hashable LevelId

- Game.LambdaHack.Common.Misc: instance Hashable Tactic

- Game.LambdaHack.Common.Misc: instance IsString (GroupName a)

- Game.LambdaHack.Common.Misc: instance NFData (GroupName a)

- Game.LambdaHack.Common.Misc: instance NFData CStore

- Game.LambdaHack.Common.Misc: instance NFData ItemDialogMode

- Game.LambdaHack.Common.Misc: instance NFData Part

- Game.LambdaHack.Common.Misc: instance NFData Person

- Game.LambdaHack.Common.Misc: instance NFData Polarity

- Game.LambdaHack.Common.Misc: instance Ord (GroupName a)

- Game.LambdaHack.Common.Misc: instance Ord AbsDepth

- Game.LambdaHack.Common.Misc: instance Ord ActorId

- Game.LambdaHack.Common.Misc: instance Ord CStore

- Game.LambdaHack.Common.Misc: instance Ord Container

- Game.LambdaHack.Common.Misc: instance Ord FactionId

- Game.LambdaHack.Common.Misc: instance Ord ItemDialogMode

- Game.LambdaHack.Common.Misc: instance Ord LevelId

- Game.LambdaHack.Common.Misc: instance Ord Tactic

- Game.LambdaHack.Common.Misc: instance Read (GroupName a)

- Game.LambdaHack.Common.Misc: instance Read CStore

- Game.LambdaHack.Common.Misc: instance Read ItemDialogMode

- Game.LambdaHack.Common.Misc: instance Show (GroupName a)

- Game.LambdaHack.Common.Misc: instance Show AbsDepth

- Game.LambdaHack.Common.Misc: instance Show ActorId

- Game.LambdaHack.Common.Misc: instance Show CStore

- Game.LambdaHack.Common.Misc: instance Show Container

- Game.LambdaHack.Common.Misc: instance Show FactionId

- Game.LambdaHack.Common.Misc: instance Show ItemDialogMode

- Game.LambdaHack.Common.Misc: instance Show LevelId

- Game.LambdaHack.Common.Misc: instance Show Tactic

- Game.LambdaHack.Common.Misc: instance Zip (EnumMap k)

- Game.LambdaHack.Common.Misc: isRight :: Either a b -> Bool

- Game.LambdaHack.Common.Misc: serverSaveName :: String

- Game.LambdaHack.Common.MonadStateRead: factionCanEscape :: MonadStateRead m => FactionId -> m Bool

- Game.LambdaHack.Common.MonadStateRead: posOfAid :: MonadStateRead m => ActorId -> m (LevelId, Point)

- Game.LambdaHack.Common.Msg: (<+>) :: Text -> Text -> Text

- Game.LambdaHack.Common.Msg: (<>) :: Monoid m => m -> m -> m

- Game.LambdaHack.Common.Msg: addMsg :: Report -> Msg -> Report

- Game.LambdaHack.Common.Msg: addReport :: History -> Time -> Report -> History

- Game.LambdaHack.Common.Msg: data History

- Game.LambdaHack.Common.Msg: data Overlay

- Game.LambdaHack.Common.Msg: data Report

- Game.LambdaHack.Common.Msg: data Slideshow

- Game.LambdaHack.Common.Msg: emptyHistory :: Int -> History

- Game.LambdaHack.Common.Msg: emptyOverlay :: Overlay

- Game.LambdaHack.Common.Msg: emptyReport :: Report

- Game.LambdaHack.Common.Msg: encodeLine :: [AttrChar] -> ScreenLine

- Game.LambdaHack.Common.Msg: encodeOverlay :: [[AttrChar]] -> Overlay

- Game.LambdaHack.Common.Msg: endMsg :: Msg

- Game.LambdaHack.Common.Msg: findInReport :: (ByteString -> Bool) -> Report -> Maybe ByteString

- Game.LambdaHack.Common.Msg: instance Binary History

- Game.LambdaHack.Common.Msg: instance Binary Overlay

- Game.LambdaHack.Common.Msg: instance Binary Report

- Game.LambdaHack.Common.Msg: instance Eq Overlay

- Game.LambdaHack.Common.Msg: instance Eq Slideshow

- Game.LambdaHack.Common.Msg: instance Monoid Slideshow

- Game.LambdaHack.Common.Msg: instance Show History

- Game.LambdaHack.Common.Msg: instance Show Overlay

- Game.LambdaHack.Common.Msg: instance Show Report

- Game.LambdaHack.Common.Msg: instance Show Slideshow

- Game.LambdaHack.Common.Msg: lastMsgOfReport :: Report -> (ByteString, Report)

- Game.LambdaHack.Common.Msg: lastReportOfHistory :: History -> Maybe Report

- Game.LambdaHack.Common.Msg: lengthHistory :: History -> Int

- Game.LambdaHack.Common.Msg: makePhrase :: [Part] -> Text

- Game.LambdaHack.Common.Msg: makeSentence :: [Part] -> Text

- Game.LambdaHack.Common.Msg: moreMsg :: Msg

- Game.LambdaHack.Common.Msg: nullReport :: Report -> Bool

- Game.LambdaHack.Common.Msg: prependMsg :: Msg -> Report -> Report

- Game.LambdaHack.Common.Msg: renderHistory :: History -> Overlay

- Game.LambdaHack.Common.Msg: renderReport :: Report -> Text

- Game.LambdaHack.Common.Msg: singletonReport :: Msg -> Report

- Game.LambdaHack.Common.Msg: splitOverlay :: Maybe Bool -> Y -> Overlay -> Overlay -> Slideshow

- Game.LambdaHack.Common.Msg: splitReport :: X -> Report -> Overlay

- Game.LambdaHack.Common.Msg: splitText :: X -> Text -> [Text]

- Game.LambdaHack.Common.Msg: toOverlay :: [Text] -> Overlay

- Game.LambdaHack.Common.Msg: toScreenLine :: Text -> ScreenLine

- Game.LambdaHack.Common.Msg: toSlideshow :: Maybe Bool -> [[Text]] -> Slideshow

- Game.LambdaHack.Common.Msg: toWidth :: Int -> Text -> Text

- Game.LambdaHack.Common.Msg: truncateMsg :: X -> Text -> Text

- Game.LambdaHack.Common.Msg: truncateToOverlay :: Text -> Overlay

- Game.LambdaHack.Common.Msg: tshow :: Show a => a -> Text

- Game.LambdaHack.Common.Msg: type Msg = Text

- Game.LambdaHack.Common.Msg: type ScreenLine = Vector Int32

- Game.LambdaHack.Common.Msg: yesnoMsg :: Msg

- Game.LambdaHack.Common.Perception: PerceptionVisible :: EnumSet Point -> PerceptionVisible

- Game.LambdaHack.Common.Perception: instance Binary Perception

- Game.LambdaHack.Common.Perception: instance Binary PerceptionVisible

- Game.LambdaHack.Common.Perception: instance Constructor C1_0Perception

- Game.LambdaHack.Common.Perception: instance Datatype D1Perception

- Game.LambdaHack.Common.Perception: instance Eq Perception

- Game.LambdaHack.Common.Perception: instance Eq PerceptionVisible

- Game.LambdaHack.Common.Perception: instance Generic Perception

- Game.LambdaHack.Common.Perception: instance Selector S1_0_0Perception

- Game.LambdaHack.Common.Perception: instance Selector S1_0_1Perception

- Game.LambdaHack.Common.Perception: instance Show Perception

- Game.LambdaHack.Common.Perception: instance Show PerceptionVisible

- Game.LambdaHack.Common.Perception: newtype PerceptionVisible

- Game.LambdaHack.Common.Perception: smellVisible :: Perception -> EnumSet Point

- Game.LambdaHack.Common.Perception: type FactionPers = EnumMap LevelId Perception

- Game.LambdaHack.Common.Perception: type Pers = EnumMap FactionId FactionPers

- Game.LambdaHack.Common.Point: instance Binary Point

- Game.LambdaHack.Common.Point: instance Constructor C1_0Point

- Game.LambdaHack.Common.Point: instance Datatype D1Point

- Game.LambdaHack.Common.Point: instance Enum Point

- Game.LambdaHack.Common.Point: instance Eq Point

- Game.LambdaHack.Common.Point: instance Generic Point

- Game.LambdaHack.Common.Point: instance NFData Point

- Game.LambdaHack.Common.Point: instance Ord Point

- Game.LambdaHack.Common.Point: instance Read Point

- Game.LambdaHack.Common.Point: instance Selector S1_0_0Point

- Game.LambdaHack.Common.Point: instance Selector S1_0_1Point

- Game.LambdaHack.Common.Point: instance Show Point

- Game.LambdaHack.Common.Point: px :: Point -> !X

- Game.LambdaHack.Common.Point: py :: Point -> !Y

- Game.LambdaHack.Common.PointArray: data Array c

- Game.LambdaHack.Common.PointArray: foldlA :: Enum c => (a -> c -> a) -> a -> Array c -> a

- Game.LambdaHack.Common.PointArray: ifoldlA :: Enum c => (a -> Point -> c -> a) -> a -> Array c -> a

- Game.LambdaHack.Common.PointArray: instance Binary (Array c)

- Game.LambdaHack.Common.PointArray: instance Eq (Array c)

- Game.LambdaHack.Common.PointArray: instance Show (Array c)

- Game.LambdaHack.Common.PointArray: mapWithKeyMA :: Enum c => Monad m => (Point -> c -> m ()) -> Array c -> m ()

- Game.LambdaHack.Common.Request: NoChangeLvlLeader :: ReqFailure

- Game.LambdaHack.Common.Request: ProjectFragile :: ReqFailure

- Game.LambdaHack.Common.Request: ProjectNotRanged :: ReqFailure

- Game.LambdaHack.Common.Request: ReqAILeader :: !ActorId -> !(Maybe Target) -> !RequestAI -> RequestAI

- Game.LambdaHack.Common.Request: ReqAIPong :: RequestAI

- Game.LambdaHack.Common.Request: ReqAlter :: !Point -> !(Maybe Feature) -> RequestTimed AbAlter

- Game.LambdaHack.Common.Request: ReqApply :: !ItemId -> !CStore -> RequestTimed AbApply

- Game.LambdaHack.Common.Request: ReqDisplace :: !ActorId -> RequestTimed AbDisplace

- Game.LambdaHack.Common.Request: ReqMelee :: !ActorId -> !ItemId -> !CStore -> RequestTimed AbMelee

- Game.LambdaHack.Common.Request: ReqMove :: !Vector -> RequestTimed AbMove

- Game.LambdaHack.Common.Request: ReqMoveItems :: ![(ItemId, Int, CStore, CStore)] -> RequestTimed AbMoveItem

- Game.LambdaHack.Common.Request: ReqProject :: !Point -> !Int -> !ItemId -> !CStore -> RequestTimed AbProject

- Game.LambdaHack.Common.Request: ReqTrigger :: !(Maybe Feature) -> RequestTimed AbTrigger

- Game.LambdaHack.Common.Request: ReqUILeader :: !ActorId -> !(Maybe Target) -> !RequestUI -> RequestUI

- Game.LambdaHack.Common.Request: ReqUIPong :: [CmdAtomic] -> RequestUI

- Game.LambdaHack.Common.Request: ReqWait :: RequestTimed AbWait

- Game.LambdaHack.Common.Request: anyToUI :: RequestAnyAbility -> RequestUI

- Game.LambdaHack.Common.Request: data RequestAI

- Game.LambdaHack.Common.Request: data RequestUI

- Game.LambdaHack.Common.Request: instance Show (RequestTimed a)

- Game.LambdaHack.Common.Request: instance Show RequestAI

- Game.LambdaHack.Common.Request: instance Show RequestAnyAbility

- Game.LambdaHack.Common.Request: instance Show RequestUI

- Game.LambdaHack.Common.Response: RespPingAI :: ResponseAI

- Game.LambdaHack.Common.Response: RespPingUI :: ResponseUI

- Game.LambdaHack.Common.Response: RespSfxAtomicUI :: !SfxAtomic -> ResponseUI

- Game.LambdaHack.Common.Response: RespUpdAtomicAI :: !UpdAtomic -> ResponseAI

- Game.LambdaHack.Common.Response: RespUpdAtomicUI :: !UpdAtomic -> ResponseUI

- Game.LambdaHack.Common.Response: data ResponseAI

- Game.LambdaHack.Common.Response: data ResponseUI

- Game.LambdaHack.Common.Response: instance Show ResponseAI

- Game.LambdaHack.Common.Response: instance Show ResponseUI

- Game.LambdaHack.Common.RingBuffer: instance Binary a => Binary (RingBuffer a)

- Game.LambdaHack.Common.RingBuffer: instance Constructor C1_0RingBuffer

- Game.LambdaHack.Common.RingBuffer: instance Datatype D1RingBuffer

- Game.LambdaHack.Common.RingBuffer: instance Generic (RingBuffer a)

- Game.LambdaHack.Common.RingBuffer: instance Selector S1_0_0RingBuffer

- Game.LambdaHack.Common.RingBuffer: instance Selector S1_0_1RingBuffer

- Game.LambdaHack.Common.RingBuffer: instance Selector S1_0_2RingBuffer

- Game.LambdaHack.Common.RingBuffer: instance Show a => Show (RingBuffer a)

- Game.LambdaHack.Common.Save: delayPrint :: Text -> IO ()

- Game.LambdaHack.Common.State: instance Binary State

- Game.LambdaHack.Common.State: instance Eq State

- Game.LambdaHack.Common.State: instance Show State

- Game.LambdaHack.Common.Tile: TileSpeedup :: !Tab -> !Tab -> !Tab -> !Tab -> !Tab -> !Tab -> !Tab -> !Tab -> TileSpeedup

- Game.LambdaHack.Common.Tile: ascendTo :: Ops TileKind -> Id TileKind -> [Int]

- Game.LambdaHack.Common.Tile: causeEffects :: Ops TileKind -> Id TileKind -> [Effect]

- Game.LambdaHack.Common.Tile: data Tab

- Game.LambdaHack.Common.Tile: data TileSpeedup

- Game.LambdaHack.Common.Tile: embedItems :: Ops TileKind -> Id TileKind -> [GroupName ItemKind]

- Game.LambdaHack.Common.Tile: isChangeable :: Ops TileKind -> Id TileKind -> Bool

- Game.LambdaHack.Common.Tile: isChangeableTab :: TileSpeedup -> !Tab

- Game.LambdaHack.Common.Tile: isClearTab :: TileSpeedup -> !Tab

- Game.LambdaHack.Common.Tile: isDoorTab :: TileSpeedup -> !Tab

- Game.LambdaHack.Common.Tile: isEscape :: Ops TileKind -> Id TileKind -> Bool

- Game.LambdaHack.Common.Tile: isLitTab :: TileSpeedup -> !Tab

- Game.LambdaHack.Common.Tile: isPassable :: Ops TileKind -> Id TileKind -> Bool

- Game.LambdaHack.Common.Tile: isPassableNoSuspect :: Ops TileKind -> Id TileKind -> Bool

- Game.LambdaHack.Common.Tile: isPassableNoSuspectTab :: TileSpeedup -> !Tab

- Game.LambdaHack.Common.Tile: isPassableTab :: TileSpeedup -> !Tab

- Game.LambdaHack.Common.Tile: isStair :: Ops TileKind -> Id TileKind -> Bool

- Game.LambdaHack.Common.Tile: isSuspectTab :: TileSpeedup -> !Tab

- Game.LambdaHack.Common.Tile: isWalkableTab :: TileSpeedup -> !Tab

- Game.LambdaHack.Common.Tile: lookSimilar :: TileKind -> TileKind -> Bool

- Game.LambdaHack.Common.Tile: type SmellTime = Time

- Game.LambdaHack.Common.Time: instance Binary Speed

- Game.LambdaHack.Common.Time: instance Binary Time

- Game.LambdaHack.Common.Time: instance Binary a => Binary (Delta a)

- Game.LambdaHack.Common.Time: instance Bounded Time

- Game.LambdaHack.Common.Time: instance Bounded a => Bounded (Delta a)

- Game.LambdaHack.Common.Time: instance Enum Time

- Game.LambdaHack.Common.Time: instance Enum a => Enum (Delta a)

- Game.LambdaHack.Common.Time: instance Eq Speed

- Game.LambdaHack.Common.Time: instance Eq Time

- Game.LambdaHack.Common.Time: instance Eq a => Eq (Delta a)

- Game.LambdaHack.Common.Time: instance Functor Delta

- Game.LambdaHack.Common.Time: instance Ord Speed

- Game.LambdaHack.Common.Time: instance Ord Time

- Game.LambdaHack.Common.Time: instance Ord a => Ord (Delta a)

- Game.LambdaHack.Common.Time: instance Show Speed

- Game.LambdaHack.Common.Time: instance Show Time

- Game.LambdaHack.Common.Time: instance Show a => Show (Delta a)

- Game.LambdaHack.Common.Time: rangeFromSpeed :: Speed -> Int

- Game.LambdaHack.Common.Time: speedNormal :: Speed

- Game.LambdaHack.Common.Vector: instance Binary Vector

- Game.LambdaHack.Common.Vector: instance Constructor C1_0Vector

- Game.LambdaHack.Common.Vector: instance Datatype D1Vector

- Game.LambdaHack.Common.Vector: instance Enum Vector

- Game.LambdaHack.Common.Vector: instance Eq Vector

- Game.LambdaHack.Common.Vector: instance Generic Vector

- Game.LambdaHack.Common.Vector: instance NFData Vector

- Game.LambdaHack.Common.Vector: instance Ord Vector

- Game.LambdaHack.Common.Vector: instance Read Vector

- Game.LambdaHack.Common.Vector: instance Selector S1_0_0Vector

- Game.LambdaHack.Common.Vector: instance Selector S1_0_1Vector

- Game.LambdaHack.Common.Vector: instance Show Vector

- Game.LambdaHack.Common.Vector: vx :: Vector -> !X

- Game.LambdaHack.Common.Vector: vy :: Vector -> !Y

- Game.LambdaHack.Content.CaveKind: cactorCoeff :: CaveKind -> !Int

- Game.LambdaHack.Content.CaveKind: cactorFreq :: CaveKind -> !(Freqs ItemKind)

- Game.LambdaHack.Content.CaveKind: cauxConnects :: CaveKind -> !Rational

- Game.LambdaHack.Content.CaveKind: cdarkChance :: CaveKind -> !Dice

- Game.LambdaHack.Content.CaveKind: cdarkCorTile :: CaveKind -> !(GroupName TileKind)

- Game.LambdaHack.Content.CaveKind: cdefTile :: CaveKind -> !(GroupName TileKind)

- Game.LambdaHack.Content.CaveKind: cdoorChance :: CaveKind -> !Chance

- Game.LambdaHack.Content.CaveKind: cfillerTile :: CaveKind -> !(GroupName TileKind)

- Game.LambdaHack.Content.CaveKind: cfreq :: CaveKind -> !(Freqs CaveKind)

- Game.LambdaHack.Content.CaveKind: cgrid :: CaveKind -> !DiceXY

- Game.LambdaHack.Content.CaveKind: chidden :: CaveKind -> !Int

- Game.LambdaHack.Content.CaveKind: citemFreq :: CaveKind -> !(Freqs ItemKind)

- Game.LambdaHack.Content.CaveKind: citemNum :: CaveKind -> !Dice

- Game.LambdaHack.Content.CaveKind: clegendDarkTile :: CaveKind -> !(GroupName TileKind)

- Game.LambdaHack.Content.CaveKind: clegendLitTile :: CaveKind -> !(GroupName TileKind)

- Game.LambdaHack.Content.CaveKind: clitCorTile :: CaveKind -> !(GroupName TileKind)

- Game.LambdaHack.Content.CaveKind: cmaxPlaceSize :: CaveKind -> !DiceXY

- Game.LambdaHack.Content.CaveKind: cmaxVoid :: CaveKind -> !Rational

- Game.LambdaHack.Content.CaveKind: cminPlaceSize :: CaveKind -> !DiceXY

- Game.LambdaHack.Content.CaveKind: cminStairDist :: CaveKind -> !Int

- Game.LambdaHack.Content.CaveKind: cname :: CaveKind -> !Text

- Game.LambdaHack.Content.CaveKind: cnightChance :: CaveKind -> !Dice

- Game.LambdaHack.Content.CaveKind: copenChance :: CaveKind -> !Chance

- Game.LambdaHack.Content.CaveKind: couterFenceTile :: CaveKind -> !(GroupName TileKind)

- Game.LambdaHack.Content.CaveKind: cpassable :: CaveKind -> !Bool

- Game.LambdaHack.Content.CaveKind: cplaceFreq :: CaveKind -> !(Freqs PlaceKind)

- Game.LambdaHack.Content.CaveKind: csymbol :: CaveKind -> !Char

- Game.LambdaHack.Content.CaveKind: cxsize :: CaveKind -> !X

- Game.LambdaHack.Content.CaveKind: cysize :: CaveKind -> !Y

- Game.LambdaHack.Content.CaveKind: instance Show CaveKind

- Game.LambdaHack.Content.ItemKind: AddHurtRanged :: !a -> Aspect a

- Game.LambdaHack.Content.ItemKind: AddLight :: !a -> Aspect a

- Game.LambdaHack.Content.ItemKind: AddSkills :: !Skills -> Aspect a

- Game.LambdaHack.Content.ItemKind: CallFriend :: !Dice -> Effect

- Game.LambdaHack.Content.ItemKind: EqpSlotAddHurtRanged :: EqpSlot

- Game.LambdaHack.Content.ItemKind: EqpSlotAddLight :: EqpSlot

- Game.LambdaHack.Content.ItemKind: EqpSlotAddSkills :: Ability -> EqpSlot

- Game.LambdaHack.Content.ItemKind: EqpSlotPeriodic :: EqpSlot

- Game.LambdaHack.Content.ItemKind: EqpSlotTimeout :: EqpSlot

- Game.LambdaHack.Content.ItemKind: Hurt :: !Dice -> Effect

- Game.LambdaHack.Content.ItemKind: NoEffect :: !Text -> Effect

- Game.LambdaHack.Content.ItemKind: OverfillCalm :: !Int -> Effect

- Game.LambdaHack.Content.ItemKind: OverfillHP :: !Int -> Effect

- Game.LambdaHack.Content.ItemKind: iaspects :: ItemKind -> ![Aspect Dice]

- Game.LambdaHack.Content.ItemKind: icount :: ItemKind -> !Dice

- Game.LambdaHack.Content.ItemKind: idesc :: ItemKind -> !Text

- Game.LambdaHack.Content.ItemKind: ieffects :: ItemKind -> ![Effect]

- Game.LambdaHack.Content.ItemKind: ifeature :: ItemKind -> ![Feature]

- Game.LambdaHack.Content.ItemKind: iflavour :: ItemKind -> ![Flavour]

- Game.LambdaHack.Content.ItemKind: ifreq :: ItemKind -> !(Freqs ItemKind)

- Game.LambdaHack.Content.ItemKind: ikit :: ItemKind -> ![(GroupName ItemKind, CStore)]

- Game.LambdaHack.Content.ItemKind: iname :: ItemKind -> !Text

- Game.LambdaHack.Content.ItemKind: instance Binary Effect

- Game.LambdaHack.Content.ItemKind: instance Binary EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Binary Feature

- Game.LambdaHack.Content.ItemKind: instance Binary ThrowMod

- Game.LambdaHack.Content.ItemKind: instance Binary TimerDice

- Game.LambdaHack.Content.ItemKind: instance Binary a => Binary (Aspect a)

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_0Aspect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_0Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_0EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_0Feature

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_0ThrowMod

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_0TimerDice

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_10Aspect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_10Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_10EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_11Aspect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_11Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_11EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_12Aspect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_12Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_12EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_13Aspect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_13Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_13EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_14Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_15Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_16Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_17Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_18Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_19Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_1Aspect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_1Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_1EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_1Feature

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_1TimerDice

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_20Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_21Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_22Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_23Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_24Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_25Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_26Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_27Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_28Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_29Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_2Aspect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_2Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_2EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_2Feature

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_2TimerDice

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_30Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_3Aspect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_3Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_3EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_3Feature

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_4Aspect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_4Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_4EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_4Feature

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_5Aspect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_5Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_5EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_5Feature

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_6Aspect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_6Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_6EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_6Feature

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_7Aspect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_7Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_7EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_7Feature

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_8Aspect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_8Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_8EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_9Aspect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_9Effect

- Game.LambdaHack.Content.ItemKind: instance Constructor C1_9EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Datatype D1Aspect

- Game.LambdaHack.Content.ItemKind: instance Datatype D1Effect

- Game.LambdaHack.Content.ItemKind: instance Datatype D1EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Datatype D1Feature

- Game.LambdaHack.Content.ItemKind: instance Datatype D1ThrowMod

- Game.LambdaHack.Content.ItemKind: instance Datatype D1TimerDice

- Game.LambdaHack.Content.ItemKind: instance Eq Effect

- Game.LambdaHack.Content.ItemKind: instance Eq EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Eq Feature

- Game.LambdaHack.Content.ItemKind: instance Eq ThrowMod

- Game.LambdaHack.Content.ItemKind: instance Eq TimerDice

- Game.LambdaHack.Content.ItemKind: instance Eq a => Eq (Aspect a)

- Game.LambdaHack.Content.ItemKind: instance Foldable Aspect

- Game.LambdaHack.Content.ItemKind: instance Functor Aspect

- Game.LambdaHack.Content.ItemKind: instance Generic (Aspect a)

- Game.LambdaHack.Content.ItemKind: instance Generic Effect

- Game.LambdaHack.Content.ItemKind: instance Generic EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Generic Feature

- Game.LambdaHack.Content.ItemKind: instance Generic ThrowMod

- Game.LambdaHack.Content.ItemKind: instance Generic TimerDice

- Game.LambdaHack.Content.ItemKind: instance Hashable Effect

- Game.LambdaHack.Content.ItemKind: instance Hashable EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Hashable Feature

- Game.LambdaHack.Content.ItemKind: instance Hashable ThrowMod

- Game.LambdaHack.Content.ItemKind: instance Hashable TimerDice

- Game.LambdaHack.Content.ItemKind: instance Hashable a => Hashable (Aspect a)

- Game.LambdaHack.Content.ItemKind: instance NFData Effect

- Game.LambdaHack.Content.ItemKind: instance NFData ThrowMod

- Game.LambdaHack.Content.ItemKind: instance NFData TimerDice

- Game.LambdaHack.Content.ItemKind: instance Ord Effect

- Game.LambdaHack.Content.ItemKind: instance Ord EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Ord Feature

- Game.LambdaHack.Content.ItemKind: instance Ord ThrowMod

- Game.LambdaHack.Content.ItemKind: instance Ord TimerDice

- Game.LambdaHack.Content.ItemKind: instance Ord a => Ord (Aspect a)

- Game.LambdaHack.Content.ItemKind: instance Read Effect

- Game.LambdaHack.Content.ItemKind: instance Read ThrowMod

- Game.LambdaHack.Content.ItemKind: instance Read TimerDice

- Game.LambdaHack.Content.ItemKind: instance Read a => Read (Aspect a)

- Game.LambdaHack.Content.ItemKind: instance Selector S1_0_0ThrowMod

- Game.LambdaHack.Content.ItemKind: instance Selector S1_0_1ThrowMod

- Game.LambdaHack.Content.ItemKind: instance Show Effect

- Game.LambdaHack.Content.ItemKind: instance Show EqpSlot

- Game.LambdaHack.Content.ItemKind: instance Show Feature

- Game.LambdaHack.Content.ItemKind: instance Show ItemKind

- Game.LambdaHack.Content.ItemKind: instance Show ThrowMod

- Game.LambdaHack.Content.ItemKind: instance Show TimerDice

- Game.LambdaHack.Content.ItemKind: instance Show a => Show (Aspect a)

- Game.LambdaHack.Content.ItemKind: instance Traversable Aspect

- Game.LambdaHack.Content.ItemKind: irarity :: ItemKind -> !Rarity

- Game.LambdaHack.Content.ItemKind: isymbol :: ItemKind -> !Char

- Game.LambdaHack.Content.ItemKind: iverbHit :: ItemKind -> !Part

- Game.LambdaHack.Content.ItemKind: iweight :: ItemKind -> !Int

- Game.LambdaHack.Content.ItemKind: slotName :: EqpSlot -> Text

- Game.LambdaHack.Content.ItemKind: throwLinger :: ThrowMod -> !Int

- Game.LambdaHack.Content.ItemKind: throwVelocity :: ThrowMod -> !Int

- Game.LambdaHack.Content.ModeKind: autoDungeon :: AutoLeader -> !Bool

- Game.LambdaHack.Content.ModeKind: autoLevel :: AutoLeader -> !Bool

- Game.LambdaHack.Content.ModeKind: fcanEscape :: Player a -> !Bool

- Game.LambdaHack.Content.ModeKind: fentryLevel :: Player a -> !a

- Game.LambdaHack.Content.ModeKind: fgroup :: Player a -> !(GroupName ItemKind)

- Game.LambdaHack.Content.ModeKind: fhasGender :: Player a -> !Bool

- Game.LambdaHack.Content.ModeKind: fhasNumbers :: Player a -> !Bool

- Game.LambdaHack.Content.ModeKind: fhasUI :: Player a -> !Bool

- Game.LambdaHack.Content.ModeKind: fhiCondPoly :: Player a -> !HiCondPoly

- Game.LambdaHack.Content.ModeKind: finitialActors :: Player a -> !a

- Game.LambdaHack.Content.ModeKind: fleaderMode :: Player a -> !LeaderMode

- Game.LambdaHack.Content.ModeKind: fname :: Player a -> !Text

- Game.LambdaHack.Content.ModeKind: fneverEmpty :: Player a -> !Bool

- Game.LambdaHack.Content.ModeKind: fskillsOther :: Player a -> !Skills

- Game.LambdaHack.Content.ModeKind: ftactic :: Player a -> !Tactic

- Game.LambdaHack.Content.ModeKind: instance Binary AutoLeader

- Game.LambdaHack.Content.ModeKind: instance Binary HiIndeterminant

- Game.LambdaHack.Content.ModeKind: instance Binary LeaderMode

- Game.LambdaHack.Content.ModeKind: instance Binary Outcome

- Game.LambdaHack.Content.ModeKind: instance Binary a => Binary (Player a)

- Game.LambdaHack.Content.ModeKind: instance Bounded Outcome

- Game.LambdaHack.Content.ModeKind: instance Constructor C1_0AutoLeader

- Game.LambdaHack.Content.ModeKind: instance Constructor C1_0HiIndeterminant

- Game.LambdaHack.Content.ModeKind: instance Constructor C1_0LeaderMode

- Game.LambdaHack.Content.ModeKind: instance Constructor C1_0Outcome

- Game.LambdaHack.Content.ModeKind: instance Constructor C1_0Player

- Game.LambdaHack.Content.ModeKind: instance Constructor C1_1HiIndeterminant

- Game.LambdaHack.Content.ModeKind: instance Constructor C1_1LeaderMode

- Game.LambdaHack.Content.ModeKind: instance Constructor C1_1Outcome

- Game.LambdaHack.Content.ModeKind: instance Constructor C1_2HiIndeterminant

- Game.LambdaHack.Content.ModeKind: instance Constructor C1_2LeaderMode

- Game.LambdaHack.Content.ModeKind: instance Constructor C1_2Outcome

- Game.LambdaHack.Content.ModeKind: instance Constructor C1_3HiIndeterminant

- Game.LambdaHack.Content.ModeKind: instance Constructor C1_3Outcome

- Game.LambdaHack.Content.ModeKind: instance Constructor C1_4HiIndeterminant

- Game.LambdaHack.Content.ModeKind: instance Constructor C1_4Outcome

- Game.LambdaHack.Content.ModeKind: instance Constructor C1_5HiIndeterminant

- Game.LambdaHack.Content.ModeKind: instance Constructor C1_5Outcome

- Game.LambdaHack.Content.ModeKind: instance Datatype D1AutoLeader

- Game.LambdaHack.Content.ModeKind: instance Datatype D1HiIndeterminant

- Game.LambdaHack.Content.ModeKind: instance Datatype D1LeaderMode

- Game.LambdaHack.Content.ModeKind: instance Datatype D1Outcome

- Game.LambdaHack.Content.ModeKind: instance Datatype D1Player

- Game.LambdaHack.Content.ModeKind: instance Enum Outcome

- Game.LambdaHack.Content.ModeKind: instance Eq AutoLeader

- Game.LambdaHack.Content.ModeKind: instance Eq HiIndeterminant

- Game.LambdaHack.Content.ModeKind: instance Eq LeaderMode

- Game.LambdaHack.Content.ModeKind: instance Eq Outcome

- Game.LambdaHack.Content.ModeKind: instance Eq Roster

- Game.LambdaHack.Content.ModeKind: instance Eq a => Eq (Player a)

- Game.LambdaHack.Content.ModeKind: instance Generic (Player a)

- Game.LambdaHack.Content.ModeKind: instance Generic AutoLeader

- Game.LambdaHack.Content.ModeKind: instance Generic HiIndeterminant

- Game.LambdaHack.Content.ModeKind: instance Generic LeaderMode

- Game.LambdaHack.Content.ModeKind: instance Generic Outcome

- Game.LambdaHack.Content.ModeKind: instance Ord AutoLeader

- Game.LambdaHack.Content.ModeKind: instance Ord HiIndeterminant

- Game.LambdaHack.Content.ModeKind: instance Ord LeaderMode

- Game.LambdaHack.Content.ModeKind: instance Ord Outcome

- Game.LambdaHack.Content.ModeKind: instance Ord a => Ord (Player a)

- Game.LambdaHack.Content.ModeKind: instance Selector S1_0_0AutoLeader

- Game.LambdaHack.Content.ModeKind: instance Selector S1_0_0Player

- Game.LambdaHack.Content.ModeKind: instance Selector S1_0_10Player

- Game.LambdaHack.Content.ModeKind: instance Selector S1_0_11Player

- Game.LambdaHack.Content.ModeKind: instance Selector S1_0_12Player

- Game.LambdaHack.Content.ModeKind: instance Selector S1_0_1AutoLeader

- Game.LambdaHack.Content.ModeKind: instance Selector S1_0_1Player

- Game.LambdaHack.Content.ModeKind: instance Selector S1_0_2Player

- Game.LambdaHack.Content.ModeKind: instance Selector S1_0_3Player

- Game.LambdaHack.Content.ModeKind: instance Selector S1_0_4Player

- Game.LambdaHack.Content.ModeKind: instance Selector S1_0_5Player

- Game.LambdaHack.Content.ModeKind: instance Selector S1_0_6Player

- Game.LambdaHack.Content.ModeKind: instance Selector S1_0_7Player

- Game.LambdaHack.Content.ModeKind: instance Selector S1_0_8Player

- Game.LambdaHack.Content.ModeKind: instance Selector S1_0_9Player

- Game.LambdaHack.Content.ModeKind: instance Show AutoLeader

- Game.LambdaHack.Content.ModeKind: instance Show HiIndeterminant

- Game.LambdaHack.Content.ModeKind: instance Show LeaderMode

- Game.LambdaHack.Content.ModeKind: instance Show ModeKind

- Game.LambdaHack.Content.ModeKind: instance Show Outcome

- Game.LambdaHack.Content.ModeKind: instance Show Roster

- Game.LambdaHack.Content.ModeKind: instance Show a => Show (Player a)

- Game.LambdaHack.Content.ModeKind: mcaves :: ModeKind -> !Caves

- Game.LambdaHack.Content.ModeKind: mdesc :: ModeKind -> !Text

- Game.LambdaHack.Content.ModeKind: mfreq :: ModeKind -> !(Freqs ModeKind)

- Game.LambdaHack.Content.ModeKind: mname :: ModeKind -> !Text

- Game.LambdaHack.Content.ModeKind: mroster :: ModeKind -> !Roster

- Game.LambdaHack.Content.ModeKind: msymbol :: ModeKind -> !Char

- Game.LambdaHack.Content.ModeKind: rosterAlly :: Roster -> ![(Text, Text)]

- Game.LambdaHack.Content.ModeKind: rosterEnemy :: Roster -> ![(Text, Text)]

- Game.LambdaHack.Content.ModeKind: rosterList :: Roster -> ![Player Dice]

- Game.LambdaHack.Content.PlaceKind: instance Eq Cover

- Game.LambdaHack.Content.PlaceKind: instance Eq Fence

- Game.LambdaHack.Content.PlaceKind: instance Show Cover

- Game.LambdaHack.Content.PlaceKind: instance Show Fence

- Game.LambdaHack.Content.PlaceKind: instance Show PlaceKind

- Game.LambdaHack.Content.PlaceKind: pcover :: PlaceKind -> !Cover

- Game.LambdaHack.Content.PlaceKind: pfence :: PlaceKind -> !Fence

- Game.LambdaHack.Content.PlaceKind: pfreq :: PlaceKind -> !(Freqs PlaceKind)

- Game.LambdaHack.Content.PlaceKind: pname :: PlaceKind -> !Text

- Game.LambdaHack.Content.PlaceKind: poverride :: PlaceKind -> ![(Char, GroupName TileKind)]

- Game.LambdaHack.Content.PlaceKind: prarity :: PlaceKind -> !Rarity

- Game.LambdaHack.Content.PlaceKind: psymbol :: PlaceKind -> !Char

- Game.LambdaHack.Content.PlaceKind: ptopLeft :: PlaceKind -> ![Text]

- Game.LambdaHack.Content.RuleKind: Digital :: FovMode

- Game.LambdaHack.Content.RuleKind: Permissive :: FovMode

- Game.LambdaHack.Content.RuleKind: Shadow :: FovMode

- Game.LambdaHack.Content.RuleKind: data FovMode

- Game.LambdaHack.Content.RuleKind: instance Binary FovMode

- Game.LambdaHack.Content.RuleKind: instance Read FovMode

- Game.LambdaHack.Content.RuleKind: instance Show FovMode

- Game.LambdaHack.Content.RuleKind: instance Show RuleKind

- Game.LambdaHack.Content.RuleKind: raccessible :: RuleKind -> !(Maybe (Point -> Point -> Bool))

- Game.LambdaHack.Content.RuleKind: raccessibleDoor :: RuleKind -> !(Maybe (Point -> Point -> Bool))

- Game.LambdaHack.Content.RuleKind: rcfgUIDefault :: RuleKind -> !String

- Game.LambdaHack.Content.RuleKind: rcfgUIName :: RuleKind -> !FilePath

- Game.LambdaHack.Content.RuleKind: rfirstDeathEnds :: RuleKind -> !Bool

- Game.LambdaHack.Content.RuleKind: rfovMode :: RuleKind -> !FovMode

- Game.LambdaHack.Content.RuleKind: rfreq :: RuleKind -> !(Freqs RuleKind)

- Game.LambdaHack.Content.RuleKind: rleadLevelClips :: RuleKind -> !Int

- Game.LambdaHack.Content.RuleKind: rmainMenuArt :: RuleKind -> !Text

- Game.LambdaHack.Content.RuleKind: rname :: RuleKind -> !Text

- Game.LambdaHack.Content.RuleKind: rnearby :: RuleKind -> !Int

- Game.LambdaHack.Content.RuleKind: rpathsDataFile :: RuleKind -> FilePath -> IO FilePath

- Game.LambdaHack.Content.RuleKind: rpathsVersion :: RuleKind -> !Version

- Game.LambdaHack.Content.RuleKind: rsavePrefix :: RuleKind -> !String

- Game.LambdaHack.Content.RuleKind: rscoresFile :: RuleKind -> !FilePath

- Game.LambdaHack.Content.RuleKind: rsymbol :: RuleKind -> !Char

- Game.LambdaHack.Content.RuleKind: rtitle :: RuleKind -> !Text

- Game.LambdaHack.Content.RuleKind: rwriteSaveClips :: RuleKind -> !Int

- Game.LambdaHack.Content.TileKind: Cause :: !Effect -> Feature

- Game.LambdaHack.Content.TileKind: Impenetrable :: Feature

- Game.LambdaHack.Content.TileKind: Suspect :: Feature

- Game.LambdaHack.Content.TileKind: instance Binary Feature

- Game.LambdaHack.Content.TileKind: instance Constructor C1_0Feature

- Game.LambdaHack.Content.TileKind: instance Constructor C1_10Feature

- Game.LambdaHack.Content.TileKind: instance Constructor C1_11Feature

- Game.LambdaHack.Content.TileKind: instance Constructor C1_12Feature

- Game.LambdaHack.Content.TileKind: instance Constructor C1_13Feature

- Game.LambdaHack.Content.TileKind: instance Constructor C1_14Feature

- Game.LambdaHack.Content.TileKind: instance Constructor C1_15Feature

- Game.LambdaHack.Content.TileKind: instance Constructor C1_16Feature

- Game.LambdaHack.Content.TileKind: instance Constructor C1_1Feature

- Game.LambdaHack.Content.TileKind: instance Constructor C1_2Feature

- Game.LambdaHack.Content.TileKind: instance Constructor C1_3Feature

- Game.LambdaHack.Content.TileKind: instance Constructor C1_4Feature

- Game.LambdaHack.Content.TileKind: instance Constructor C1_5Feature

- Game.LambdaHack.Content.TileKind: instance Constructor C1_6Feature

- Game.LambdaHack.Content.TileKind: instance Constructor C1_7Feature

- Game.LambdaHack.Content.TileKind: instance Constructor C1_8Feature

- Game.LambdaHack.Content.TileKind: instance Constructor C1_9Feature

- Game.LambdaHack.Content.TileKind: instance Datatype D1Feature

- Game.LambdaHack.Content.TileKind: instance Eq Feature

- Game.LambdaHack.Content.TileKind: instance Generic Feature

- Game.LambdaHack.Content.TileKind: instance Hashable Feature

- Game.LambdaHack.Content.TileKind: instance NFData Feature

- Game.LambdaHack.Content.TileKind: instance Ord Feature

- Game.LambdaHack.Content.TileKind: instance Read Feature

- Game.LambdaHack.Content.TileKind: instance Show Feature

- Game.LambdaHack.Content.TileKind: instance Show TileKind

- Game.LambdaHack.Content.TileKind: tcolor :: TileKind -> !Color

- Game.LambdaHack.Content.TileKind: tcolor2 :: TileKind -> !Color

- Game.LambdaHack.Content.TileKind: tfeature :: TileKind -> ![Feature]

- Game.LambdaHack.Content.TileKind: tfreq :: TileKind -> !(Freqs TileKind)

- Game.LambdaHack.Content.TileKind: tname :: TileKind -> !Text

- Game.LambdaHack.Content.TileKind: tsymbol :: TileKind -> !Char

- Game.LambdaHack.SampleImplementation.SampleMonadClient: data CliImplementation resp req a

- Game.LambdaHack.SampleImplementation.SampleMonadClient: instance Applicative (CliImplementation resp req)

- Game.LambdaHack.SampleImplementation.SampleMonadClient: instance Functor (CliImplementation resp req)

- Game.LambdaHack.SampleImplementation.SampleMonadClient: instance Monad (CliImplementation resp req)

- Game.LambdaHack.SampleImplementation.SampleMonadClient: instance MonadAtomic (CliImplementation resp req)

- Game.LambdaHack.SampleImplementation.SampleMonadClient: instance MonadClient (CliImplementation resp req)

- Game.LambdaHack.SampleImplementation.SampleMonadClient: instance MonadClientReadResponse resp (CliImplementation resp req)

- Game.LambdaHack.SampleImplementation.SampleMonadClient: instance MonadClientUI (CliImplementation resp req)

- Game.LambdaHack.SampleImplementation.SampleMonadClient: instance MonadClientWriteRequest req (CliImplementation resp req)

- Game.LambdaHack.SampleImplementation.SampleMonadClient: instance MonadStateRead (CliImplementation resp req)

- Game.LambdaHack.SampleImplementation.SampleMonadClient: instance MonadStateWrite (CliImplementation resp req)

- Game.LambdaHack.SampleImplementation.SampleMonadServer: data SerImplementation a

- Game.LambdaHack.SampleImplementation.SampleMonadServer: instance Applicative SerImplementation

- Game.LambdaHack.SampleImplementation.SampleMonadServer: instance Functor SerImplementation

- Game.LambdaHack.SampleImplementation.SampleMonadServer: instance Monad SerImplementation

- Game.LambdaHack.SampleImplementation.SampleMonadServer: instance MonadAtomic SerImplementation

- Game.LambdaHack.SampleImplementation.SampleMonadServer: instance MonadServer SerImplementation

- Game.LambdaHack.SampleImplementation.SampleMonadServer: instance MonadServerReadRequest SerImplementation

- Game.LambdaHack.SampleImplementation.SampleMonadServer: instance MonadStateRead SerImplementation

- Game.LambdaHack.SampleImplementation.SampleMonadServer: instance MonadStateWrite SerImplementation

- Game.LambdaHack.Server: sdebugCli :: DebugModeSer -> DebugModeCli

- Game.LambdaHack.Server: speedupCOps :: Bool -> COps -> COps

- Game.LambdaHack.Server.CommonServer: actorSkillsServer :: MonadServer m => ActorId -> m Skills

- Game.LambdaHack.Server.CommonServer: addActor :: (MonadAtomic m, MonadServer m) => GroupName ItemKind -> FactionId -> Point -> LevelId -> (Actor -> Actor) -> Text -> Time -> m (Maybe ActorId)

- Game.LambdaHack.Server.CommonServer: addActorIid :: (MonadAtomic m, MonadServer m) => ItemId -> ItemFull -> Bool -> FactionId -> Point -> LevelId -> (Actor -> Actor) -> Text -> Time -> m (Maybe ActorId)

- Game.LambdaHack.Server.CommonServer: deduceKilled :: (MonadAtomic m, MonadServer m) => ActorId -> Actor -> m ()

- Game.LambdaHack.Server.CommonServer: deduceQuits :: (MonadAtomic m, MonadServer m) => FactionId -> Maybe (ActorId, Actor) -> Status -> m ()

- Game.LambdaHack.Server.CommonServer: electLeader :: MonadAtomic m => FactionId -> LevelId -> ActorId -> m ()

- Game.LambdaHack.Server.CommonServer: execFailure :: (MonadAtomic m, MonadServer m) => ActorId -> RequestTimed a -> ReqFailure -> m ()

- Game.LambdaHack.Server.CommonServer: getPerFid :: MonadServer m => FactionId -> LevelId -> m Perception

- Game.LambdaHack.Server.CommonServer: moveStores :: (MonadAtomic m, MonadServer m) => ActorId -> CStore -> CStore -> m ()

- Game.LambdaHack.Server.CommonServer: pickWeaponServer :: MonadServer m => ActorId -> m (Maybe (ItemId, CStore))

- Game.LambdaHack.Server.CommonServer: projectFail :: (MonadAtomic m, MonadServer m) => ActorId -> Point -> Int -> ItemId -> CStore -> Bool -> m (Maybe ReqFailure)

- Game.LambdaHack.Server.CommonServer: resetFidPerception :: MonadServer m => PersLit -> FactionId -> LevelId -> m Perception

- Game.LambdaHack.Server.CommonServer: resetLitInDungeon :: MonadServer m => m PersLit

- Game.LambdaHack.Server.CommonServer: revealItems :: (MonadAtomic m, MonadServer m) => Maybe FactionId -> Maybe (ActorId, Actor) -> m ()

- Game.LambdaHack.Server.CommonServer: sumOrganEqpServer :: MonadServer m => EqpSlot -> ActorId -> m Int

- Game.LambdaHack.Server.DebugServer: debugRequestAI :: MonadServer m => ActorId -> RequestAI -> m ()

- Game.LambdaHack.Server.DebugServer: debugRequestUI :: MonadServer m => ActorId -> RequestUI -> m ()

- Game.LambdaHack.Server.DebugServer: debugResponseAI :: MonadServer m => ResponseAI -> m ()

- Game.LambdaHack.Server.DebugServer: debugResponseUI :: MonadServer m => ResponseUI -> m ()

- Game.LambdaHack.Server.DebugServer: instance Show a => Show (DebugAid a)

- Game.LambdaHack.Server.DungeonGen: findGenerator :: COps -> LevelId -> LevelId -> LevelId -> AbsDepth -> Int -> (GroupName CaveKind, Maybe Bool) -> Rnd Level

- Game.LambdaHack.Server.DungeonGen: freshDungeon :: FreshDungeon -> !Dungeon

- Game.LambdaHack.Server.DungeonGen: freshTotalDepth :: FreshDungeon -> !AbsDepth

- Game.LambdaHack.Server.DungeonGen: placeStairs :: COps -> TileMap -> CaveKind -> [Point] -> Rnd Point

- Game.LambdaHack.Server.DungeonGen.Area: instance Binary Area

- Game.LambdaHack.Server.DungeonGen.Area: instance Show Area

- Game.LambdaHack.Server.DungeonGen.Cave: dkind :: Cave -> !(Id CaveKind)

- Game.LambdaHack.Server.DungeonGen.Cave: dmap :: Cave -> !TileMapEM

- Game.LambdaHack.Server.DungeonGen.Cave: dnight :: Cave -> !Bool

- Game.LambdaHack.Server.DungeonGen.Cave: dplaces :: Cave -> ![Place]

- Game.LambdaHack.Server.DungeonGen.Cave: instance Show Cave

- Game.LambdaHack.Server.DungeonGen.Place: instance Binary Place

- Game.LambdaHack.Server.DungeonGen.Place: instance Show Place

- Game.LambdaHack.Server.DungeonGen.Place: qFFloor :: Place -> !(Id TileKind)

- Game.LambdaHack.Server.DungeonGen.Place: qFGround :: Place -> !(Id TileKind)

- Game.LambdaHack.Server.DungeonGen.Place: qFWall :: Place -> !(Id TileKind)

- Game.LambdaHack.Server.DungeonGen.Place: qarea :: Place -> !Area

- Game.LambdaHack.Server.DungeonGen.Place: qkind :: Place -> !(Id PlaceKind)

- Game.LambdaHack.Server.DungeonGen.Place: qlegend :: Place -> !(GroupName TileKind)

- Game.LambdaHack.Server.DungeonGen.Place: qseen :: Place -> !Bool

- Game.LambdaHack.Server.EndServer: dieSer :: (MonadAtomic m, MonadServer m) => ActorId -> Actor -> Bool -> m ()

- Game.LambdaHack.Server.EndServer: endOrLoop :: (MonadAtomic m, MonadServer m) => m () -> (Maybe (GroupName ModeKind) -> m ()) -> m () -> m () -> m ()

- Game.LambdaHack.Server.Fov: PerceptionDynamicLit :: [Point] -> PerceptionDynamicLit

- Game.LambdaHack.Server.Fov: PerceptionReachable :: [Point] -> PerceptionReachable

- Game.LambdaHack.Server.Fov: dungeonPerception :: FovMode -> State -> StateServer -> Pers

- Game.LambdaHack.Server.Fov: fidLidPerception :: FovMode -> PersLit -> FactionId -> LevelId -> Level -> Perception

- Game.LambdaHack.Server.Fov: instance Show PerceptionDynamicLit

- Game.LambdaHack.Server.Fov: instance Show PerceptionReachable

- Game.LambdaHack.Server.Fov: newtype PerceptionDynamicLit

- Game.LambdaHack.Server.Fov: newtype PerceptionReachable

- Game.LambdaHack.Server.Fov: pdynamicLit :: PerceptionDynamicLit -> [Point]

- Game.LambdaHack.Server.Fov: preachable :: PerceptionReachable -> [Point]

- Game.LambdaHack.Server.Fov: type PersLit = EnumMap LevelId (EnumMap FactionId [(Actor, FovCache3)], Array Bool, Array Bool)

- Game.LambdaHack.Server.Fov.Common: B :: !Int -> !Int -> Bump

- Game.LambdaHack.Server.Fov.Common: Line :: !Bump -> !Bump -> Line

- Game.LambdaHack.Server.Fov.Common: addHull :: (Bump -> Bump -> Bool) -> Bump -> ConvexHull -> ConvexHull

- Game.LambdaHack.Server.Fov.Common: bx :: Bump -> !Int

- Game.LambdaHack.Server.Fov.Common: by :: Bump -> !Int

- Game.LambdaHack.Server.Fov.Common: data Bump

- Game.LambdaHack.Server.Fov.Common: data Line

- Game.LambdaHack.Server.Fov.Common: instance Show Bump

- Game.LambdaHack.Server.Fov.Common: instance Show Line

- Game.LambdaHack.Server.Fov.Common: maximal :: (a -> a -> Bool) -> [a] -> a

- Game.LambdaHack.Server.Fov.Common: steeper :: Bump -> Bump -> Bump -> Bool

- Game.LambdaHack.Server.Fov.Common: type ConvexHull = [Bump]

- Game.LambdaHack.Server.Fov.Common: type Distance = Int

- Game.LambdaHack.Server.Fov.Common: type Edge = (Line, ConvexHull)

- Game.LambdaHack.Server.Fov.Common: type EdgeInterval = (Edge, Edge)

- Game.LambdaHack.Server.Fov.Common: type Progress = Int

- Game.LambdaHack.Server.Fov.Digital: _debugLine :: Line -> (Bool, String)

- Game.LambdaHack.Server.Fov.Digital: _debugSteeper :: Bump -> Bump -> Bump -> Bool

- Game.LambdaHack.Server.Fov.Digital: dline :: Bump -> Bump -> Line

- Game.LambdaHack.Server.Fov.Digital: dsteeper :: Bump -> Bump -> Bump -> Bool

- Game.LambdaHack.Server.Fov.Digital: intersect :: Line -> Distance -> (Int, Int)

- Game.LambdaHack.Server.Fov.Digital: scan :: Distance -> (Bump -> Bool) -> [Bump]

- Game.LambdaHack.Server.Fov.Permissive: debugLine :: Line -> (Bool, String)

- Game.LambdaHack.Server.Fov.Permissive: debugSteeper :: Bump -> Bump -> Bump -> Bool

- Game.LambdaHack.Server.Fov.Permissive: dline :: Bump -> Bump -> Line

- Game.LambdaHack.Server.Fov.Permissive: dsteeper :: Bump -> Bump -> Bump -> Bool

- Game.LambdaHack.Server.Fov.Permissive: intersect :: Line -> Distance -> (Int, Int)

- Game.LambdaHack.Server.Fov.Permissive: scan :: (Bump -> Bool) -> [Bump]

- Game.LambdaHack.Server.Fov.Shadow: scan :: (SBump -> Bool) -> Distance -> Interval -> [SBump]

- Game.LambdaHack.Server.Fov.Shadow: type Interval = (Rational, Rational)

- Game.LambdaHack.Server.Fov.Shadow: type SBump = (Progress, Distance)

- Game.LambdaHack.Server.HandleEffectServer: applyItem :: (MonadAtomic m, MonadServer m) => ActorId -> ItemId -> CStore -> m ()

- Game.LambdaHack.Server.HandleEffectServer: armorHurtBonus :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m Int

- Game.LambdaHack.Server.HandleEffectServer: dropCStoreItem :: (MonadAtomic m, MonadServer m) => CStore -> ActorId -> Actor -> Bool -> ItemId -> ItemQuant -> m ()

- Game.LambdaHack.Server.HandleEffectServer: effectAndDestroy :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> ItemId -> Container -> Bool -> [Effect] -> [Aspect Int] -> ItemQuant -> m ()

- Game.LambdaHack.Server.HandleEffectServer: itemEffectAndDestroy :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> ItemId -> Container -> m ()

- Game.LambdaHack.Server.HandleEffectServer: itemEffectCause :: (MonadAtomic m, MonadServer m) => ActorId -> Point -> Effect -> m Bool

- Game.LambdaHack.Server.HandleRequestServer: handleRequestAI :: (MonadAtomic m, MonadServer m) => FactionId -> ActorId -> RequestAI -> m (ActorId, m ())

- Game.LambdaHack.Server.HandleRequestServer: handleRequestUI :: (MonadAtomic m, MonadServer m) => FactionId -> RequestUI -> m (Maybe ActorId, m ())

- Game.LambdaHack.Server.HandleRequestServer: reqDisplace :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m ()

- Game.LambdaHack.Server.HandleRequestServer: reqMove :: (MonadAtomic m, MonadServer m) => ActorId -> Vector -> m ()

- Game.LambdaHack.Server.ItemRev: instance Binary FlavourMap

- Game.LambdaHack.Server.ItemRev: instance Show FlavourMap

- Game.LambdaHack.Server.ItemServer: activeItemsServer :: MonadServer m => ActorId -> m [ItemFull]

- Game.LambdaHack.Server.ItemServer: embedItemsInDungeon :: (MonadAtomic m, MonadServer m) => m ()

- Game.LambdaHack.Server.ItemServer: fullAssocsServer :: MonadServer m => ActorId -> [CStore] -> m [(ItemId, ItemFull)]

- Game.LambdaHack.Server.ItemServer: itemToFullServer :: MonadServer m => m (ItemId -> ItemQuant -> ItemFull)

- Game.LambdaHack.Server.ItemServer: mapActorCStore_ :: MonadServer m => CStore -> (ItemId -> ItemQuant -> m a) -> Actor -> m ()

- Game.LambdaHack.Server.ItemServer: placeItemsInDungeon :: (MonadAtomic m, MonadServer m) => m ()

- Game.LambdaHack.Server.ItemServer: registerItem :: (MonadAtomic m, MonadServer m) => ItemFull -> ItemKnown -> ItemSeed -> Int -> Container -> Bool -> m ItemId

- Game.LambdaHack.Server.ItemServer: rollAndRegisterItem :: (MonadAtomic m, MonadServer m) => LevelId -> Freqs ItemKind -> Container -> Bool -> Maybe Int -> m (Maybe (ItemId, (ItemFull, GroupName ItemKind)))

- Game.LambdaHack.Server.ItemServer: rollItem :: (MonadAtomic m, MonadServer m) => Int -> LevelId -> Freqs ItemKind -> m (Maybe (ItemKnown, ItemFull, ItemDisco, ItemSeed, GroupName ItemKind))

- Game.LambdaHack.Server.LoopServer: loopSer :: (MonadAtomic m, MonadServerReadRequest m) => COps -> DebugModeSer -> (FactionId -> ChanServer ResponseUI RequestUI -> IO ()) -> (FactionId -> ChanServer ResponseAI RequestAI -> IO ()) -> m ()

- Game.LambdaHack.Server.MonadServer: elapsedSessionTimeGT :: MonadServer m => Int -> m Bool

- Game.LambdaHack.Server.MonadServer: resetGameStart :: MonadServer m => m ()

- Game.LambdaHack.Server.MonadServer: resetSessionStart :: MonadServer m => m ()

- Game.LambdaHack.Server.MonadServer: saveName :: String

- Game.LambdaHack.Server.MonadServer: speedupCOps :: Bool -> COps -> COps

- Game.LambdaHack.Server.MonadServer: tellAllClipPS :: MonadServer m => m ()

- Game.LambdaHack.Server.MonadServer: tellGameClipPS :: MonadServer m => m ()

- Game.LambdaHack.Server.MonadServer: tryRestore :: MonadServer m => COps -> DebugModeSer -> m (Maybe (State, StateServer))

- Game.LambdaHack.Server.PeriodicServer: addAnyActor :: (MonadAtomic m, MonadServer m) => Freqs ItemKind -> LevelId -> Time -> Maybe Point -> m (Maybe ActorId)

- Game.LambdaHack.Server.PeriodicServer: advanceTime :: (MonadAtomic m, MonadServer m) => ActorId -> m ()

- Game.LambdaHack.Server.PeriodicServer: dominateFidSfx :: (MonadAtomic m, MonadServer m) => FactionId -> ActorId -> m Bool

- Game.LambdaHack.Server.PeriodicServer: leadLevelSwitch :: (MonadAtomic m, MonadServer m) => m ()

- Game.LambdaHack.Server.PeriodicServer: managePerTurn :: (MonadAtomic m, MonadServer m) => ActorId -> m ()

- Game.LambdaHack.Server.PeriodicServer: spawnMonster :: (MonadAtomic m, MonadServer m) => LevelId -> m ()

- Game.LambdaHack.Server.PeriodicServer: swapTime :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m ()

- Game.LambdaHack.Server.PeriodicServer: udpateCalm :: (MonadAtomic m, MonadServer m) => ActorId -> Int64 -> m ()

- Game.LambdaHack.Server.ProtocolServer: ChanServer :: !(TQueue resp) -> !(TQueue req) -> ChanServer resp req

- Game.LambdaHack.Server.ProtocolServer: childrenServer :: MVar [Async ()]

- Game.LambdaHack.Server.ProtocolServer: class MonadServer m => MonadServerReadRequest m

- Game.LambdaHack.Server.ProtocolServer: data ChanServer resp req

- Game.LambdaHack.Server.ProtocolServer: getDict :: MonadServerReadRequest m => m ConnServerDict

- Game.LambdaHack.Server.ProtocolServer: getsDict :: MonadServerReadRequest m => (ConnServerDict -> a) -> m a

- Game.LambdaHack.Server.ProtocolServer: killAllClients :: (MonadAtomic m, MonadServerReadRequest m) => m ()

- Game.LambdaHack.Server.ProtocolServer: liftIO :: MonadServerReadRequest m => IO a -> m a

- Game.LambdaHack.Server.ProtocolServer: modifyDict :: MonadServerReadRequest m => (ConnServerDict -> ConnServerDict) -> m ()

- Game.LambdaHack.Server.ProtocolServer: putDict :: MonadServerReadRequest m => ConnServerDict -> m ()

- Game.LambdaHack.Server.ProtocolServer: requestS :: ChanServer resp req -> !(TQueue req)

- Game.LambdaHack.Server.ProtocolServer: responseS :: ChanServer resp req -> !(TQueue resp)

- Game.LambdaHack.Server.ProtocolServer: sendPingAI :: (MonadAtomic m, MonadServerReadRequest m) => FactionId -> m ()

- Game.LambdaHack.Server.ProtocolServer: sendPingUI :: (MonadAtomic m, MonadServerReadRequest m) => FactionId -> m ()

- Game.LambdaHack.Server.ProtocolServer: sendQueryAI :: MonadServerReadRequest m => FactionId -> ActorId -> m RequestAI

- Game.LambdaHack.Server.ProtocolServer: sendQueryUI :: (MonadAtomic m, MonadServerReadRequest m) => FactionId -> ActorId -> m RequestUI

- Game.LambdaHack.Server.ProtocolServer: sendUpdateAI :: MonadServerReadRequest m => FactionId -> ResponseAI -> m ()

- Game.LambdaHack.Server.ProtocolServer: sendUpdateUI :: MonadServerReadRequest m => FactionId -> ResponseUI -> m ()

- Game.LambdaHack.Server.ProtocolServer: type ConnServerDict = EnumMap FactionId ConnServerFaction

- Game.LambdaHack.Server.ProtocolServer: type ConnServerFaction = (Maybe (ChanServer ResponseUI RequestUI), ChanServer ResponseAI RequestAI)

- Game.LambdaHack.Server.ProtocolServer: updateConn :: (MonadAtomic m, MonadServerReadRequest m) => (FactionId -> ChanServer ResponseUI RequestUI -> IO ()) -> (FactionId -> ChanServer ResponseAI RequestAI -> IO ()) -> m ()

- Game.LambdaHack.Server.StartServer: applyDebug :: MonadServer m => m ()

- Game.LambdaHack.Server.StartServer: gameReset :: MonadServer m => COps -> DebugModeSer -> Maybe (GroupName ModeKind) -> Maybe StdGen -> m State

- Game.LambdaHack.Server.StartServer: initDebug :: MonadStateRead m => COps -> DebugModeSer -> m DebugModeSer

- Game.LambdaHack.Server.StartServer: initPer :: MonadServer m => m ()

- Game.LambdaHack.Server.StartServer: recruitActors :: (MonadAtomic m, MonadServer m) => [Point] -> LevelId -> Time -> FactionId -> m Bool

- Game.LambdaHack.Server.StartServer: reinitGame :: (MonadAtomic m, MonadServer m) => m ()

- Game.LambdaHack.Server.State: FovCache3 :: !Int -> !Int -> !Int -> FovCache3

- Game.LambdaHack.Server.State: data FovCache3

- Game.LambdaHack.Server.State: dungeonRandomGenerator :: RNGs -> !(Maybe StdGen)

- Game.LambdaHack.Server.State: emptyFovCache3 :: FovCache3

- Game.LambdaHack.Server.State: fovLight :: FovCache3 -> !Int

- Game.LambdaHack.Server.State: fovSight :: FovCache3 -> !Int

- Game.LambdaHack.Server.State: fovSmell :: FovCache3 -> !Int

- Game.LambdaHack.Server.State: instance Binary DebugModeSer

- Game.LambdaHack.Server.State: instance Binary FovCache3

- Game.LambdaHack.Server.State: instance Binary RNGs

- Game.LambdaHack.Server.State: instance Binary StateServer

- Game.LambdaHack.Server.State: instance Eq FovCache3

- Game.LambdaHack.Server.State: instance Show DebugModeSer

- Game.LambdaHack.Server.State: instance Show FovCache3

- Game.LambdaHack.Server.State: instance Show RNGs

- Game.LambdaHack.Server.State: instance Show StateServer

- Game.LambdaHack.Server.State: sItemFovCache :: StateServer -> !(EnumMap ItemId FovCache3)

- Game.LambdaHack.Server.State: sacounter :: StateServer -> !ActorId

- Game.LambdaHack.Server.State: sallClear :: DebugModeSer -> !Bool

- Game.LambdaHack.Server.State: sallTime :: StateServer -> !Time

- Game.LambdaHack.Server.State: sautomateAll :: DebugModeSer -> !Bool

- Game.LambdaHack.Server.State: scurDiffSer :: DebugModeSer -> !Int

- Game.LambdaHack.Server.State: sdbgMsgSer :: DebugModeSer -> !Bool

- Game.LambdaHack.Server.State: sdebugCli :: DebugModeSer -> !DebugModeCli

- Game.LambdaHack.Server.State: sdebugNxt :: StateServer -> !DebugModeSer

- Game.LambdaHack.Server.State: sdebugSer :: StateServer -> !DebugModeSer

- Game.LambdaHack.Server.State: sdiscoEffect :: StateServer -> !DiscoveryEffect

- Game.LambdaHack.Server.State: sdiscoKind :: StateServer -> !DiscoveryKind

- Game.LambdaHack.Server.State: sdiscoKindRev :: StateServer -> !DiscoveryKindRev

- Game.LambdaHack.Server.State: sdumpInitRngs :: DebugModeSer -> !Bool

- Game.LambdaHack.Server.State: sdungeonRng :: DebugModeSer -> !(Maybe StdGen)

- Game.LambdaHack.Server.State: sflavour :: StateServer -> !FlavourMap

- Game.LambdaHack.Server.State: sfovMode :: DebugModeSer -> !(Maybe FovMode)

- Game.LambdaHack.Server.State: sgameMode :: DebugModeSer -> !(Maybe (GroupName ModeKind))

- Game.LambdaHack.Server.State: sgstart :: StateServer -> !ClockTime

- Game.LambdaHack.Server.State: sheroNames :: StateServer -> !(EnumMap FactionId [(Int, (Text, Text))])

- Game.LambdaHack.Server.State: sicounter :: StateServer -> !ItemId

- Game.LambdaHack.Server.State: sitemRev :: StateServer -> !ItemRev

- Game.LambdaHack.Server.State: sitemSeedD :: StateServer -> !ItemSeedDict

- Game.LambdaHack.Server.State: skeepAutomated :: DebugModeSer -> !Bool

- Game.LambdaHack.Server.State: sknowEvents :: DebugModeSer -> !Bool

- Game.LambdaHack.Server.State: sknowMap :: DebugModeSer -> !Bool

- Game.LambdaHack.Server.State: smainRng :: DebugModeSer -> !(Maybe StdGen)

- Game.LambdaHack.Server.State: snewGameSer :: DebugModeSer -> !Bool

- Game.LambdaHack.Server.State: sniffIn :: DebugModeSer -> !Bool

- Game.LambdaHack.Server.State: sniffOut :: DebugModeSer -> !Bool

- Game.LambdaHack.Server.State: snumSpawned :: StateServer -> !(EnumMap LevelId Int)

- Game.LambdaHack.Server.State: sper :: StateServer -> !Pers

- Game.LambdaHack.Server.State: sprocessed :: StateServer -> !(EnumMap LevelId Time)

- Game.LambdaHack.Server.State: squit :: StateServer -> !Bool

- Game.LambdaHack.Server.State: srandom :: StateServer -> !StdGen

- Game.LambdaHack.Server.State: srngs :: StateServer -> !RNGs

- Game.LambdaHack.Server.State: ssavePrefixSer :: DebugModeSer -> !(Maybe String)

- Game.LambdaHack.Server.State: sstart :: StateServer -> !ClockTime

- Game.LambdaHack.Server.State: sstopAfter :: DebugModeSer -> !(Maybe Int)

- Game.LambdaHack.Server.State: startingRandomGenerator :: RNGs -> !(Maybe StdGen)

- Game.LambdaHack.Server.State: sundo :: StateServer -> ![CmdAtomic]

- Game.LambdaHack.Server.State: suniqueSet :: StateServer -> !UniqueSet

- Game.LambdaHack.Server.State: swriteSave :: StateServer -> !Bool

+ Game.LambdaHack.Atomic: SfxBracedImmune :: !ActorId -> SfxMsg

+ Game.LambdaHack.Atomic: SfxColdFish :: SfxMsg

+ Game.LambdaHack.Atomic: SfxEscapeImpossible :: SfxMsg

+ Game.LambdaHack.Atomic: SfxFizzles :: SfxMsg

+ Game.LambdaHack.Atomic: SfxIdentifyNothing :: !CStore -> SfxMsg

+ Game.LambdaHack.Atomic: SfxLevelNoMore :: SfxMsg

+ Game.LambdaHack.Atomic: SfxLevelPushed :: SfxMsg

+ Game.LambdaHack.Atomic: SfxLoudStrike :: !Bool -> !(Id ItemKind) -> !Int -> SfxMsg

+ Game.LambdaHack.Atomic: SfxLoudUpd :: !Bool -> !UpdAtomic -> SfxMsg

+ Game.LambdaHack.Atomic: SfxPurposeNothing :: !CStore -> SfxMsg

+ Game.LambdaHack.Atomic: SfxPurposeTooFew :: !Int -> !Int -> SfxMsg

+ Game.LambdaHack.Atomic: SfxPurposeUnique :: SfxMsg

+ Game.LambdaHack.Atomic: SfxReceive :: !ActorId -> !ItemId -> !CStore -> SfxAtomic

+ Game.LambdaHack.Atomic: SfxRelease :: !ActorId -> !ActorId -> !ItemId -> !CStore -> SfxAtomic

+ Game.LambdaHack.Atomic: SfxSteal :: !ActorId -> !ActorId -> !ItemId -> !CStore -> SfxAtomic

+ Game.LambdaHack.Atomic: SfxSummonLackCalm :: !ActorId -> SfxMsg

+ Game.LambdaHack.Atomic: SfxTransImpossible :: SfxMsg

+ Game.LambdaHack.Atomic: SfxUnexpected :: !ReqFailure -> SfxMsg

+ Game.LambdaHack.Atomic: SfxVoidDetection :: SfxMsg

+ Game.LambdaHack.Atomic: UpdHideTile :: !ActorId -> !Point -> !(Id TileKind) -> UpdAtomic

+ Game.LambdaHack.Atomic: UpdUnAgeGame :: ![LevelId] -> UpdAtomic

+ Game.LambdaHack.Atomic: breakUpdAtomic :: MonadStateRead m => UpdAtomic -> m [UpdAtomic]

+ Game.LambdaHack.Atomic: class MonadStateRead m => MonadStateWrite m

+ Game.LambdaHack.Atomic: data SfxMsg

+ Game.LambdaHack.Atomic: execSendPer :: MonadAtomic m => FactionId -> LevelId -> Perception -> Perception -> Perception -> m ()

+ Game.LambdaHack.Atomic: handleUpdAtomic :: MonadStateWrite m => UpdAtomic -> m ()

+ Game.LambdaHack.Atomic: modifyState :: MonadStateWrite m => (State -> State) -> m ()

+ Game.LambdaHack.Atomic: seenAtomicSer :: PosAtomic -> Bool

+ Game.LambdaHack.Atomic.CmdAtomic: SfxBracedImmune :: !ActorId -> SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: SfxColdFish :: SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: SfxEscapeImpossible :: SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: SfxFizzles :: SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: SfxIdentifyNothing :: !CStore -> SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: SfxLevelNoMore :: SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: SfxLevelPushed :: SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: SfxLoudStrike :: !Bool -> !(Id ItemKind) -> !Int -> SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: SfxLoudUpd :: !Bool -> !UpdAtomic -> SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: SfxPurposeNothing :: !CStore -> SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: SfxPurposeTooFew :: !Int -> !Int -> SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: SfxPurposeUnique :: SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: SfxReceive :: !ActorId -> !ItemId -> !CStore -> SfxAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: SfxRelease :: !ActorId -> !ActorId -> !ItemId -> !CStore -> SfxAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: SfxSteal :: !ActorId -> !ActorId -> !ItemId -> !CStore -> SfxAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: SfxSummonLackCalm :: !ActorId -> SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: SfxTransImpossible :: SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: SfxUnexpected :: !ReqFailure -> SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: SfxVoidDetection :: SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: UpdHideTile :: !ActorId -> !Point -> !(Id TileKind) -> UpdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: UpdUnAgeGame :: ![LevelId] -> UpdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: data SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: instance Data.Binary.Class.Binary Game.LambdaHack.Atomic.CmdAtomic.CmdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: instance Data.Binary.Class.Binary Game.LambdaHack.Atomic.CmdAtomic.SfxAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: instance Data.Binary.Class.Binary Game.LambdaHack.Atomic.CmdAtomic.SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: instance Data.Binary.Class.Binary Game.LambdaHack.Atomic.CmdAtomic.UpdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: instance GHC.Classes.Eq Game.LambdaHack.Atomic.CmdAtomic.CmdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: instance GHC.Classes.Eq Game.LambdaHack.Atomic.CmdAtomic.SfxAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: instance GHC.Classes.Eq Game.LambdaHack.Atomic.CmdAtomic.SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: instance GHC.Classes.Eq Game.LambdaHack.Atomic.CmdAtomic.UpdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: instance GHC.Generics.Generic Game.LambdaHack.Atomic.CmdAtomic.CmdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: instance GHC.Generics.Generic Game.LambdaHack.Atomic.CmdAtomic.SfxAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: instance GHC.Generics.Generic Game.LambdaHack.Atomic.CmdAtomic.SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: instance GHC.Generics.Generic Game.LambdaHack.Atomic.CmdAtomic.UpdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: instance GHC.Show.Show Game.LambdaHack.Atomic.CmdAtomic.CmdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: instance GHC.Show.Show Game.LambdaHack.Atomic.CmdAtomic.SfxAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: instance GHC.Show.Show Game.LambdaHack.Atomic.CmdAtomic.SfxMsg

+ Game.LambdaHack.Atomic.CmdAtomic: instance GHC.Show.Show Game.LambdaHack.Atomic.CmdAtomic.UpdAtomic

+ Game.LambdaHack.Atomic.HandleAtomicWrite: handleUpdAtomic :: MonadStateWrite m => UpdAtomic -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updAgeGame :: MonadStateWrite m => [LevelId] -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updAlterClear :: MonadStateWrite m => LevelId -> Int -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updAlterSmell :: MonadStateWrite m => LevelId -> Point -> Time -> Time -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updAlterTile :: MonadStateWrite m => LevelId -> Point -> Id TileKind -> Id TileKind -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updAutoFaction :: MonadStateWrite m => FactionId -> Bool -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updCreateActor :: MonadStateWrite m => ActorId -> Actor -> [(ItemId, Item)] -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updCreateItem :: MonadStateWrite m => ItemId -> Item -> ItemQuant -> Container -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updDestroyActor :: MonadStateWrite m => ActorId -> Actor -> [(ItemId, Item)] -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updDestroyItem :: MonadStateWrite m => ItemId -> Item -> ItemQuant -> Container -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updDiplFaction :: MonadStateWrite m => FactionId -> FactionId -> Diplomacy -> Diplomacy -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updDisplaceActor :: MonadStateWrite m => ActorId -> ActorId -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updLeadFaction :: MonadStateWrite m => FactionId -> Maybe ActorId -> Maybe ActorId -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updLoseSmell :: MonadStateWrite m => LevelId -> [(Point, Time)] -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updLoseTile :: MonadStateWrite m => LevelId -> [(Point, Id TileKind)] -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updMoveActor :: MonadStateWrite m => ActorId -> Point -> Point -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updMoveItem :: MonadStateWrite m => ItemId -> Int -> ActorId -> CStore -> CStore -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updQuitFaction :: MonadStateWrite m => FactionId -> Maybe Status -> Maybe Status -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updRecordKill :: MonadStateWrite m => ActorId -> Id ItemKind -> Int -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updRefillCalm :: MonadStateWrite m => ActorId -> Int64 -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updRefillHP :: MonadStateWrite m => ActorId -> Int64 -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updRestart :: MonadStateWrite m => State -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updRestartServer :: MonadStateWrite m => State -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updResumeServer :: MonadStateWrite m => State -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updSpotSmell :: MonadStateWrite m => LevelId -> [(Point, Time)] -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updSpotTile :: MonadStateWrite m => LevelId -> [(Point, Id TileKind)] -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updTacticFaction :: MonadStateWrite m => FactionId -> Tactic -> Tactic -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updTimeItem :: MonadStateWrite m => ItemId -> Container -> ItemTimer -> ItemTimer -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updTrajectory :: MonadStateWrite m => ActorId -> Maybe ([Vector], Speed) -> Maybe ([Vector], Speed) -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updUnAgeGame :: MonadStateWrite m => [LevelId] -> m ()

+ Game.LambdaHack.Atomic.HandleAtomicWrite: updWaitActor :: MonadStateWrite m => ActorId -> Bool -> m ()

+ Game.LambdaHack.Atomic.MonadAtomic: execSendPer :: MonadAtomic m => FactionId -> LevelId -> Perception -> Perception -> Perception -> m ()

+ Game.LambdaHack.Atomic.MonadStateWrite: moveActorMap :: MonadStateWrite m => ActorId -> Actor -> Actor -> m ()

+ Game.LambdaHack.Atomic.MonadStateWrite: updateActorMap :: (ActorMap -> ActorMap) -> Level -> Level

+ Game.LambdaHack.Atomic.PosAtomicRead: instance GHC.Classes.Eq Game.LambdaHack.Atomic.PosAtomicRead.PosAtomic

+ Game.LambdaHack.Atomic.PosAtomicRead: instance GHC.Show.Show Game.LambdaHack.Atomic.PosAtomicRead.PosAtomic

+ Game.LambdaHack.Client: loopCli :: (MonadClientSetup m, MonadClientUI m, MonadAtomic m, MonadClientReadResponse m, MonadClientWriteRequest m) => KeyKind -> Config -> DebugModeCli -> m ()

+ Game.LambdaHack.Client.AI: condInMeleeM :: MonadClient m => Actor -> m Bool

+ Game.LambdaHack.Client.AI: pickAI :: MonadClient m => Maybe (ActorId, RequestAnyAbility) -> ActorId -> m (ActorId, RequestAnyAbility)

+ Game.LambdaHack.Client.AI: udpdateCondInMelee :: MonadClient m => ActorId -> m ()

+ Game.LambdaHack.Client.AI.ConditionM: benAvailableItems :: MonadClient m => ActorId -> [CStore] -> m [(Maybe Benefit, CStore, ItemId, ItemFull)]

+ Game.LambdaHack.Client.AI.ConditionM: benGroundItems :: MonadClient m => ActorId -> m [(Maybe Benefit, CStore, ItemId, ItemFull)]

+ Game.LambdaHack.Client.AI.ConditionM: condAdjTriggerableM :: MonadStateRead m => ActorId -> m Bool

+ Game.LambdaHack.Client.AI.ConditionM: condAimEnemyPresentM :: MonadClient m => ActorId -> m Bool

+ Game.LambdaHack.Client.AI.ConditionM: condAimEnemyRememberedM :: MonadClient m => ActorId -> m Bool

+ Game.LambdaHack.Client.AI.ConditionM: condAnyFoeAdjM :: MonadStateRead m => ActorId -> m Bool

+ Game.LambdaHack.Client.AI.ConditionM: condBlocksFriendsM :: MonadClient m => ActorId -> m Bool

+ Game.LambdaHack.Client.AI.ConditionM: condCanProjectM :: MonadClient m => Int -> ActorId -> m Bool

+ Game.LambdaHack.Client.AI.ConditionM: condDesirableFloorItemM :: MonadClient m => ActorId -> m Bool

+ Game.LambdaHack.Client.AI.ConditionM: condFloorWeaponM :: MonadClient m => ActorId -> m Bool

+ Game.LambdaHack.Client.AI.ConditionM: condNoEqpWeaponM :: MonadClient m => ActorId -> m Bool

+ Game.LambdaHack.Client.AI.ConditionM: condProjectListM :: MonadClient m => Int -> ActorId -> m [(Maybe Benefit, CStore, ItemId, ItemFull)]

+ Game.LambdaHack.Client.AI.ConditionM: condShineWouldBetrayM :: MonadClient m => ActorId -> m Bool

+ Game.LambdaHack.Client.AI.ConditionM: condSupport :: MonadClient m => Int -> ActorId -> m Bool

+ Game.LambdaHack.Client.AI.ConditionM: condTgtNonmovingM :: MonadClient m => ActorId -> m Bool

+ Game.LambdaHack.Client.AI.ConditionM: desirableItem :: Bool -> Maybe Int -> Item -> Bool

+ Game.LambdaHack.Client.AI.ConditionM: fleeList :: MonadClient m => ActorId -> m ([(Int, Point)], [(Int, Point)])

+ Game.LambdaHack.Client.AI.ConditionM: hinders :: Bool -> Bool -> Bool -> Bool -> Actor -> AspectRecord -> ItemFull -> Bool

+ Game.LambdaHack.Client.AI.ConditionM: meleeThreatDistList :: MonadClient m => ActorId -> m [(Int, (ActorId, Actor))]

+ Game.LambdaHack.Client.AI.HandleAbilityM: actionStrategy :: forall m. MonadClient m => ActorId -> Bool -> m (Strategy RequestAnyAbility)

+ Game.LambdaHack.Client.AI.HandleAbilityM: applyItem :: MonadClient m => ActorId -> ApplyItemGroup -> m (Strategy (RequestTimed AbApply))

+ Game.LambdaHack.Client.AI.HandleAbilityM: bestByEqpSlot :: DiscoveryBenefit -> [(ItemId, ItemFull)] -> [(ItemId, ItemFull)] -> [(ItemId, ItemFull)] -> [(EqpSlot, ([(Int, (ItemId, ItemFull))], [(Int, (ItemId, ItemFull))], [(Int, (ItemId, ItemFull))]))]

+ Game.LambdaHack.Client.AI.HandleAbilityM: chase :: MonadClient m => ActorId -> Bool -> Bool -> m (Strategy RequestAnyAbility)

+ Game.LambdaHack.Client.AI.HandleAbilityM: displaceBlocker :: MonadClient m => ActorId -> Bool -> m (Strategy RequestAnyAbility)

+ Game.LambdaHack.Client.AI.HandleAbilityM: displaceFoe :: MonadClient m => ActorId -> m (Strategy RequestAnyAbility)

+ Game.LambdaHack.Client.AI.HandleAbilityM: displaceTowards :: MonadClient m => ActorId -> Point -> Bool -> m (Strategy Vector)

+ Game.LambdaHack.Client.AI.HandleAbilityM: equipItems :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbMoveItem))

+ Game.LambdaHack.Client.AI.HandleAbilityM: flee :: MonadClient m => ActorId -> [(Int, Point)] -> m (Strategy RequestAnyAbility)

+ Game.LambdaHack.Client.AI.HandleAbilityM: groupByEqpSlot :: [(ItemId, ItemFull)] -> EnumMap EqpSlot [(ItemId, ItemFull)]

+ Game.LambdaHack.Client.AI.HandleAbilityM: harmful :: DiscoveryBenefit -> ItemId -> Bool

+ Game.LambdaHack.Client.AI.HandleAbilityM: instance GHC.Classes.Eq Game.LambdaHack.Client.AI.HandleAbilityM.ApplyItemGroup

+ Game.LambdaHack.Client.AI.HandleAbilityM: meleeAny :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbMelee))

+ Game.LambdaHack.Client.AI.HandleAbilityM: meleeBlocker :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbMelee))

+ Game.LambdaHack.Client.AI.HandleAbilityM: moveOrRunAid :: MonadClient m => ActorId -> Vector -> m (Maybe RequestAnyAbility)

+ Game.LambdaHack.Client.AI.HandleAbilityM: moveTowards :: MonadClient m => ActorId -> Point -> Point -> Bool -> m (Strategy Vector)

+ Game.LambdaHack.Client.AI.HandleAbilityM: pickup :: MonadClient m => ActorId -> Bool -> m (Strategy (RequestTimed AbMoveItem))

+ Game.LambdaHack.Client.AI.HandleAbilityM: projectItem :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbProject))

+ Game.LambdaHack.Client.AI.HandleAbilityM: toShare :: EqpSlot -> Bool

+ Game.LambdaHack.Client.AI.HandleAbilityM: trigger :: MonadClient m => ActorId -> FleeViaStairsOrEscape -> m (Strategy (RequestTimed AbAlter))

+ Game.LambdaHack.Client.AI.HandleAbilityM: unEquipItems :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbMoveItem))

+ Game.LambdaHack.Client.AI.HandleAbilityM: waitBlockNow :: MonadClient m => m (Strategy (RequestTimed AbWait))

+ Game.LambdaHack.Client.AI.HandleAbilityM: yieldUnneeded :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbMoveItem))

+ Game.LambdaHack.Client.AI.PickActorM: pickActorToMove :: MonadClient m => Maybe ActorId -> m ActorId

+ Game.LambdaHack.Client.AI.PickActorM: useTactics :: MonadClient m => ActorId -> m ()

+ Game.LambdaHack.Client.AI.PickTargetM: refreshTarget :: MonadClient m => (ActorId, Actor) -> m (Maybe TgtAndPath)

+ Game.LambdaHack.Client.AI.PickTargetM: targetStrategy :: forall m. MonadClient m => ActorId -> m (Strategy TgtAndPath)

+ Game.LambdaHack.Client.AI.Strategy: infix 3 .=>

+ Game.LambdaHack.Client.AI.Strategy: infixr 2 .|

+ Game.LambdaHack.Client.AI.Strategy: instance Data.Foldable.Foldable Game.LambdaHack.Client.AI.Strategy.Strategy

+ Game.LambdaHack.Client.AI.Strategy: instance Data.Traversable.Traversable Game.LambdaHack.Client.AI.Strategy.Strategy

+ Game.LambdaHack.Client.AI.Strategy: instance GHC.Base.Alternative Game.LambdaHack.Client.AI.Strategy.Strategy

+ Game.LambdaHack.Client.AI.Strategy: instance GHC.Base.Applicative Game.LambdaHack.Client.AI.Strategy.Strategy

+ Game.LambdaHack.Client.AI.Strategy: instance GHC.Base.Functor Game.LambdaHack.Client.AI.Strategy.Strategy

+ Game.LambdaHack.Client.AI.Strategy: instance GHC.Base.Monad Game.LambdaHack.Client.AI.Strategy.Strategy

+ Game.LambdaHack.Client.AI.Strategy: instance GHC.Base.MonadPlus Game.LambdaHack.Client.AI.Strategy.Strategy

+ Game.LambdaHack.Client.AI.Strategy: instance GHC.Show.Show a => GHC.Show.Show (Game.LambdaHack.Client.AI.Strategy.Strategy a)

+ Game.LambdaHack.Client.Bfs: AndPath :: ![Point] -> !Point -> !Int -> AndPath

+ Game.LambdaHack.Client.Bfs: MoveToClosed :: MoveLegal

+ Game.LambdaHack.Client.Bfs: NoPath :: AndPath

+ Game.LambdaHack.Client.Bfs: [pathGoal] :: AndPath -> !Point

+ Game.LambdaHack.Client.Bfs: [pathLen] :: AndPath -> !Int

+ Game.LambdaHack.Client.Bfs: [pathList] :: AndPath -> ![Point]

+ Game.LambdaHack.Client.Bfs: data AndPath

+ Game.LambdaHack.Client.Bfs: instance Data.Binary.Class.Binary Game.LambdaHack.Client.Bfs.AndPath

+ Game.LambdaHack.Client.Bfs: instance Data.Bits.Bits Game.LambdaHack.Client.Bfs.BfsDistance

+ Game.LambdaHack.Client.Bfs: instance GHC.Classes.Eq Game.LambdaHack.Client.Bfs.BfsDistance

+ Game.LambdaHack.Client.Bfs: instance GHC.Classes.Eq Game.LambdaHack.Client.Bfs.MoveLegal

+ Game.LambdaHack.Client.Bfs: instance GHC.Classes.Ord Game.LambdaHack.Client.Bfs.BfsDistance

+ Game.LambdaHack.Client.Bfs: instance GHC.Enum.Bounded Game.LambdaHack.Client.Bfs.BfsDistance

+ Game.LambdaHack.Client.Bfs: instance GHC.Enum.Enum Game.LambdaHack.Client.Bfs.BfsDistance

+ Game.LambdaHack.Client.Bfs: instance GHC.Generics.Generic Game.LambdaHack.Client.Bfs.AndPath

+ Game.LambdaHack.Client.Bfs: instance GHC.Show.Show Game.LambdaHack.Client.Bfs.AndPath

+ Game.LambdaHack.Client.Bfs: instance GHC.Show.Show Game.LambdaHack.Client.Bfs.BfsDistance

+ Game.LambdaHack.Client.BfsM: ViaAnything :: FleeViaStairsOrEscape

+ Game.LambdaHack.Client.BfsM: ViaEscape :: FleeViaStairsOrEscape

+ Game.LambdaHack.Client.BfsM: ViaNothing :: FleeViaStairsOrEscape

+ Game.LambdaHack.Client.BfsM: ViaStairs :: FleeViaStairsOrEscape

+ Game.LambdaHack.Client.BfsM: ViaStairsDown :: FleeViaStairsOrEscape

+ Game.LambdaHack.Client.BfsM: ViaStairsUp :: FleeViaStairsOrEscape

+ Game.LambdaHack.Client.BfsM: closestFoes :: MonadClient m => [(ActorId, Actor)] -> ActorId -> m [(Int, (ActorId, Actor))]

+ Game.LambdaHack.Client.BfsM: closestItems :: MonadClient m => ActorId -> m [(Int, (Point, ItemBag))]

+ Game.LambdaHack.Client.BfsM: closestSmell :: MonadClient m => ActorId -> m [(Int, (Point, Time))]

+ Game.LambdaHack.Client.BfsM: closestTriggers :: MonadClient m => FleeViaStairsOrEscape -> ActorId -> m [(Int, (Point, (Point, ItemBag)))]

+ Game.LambdaHack.Client.BfsM: closestUnknown :: MonadClient m => ActorId -> m (Maybe Point)

+ Game.LambdaHack.Client.BfsM: condBFS :: MonadClient m => ActorId -> m (Bool, Word8)

+ Game.LambdaHack.Client.BfsM: condEnoughGearM :: MonadClient m => ActorId -> m Bool

+ Game.LambdaHack.Client.BfsM: createBfs :: MonadClient m => Bool -> Word8 -> ActorId -> m (Array BfsDistance)

+ Game.LambdaHack.Client.BfsM: createPath :: MonadClient m => ActorId -> Target -> m TgtAndPath

+ Game.LambdaHack.Client.BfsM: data FleeViaStairsOrEscape

+ Game.LambdaHack.Client.BfsM: embedBenefit :: MonadClient m => FleeViaStairsOrEscape -> ActorId -> [(Point, ItemBag)] -> m [(Int, (Point, ItemBag))]

+ Game.LambdaHack.Client.BfsM: furthestKnown :: MonadClient m => ActorId -> m Point

+ Game.LambdaHack.Client.BfsM: getCacheBfs :: MonadClient m => ActorId -> m (Array BfsDistance)

+ Game.LambdaHack.Client.BfsM: getCacheBfsAndPath :: forall m. MonadClient m => ActorId -> Point -> m (Array BfsDistance, AndPath)

+ Game.LambdaHack.Client.BfsM: getCachePath :: MonadClient m => ActorId -> Point -> m AndPath

+ Game.LambdaHack.Client.BfsM: instance GHC.Classes.Eq Game.LambdaHack.Client.BfsM.FleeViaStairsOrEscape

+ Game.LambdaHack.Client.BfsM: instance GHC.Show.Show Game.LambdaHack.Client.BfsM.FleeViaStairsOrEscape

+ Game.LambdaHack.Client.BfsM: invalidateBfsAid :: MonadClient m => ActorId -> m ()

+ Game.LambdaHack.Client.BfsM: invalidateBfsAll :: MonadClient m => m ()

+ Game.LambdaHack.Client.BfsM: invalidateBfsLid :: MonadClient m => LevelId -> m ()

+ Game.LambdaHack.Client.BfsM: unexploredDepth :: MonadClient m => Bool -> LevelId -> m Bool

+ Game.LambdaHack.Client.BfsM: updatePathFromBfs :: MonadClient m => Bool -> BfsAndPath -> ActorId -> Point -> m (Array BfsDistance, AndPath)

+ Game.LambdaHack.Client.CommonM: aidTgtToPos :: MonadClient m => ActorId -> LevelId -> Target -> m (Maybe Point)

+ Game.LambdaHack.Client.CommonM: aspectRecordFromActorClient :: MonadClient m => Actor -> [(ItemId, Item)] -> m AspectRecord

+ Game.LambdaHack.Client.CommonM: aspectRecordFromItemClient :: MonadClient m => ItemId -> Item -> m AspectRecord

+ Game.LambdaHack.Client.CommonM: createSactorAspect :: MonadClient m => State -> m ActorAspect

+ Game.LambdaHack.Client.CommonM: createSalter :: State -> AlterLid

+ Game.LambdaHack.Client.CommonM: currentSkillsClient :: MonadClient m => ActorId -> m Skills

+ Game.LambdaHack.Client.CommonM: fullAssocsClient :: MonadClient m => ActorId -> [CStore] -> m [(ItemId, ItemFull)]

+ Game.LambdaHack.Client.CommonM: getPerFid :: MonadClient m => LevelId -> m Perception

+ Game.LambdaHack.Client.CommonM: itemToFullClient :: MonadClient m => m (ItemId -> ItemQuant -> ItemFull)

+ Game.LambdaHack.Client.CommonM: makeLine :: MonadClient m => Bool -> Actor -> Point -> Int -> m (Maybe Int)

+ Game.LambdaHack.Client.CommonM: maxActorSkillsClient :: MonadClient m => ActorId -> m Skills

+ Game.LambdaHack.Client.CommonM: pickWeaponClient :: MonadClient m => ActorId -> ActorId -> m (Maybe (RequestTimed AbMelee))

+ Game.LambdaHack.Client.CommonM: updateSalter :: MonadClient m => LevelId -> [(Point, Id TileKind)] -> m ()

+ Game.LambdaHack.Client.HandleAtomicM: cmdAtomicFilterCli :: MonadClient m => UpdAtomic -> m [UpdAtomic]

+ Game.LambdaHack.Client.HandleAtomicM: cmdAtomicSemCli :: MonadClientSetup m => UpdAtomic -> m ()

+ Game.LambdaHack.Client.HandleResponseM: class MonadClient m => MonadClientReadResponse m

+ Game.LambdaHack.Client.HandleResponseM: class MonadClient m => MonadClientWriteRequest m

+ Game.LambdaHack.Client.HandleResponseM: clientHasUI :: MonadClientWriteRequest m => m Bool

+ Game.LambdaHack.Client.HandleResponseM: handleResponse :: (MonadClientSetup m, MonadClientUI m, MonadAtomic m, MonadClientWriteRequest m) => Response -> m ()

+ Game.LambdaHack.Client.HandleResponseM: receiveResponse :: MonadClientReadResponse m => m Response

+ Game.LambdaHack.Client.HandleResponseM: sendRequestAI :: MonadClientWriteRequest m => RequestAI -> m ()

+ Game.LambdaHack.Client.HandleResponseM: sendRequestUI :: MonadClientWriteRequest m => RequestUI -> m ()

+ Game.LambdaHack.Client.LoopM: loopCli :: (MonadClientSetup m, MonadClientUI m, MonadAtomic m, MonadClientReadResponse m, MonadClientWriteRequest m) => KeyKind -> Config -> DebugModeCli -> m ()

+ Game.LambdaHack.Client.MonadClient: class MonadClient m => MonadClientSetup m

+ Game.LambdaHack.Client.MonadClient: debugPossiblyPrint :: MonadClient m => Text -> m ()

+ Game.LambdaHack.Client.MonadClient: restartClient :: MonadClientSetup m => m ()

+ Game.LambdaHack.Client.MonadClient: rndToActionForget :: MonadClient m => Rnd a -> m a

+ Game.LambdaHack.Client.Preferences: aspectToBenefit :: Aspect -> Int

+ Game.LambdaHack.Client.Preferences: effectToBenefit :: COps -> Faction -> Effect -> (Int, Int)

+ Game.LambdaHack.Client.Preferences: organBenefit :: Int -> GroupName ItemKind -> COps -> Faction -> (Int, Int)

+ Game.LambdaHack.Client.Preferences: recordToBenefit :: AspectRecord -> [Int]

+ Game.LambdaHack.Client.Preferences: totalUsefulness :: COps -> Faction -> [Effect] -> AspectRecord -> Item -> Benefit

+ Game.LambdaHack.Client.State: BfsAndPath :: !(Array BfsDistance) -> !(EnumMap Point AndPath) -> BfsAndPath

+ Game.LambdaHack.Client.State: BfsInvalid :: BfsAndPath

+ Game.LambdaHack.Client.State: TgtAndPath :: !Target -> !AndPath -> TgtAndPath

+ Game.LambdaHack.Client.State: [_sleader] :: StateClient -> !(Maybe ActorId)

+ Game.LambdaHack.Client.State: [_sside] :: StateClient -> !FactionId

+ Game.LambdaHack.Client.State: [bfsArr] :: BfsAndPath -> !(Array BfsDistance)

+ Game.LambdaHack.Client.State: [bfsPath] :: BfsAndPath -> !(EnumMap Point AndPath)

+ Game.LambdaHack.Client.State: [sactorAspect] :: StateClient -> !ActorAspect

+ Game.LambdaHack.Client.State: [salter] :: StateClient -> !AlterLid

+ Game.LambdaHack.Client.State: [sbfsD] :: StateClient -> !(EnumMap ActorId BfsAndPath)

+ Game.LambdaHack.Client.State: [scondInMelee] :: StateClient -> !(EnumMap LevelId (Maybe Bool))

+ Game.LambdaHack.Client.State: [scurChal] :: StateClient -> !Challenge

+ Game.LambdaHack.Client.State: [sdebugCli] :: StateClient -> !DebugModeCli

+ Game.LambdaHack.Client.State: [sdiscoAspect] :: StateClient -> !DiscoveryAspect

+ Game.LambdaHack.Client.State: [sdiscoBenefit] :: StateClient -> !DiscoveryBenefit

+ Game.LambdaHack.Client.State: [sdiscoKind] :: StateClient -> !DiscoveryKind

+ Game.LambdaHack.Client.State: [seps] :: StateClient -> !Int

+ Game.LambdaHack.Client.State: [sexplored] :: StateClient -> !(EnumSet LevelId)

+ Game.LambdaHack.Client.State: [sfper] :: StateClient -> !PerLid

+ Game.LambdaHack.Client.State: [smarkSuspect] :: StateClient -> !Int

+ Game.LambdaHack.Client.State: [snxtChal] :: StateClient -> !Challenge

+ Game.LambdaHack.Client.State: [snxtScenario] :: StateClient -> !Int

+ Game.LambdaHack.Client.State: [squit] :: StateClient -> !Bool

+ Game.LambdaHack.Client.State: [srandom] :: StateClient -> !StdGen

+ Game.LambdaHack.Client.State: [stargetD] :: StateClient -> !(EnumMap ActorId TgtAndPath)

+ Game.LambdaHack.Client.State: [sundo] :: StateClient -> ![CmdAtomic]

+ Game.LambdaHack.Client.State: [svictories] :: StateClient -> !(EnumMap (Id ModeKind) (Map Challenge Int))

+ Game.LambdaHack.Client.State: [tapPath] :: TgtAndPath -> !AndPath

+ Game.LambdaHack.Client.State: [tapTgt] :: TgtAndPath -> !Target

+ Game.LambdaHack.Client.State: cycleMarkSuspect :: StateClient -> StateClient

+ Game.LambdaHack.Client.State: data BfsAndPath

+ Game.LambdaHack.Client.State: data TgtAndPath

+ Game.LambdaHack.Client.State: emptyStateClient :: FactionId -> StateClient

+ Game.LambdaHack.Client.State: instance Data.Binary.Class.Binary Game.LambdaHack.Client.State.StateClient

+ Game.LambdaHack.Client.State: instance Data.Binary.Class.Binary Game.LambdaHack.Client.State.TgtAndPath

+ Game.LambdaHack.Client.State: instance GHC.Generics.Generic Game.LambdaHack.Client.State.TgtAndPath

+ Game.LambdaHack.Client.State: instance GHC.Show.Show Game.LambdaHack.Client.State.BfsAndPath

+ Game.LambdaHack.Client.State: instance GHC.Show.Show Game.LambdaHack.Client.State.StateClient

+ Game.LambdaHack.Client.State: instance GHC.Show.Show Game.LambdaHack.Client.State.TgtAndPath

+ Game.LambdaHack.Client.State: type AlterLid = EnumMap LevelId (Array Word8)

+ Game.LambdaHack.Client.UI: SessionUI :: !Target -> !ActorDictUI -> !ItemSlots -> !SlotChar -> !ChanFrontend -> !Binding -> !Config -> !(Maybe AimMode) -> !Bool -> !(Maybe (CStore, ItemId)) -> !(EnumSet ActorId) -> !(Maybe RunParams) -> !Report -> !History -> !Point -> !LastRecord -> ![KM] -> !(EnumSet ActorId) -> !Int -> !Bool -> !Bool -> !(Map String Int) -> !Bool -> !KeysHintMode -> !POSIXTime -> !POSIXTime -> !Time -> !Int -> !Int -> SessionUI

+ Game.LambdaHack.Client.UI: [_sreport] :: SessionUI -> !Report

+ Game.LambdaHack.Client.UI: [sactorUI] :: SessionUI -> !ActorDictUI

+ Game.LambdaHack.Client.UI: [saimMode] :: SessionUI -> !(Maybe AimMode)

+ Game.LambdaHack.Client.UI: [sallNframes] :: SessionUI -> !Int

+ Game.LambdaHack.Client.UI: [sallTime] :: SessionUI -> !Time

+ Game.LambdaHack.Client.UI: [sbinding] :: SessionUI -> !Binding

+ Game.LambdaHack.Client.UI: [schanF] :: SessionUI -> !ChanFrontend

+ Game.LambdaHack.Client.UI: [sconfig] :: SessionUI -> !Config

+ Game.LambdaHack.Client.UI: [sdisplayNeeded] :: SessionUI -> !Bool

+ Game.LambdaHack.Client.UI: [sgstart] :: SessionUI -> !POSIXTime

+ Game.LambdaHack.Client.UI: [shistory] :: SessionUI -> !History

+ Game.LambdaHack.Client.UI: [sitemSel] :: SessionUI -> !(Maybe (CStore, ItemId))

+ Game.LambdaHack.Client.UI: [skeysHintMode] :: SessionUI -> !KeysHintMode

+ Game.LambdaHack.Client.UI: [slastLost] :: SessionUI -> !(EnumSet ActorId)

+ Game.LambdaHack.Client.UI: [slastPlay] :: SessionUI -> ![KM]

+ Game.LambdaHack.Client.UI: [slastRecord] :: SessionUI -> !LastRecord

+ Game.LambdaHack.Client.UI: [slastSlot] :: SessionUI -> !SlotChar

+ Game.LambdaHack.Client.UI: [smarkSmell] :: SessionUI -> !Bool

+ Game.LambdaHack.Client.UI: [smarkVision] :: SessionUI -> !Bool

+ Game.LambdaHack.Client.UI: [smenuIxMap] :: SessionUI -> !(Map String Int)

+ Game.LambdaHack.Client.UI: [snframes] :: SessionUI -> !Int

+ Game.LambdaHack.Client.UI: [spointer] :: SessionUI -> !Point

+ Game.LambdaHack.Client.UI: [srunning] :: SessionUI -> !(Maybe RunParams)

+ Game.LambdaHack.Client.UI: [sselected] :: SessionUI -> !(EnumSet ActorId)

+ Game.LambdaHack.Client.UI: [sslots] :: SessionUI -> !ItemSlots

+ Game.LambdaHack.Client.UI: [sstart] :: SessionUI -> !POSIXTime

+ Game.LambdaHack.Client.UI: [swaitTimes] :: SessionUI -> !Int

+ Game.LambdaHack.Client.UI: [sxhairMoused] :: SessionUI -> !Bool

+ Game.LambdaHack.Client.UI: [sxhair] :: SessionUI -> !Target

+ Game.LambdaHack.Client.UI: addPressedEsc :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI: chanFrontend :: MonadClientUI m => DebugModeCli -> m ChanFrontend

+ Game.LambdaHack.Client.UI: data ChanFrontend

+ Game.LambdaHack.Client.UI: data Config

+ Game.LambdaHack.Client.UI: emptySessionUI :: Config -> SessionUI

+ Game.LambdaHack.Client.UI: frontendShutdown :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI: getConfirms :: MonadClientUI m => ColorMode -> [KM] -> Slideshow -> m KM

+ Game.LambdaHack.Client.UI: getsSession :: MonadClientUI m => (SessionUI -> a) -> m a

+ Game.LambdaHack.Client.UI: liftIO :: MonadClientUI m => IO a -> m a

+ Game.LambdaHack.Client.UI: modifySession :: MonadClientUI m => (SessionUI -> SessionUI) -> m ()

+ Game.LambdaHack.Client.UI: promptAdd :: MonadClientUI m => Text -> m ()

+ Game.LambdaHack.Client.UI: putSession :: MonadClientUI m => SessionUI -> m ()

+ Game.LambdaHack.Client.UI: reportToSlideshow :: MonadClientUI m => [KM] -> m Slideshow

+ Game.LambdaHack.Client.UI: stdBinding :: KeyKind -> Config -> Binding

+ Game.LambdaHack.Client.UI: tryRestore :: MonadClientUI m => m (Maybe (State, StateClient, Maybe SessionUI))

+ Game.LambdaHack.Client.UI.ActorUI: ActorUI :: !Char -> !Text -> !Text -> !Color -> ActorUI

+ Game.LambdaHack.Client.UI.ActorUI: [bcolor] :: ActorUI -> !Color

+ Game.LambdaHack.Client.UI.ActorUI: [bname] :: ActorUI -> !Text

+ Game.LambdaHack.Client.UI.ActorUI: [bpronoun] :: ActorUI -> !Text

+ Game.LambdaHack.Client.UI.ActorUI: [bsymbol] :: ActorUI -> !Char

+ Game.LambdaHack.Client.UI.ActorUI: data ActorUI

+ Game.LambdaHack.Client.UI.ActorUI: instance Data.Binary.Class.Binary Game.LambdaHack.Client.UI.ActorUI.ActorUI

+ Game.LambdaHack.Client.UI.ActorUI: instance GHC.Classes.Eq Game.LambdaHack.Client.UI.ActorUI.ActorUI

+ Game.LambdaHack.Client.UI.ActorUI: instance GHC.Generics.Generic Game.LambdaHack.Client.UI.ActorUI.ActorUI

+ Game.LambdaHack.Client.UI.ActorUI: instance GHC.Show.Show Game.LambdaHack.Client.UI.ActorUI.ActorUI

+ Game.LambdaHack.Client.UI.ActorUI: keySelected :: (ActorId, Actor, ActorUI) -> (Bool, Bool, Char, Color, ActorId)

+ Game.LambdaHack.Client.UI.ActorUI: partActor :: ActorUI -> Part

+ Game.LambdaHack.Client.UI.ActorUI: partPronoun :: ActorUI -> Part

+ Game.LambdaHack.Client.UI.ActorUI: ppCStore :: CStore -> (Text, Text)

+ Game.LambdaHack.Client.UI.ActorUI: ppCStoreIn :: CStore -> Text

+ Game.LambdaHack.Client.UI.ActorUI: ppCStoreWownW :: Bool -> CStore -> Part -> [Part]

+ Game.LambdaHack.Client.UI.ActorUI: ppContainer :: Container -> Text

+ Game.LambdaHack.Client.UI.ActorUI: ppContainerWownW :: (ActorId -> Part) -> Bool -> Container -> [Part]

+ Game.LambdaHack.Client.UI.ActorUI: tryFindHeroK :: ActorDictUI -> FactionId -> Int -> State -> Maybe (ActorId, Actor)

+ Game.LambdaHack.Client.UI.ActorUI: type ActorDictUI = EnumMap ActorId ActorUI

+ Game.LambdaHack.Client.UI.ActorUI: verbCStore :: CStore -> Text

+ Game.LambdaHack.Client.UI.Animation: blinkColorActor :: Point -> Char -> Color -> Color -> Animation

+ Game.LambdaHack.Client.UI.Animation: instance GHC.Classes.Eq Game.LambdaHack.Client.UI.Animation.Animation

+ Game.LambdaHack.Client.UI.Animation: instance GHC.Show.Show Game.LambdaHack.Client.UI.Animation.Animation

+ Game.LambdaHack.Client.UI.Animation: pushAndDelay :: Animation

+ Game.LambdaHack.Client.UI.Animation: shortDeathBody :: Point -> Animation

+ Game.LambdaHack.Client.UI.Animation: teleport :: (Point, Point) -> Animation

+ Game.LambdaHack.Client.UI.Config: [configCmdline] :: Config -> ![String]

+ Game.LambdaHack.Client.UI.Config: [configColorIsBold] :: Config -> !Bool

+ Game.LambdaHack.Client.UI.Config: [configCommands] :: Config -> ![(KM, CmdTriple)]

+ Game.LambdaHack.Client.UI.Config: [configFontSize] :: Config -> !Int

+ Game.LambdaHack.Client.UI.Config: [configGtkFontFamily] :: Config -> !Text

+ Game.LambdaHack.Client.UI.Config: [configHeroNames] :: Config -> ![(Int, (Text, Text))]

+ Game.LambdaHack.Client.UI.Config: [configHistoryMax] :: Config -> !Int

+ Game.LambdaHack.Client.UI.Config: [configLaptop] :: Config -> !Bool

+ Game.LambdaHack.Client.UI.Config: [configMaxFps] :: Config -> !Int

+ Game.LambdaHack.Client.UI.Config: [configNoAnim] :: Config -> !Bool

+ Game.LambdaHack.Client.UI.Config: [configRunStopMsgs] :: Config -> !Bool

+ Game.LambdaHack.Client.UI.Config: [configSdlFonSizeAdd] :: Config -> !Int

+ Game.LambdaHack.Client.UI.Config: [configSdlFontFile] :: Config -> !Text

+ Game.LambdaHack.Client.UI.Config: [configSdlTtfSizeAdd] :: Config -> !Int

+ Game.LambdaHack.Client.UI.Config: [configVi] :: Config -> !Bool

+ Game.LambdaHack.Client.UI.Config: instance Control.DeepSeq.NFData Game.LambdaHack.Client.UI.Config.Config

+ Game.LambdaHack.Client.UI.Config: instance Data.Binary.Class.Binary Game.LambdaHack.Client.UI.Config.Config

+ Game.LambdaHack.Client.UI.Config: instance GHC.Generics.Generic Game.LambdaHack.Client.UI.Config.Config

+ Game.LambdaHack.Client.UI.Config: instance GHC.Show.Show Game.LambdaHack.Client.UI.Config.Config

+ Game.LambdaHack.Client.UI.Content.KeyKind: [rhumanCommands] :: KeyKind -> [(KM, CmdTriple)]

+ Game.LambdaHack.Client.UI.Content.KeyKind: addCmdCategory :: CmdCategory -> CmdTriple -> CmdTriple

+ Game.LambdaHack.Client.UI.Content.KeyKind: aimFlingCmd :: HumanCmd

+ Game.LambdaHack.Client.UI.Content.KeyKind: applyI :: [Trigger] -> CmdTriple

+ Game.LambdaHack.Client.UI.Content.KeyKind: applyIK :: [Trigger] -> CmdTriple

+ Game.LambdaHack.Client.UI.Content.KeyKind: autoexplore25Cmd :: HumanCmd

+ Game.LambdaHack.Client.UI.Content.KeyKind: autoexploreCmd :: HumanCmd

+ Game.LambdaHack.Client.UI.Content.KeyKind: defaultHeroSelect :: Int -> (String, CmdTriple)

+ Game.LambdaHack.Client.UI.Content.KeyKind: descTs :: [Trigger] -> Text

+ Game.LambdaHack.Client.UI.Content.KeyKind: dropItems :: Text -> CmdTriple

+ Game.LambdaHack.Client.UI.Content.KeyKind: evalKeyDef :: (String, CmdTriple) -> (KM, CmdTriple)

+ Game.LambdaHack.Client.UI.Content.KeyKind: flingTs :: [Trigger]

+ Game.LambdaHack.Client.UI.Content.KeyKind: goToCmd :: HumanCmd

+ Game.LambdaHack.Client.UI.Content.KeyKind: grabItems :: Text -> CmdTriple

+ Game.LambdaHack.Client.UI.Content.KeyKind: mouseLMB :: CmdTriple

+ Game.LambdaHack.Client.UI.Content.KeyKind: mouseMMB :: CmdTriple

+ Game.LambdaHack.Client.UI.Content.KeyKind: mouseRMB :: CmdTriple

+ Game.LambdaHack.Client.UI.Content.KeyKind: moveItemTriple :: [CStore] -> CStore -> Part -> Bool -> CmdTriple

+ Game.LambdaHack.Client.UI.Content.KeyKind: newtype KeyKind

+ Game.LambdaHack.Client.UI.Content.KeyKind: projectA :: [Trigger] -> CmdTriple

+ Game.LambdaHack.Client.UI.Content.KeyKind: projectI :: [Trigger] -> CmdTriple

+ Game.LambdaHack.Client.UI.Content.KeyKind: repeatTriple :: Int -> CmdTriple

+ Game.LambdaHack.Client.UI.Content.KeyKind: replaceDesc :: Text -> CmdTriple -> CmdTriple

+ Game.LambdaHack.Client.UI.Content.KeyKind: runToAllCmd :: HumanCmd

+ Game.LambdaHack.Client.UI.DisplayAtomicM: displayRespSfxAtomicUI :: MonadClientUI m => Bool -> SfxAtomic -> m ()

+ Game.LambdaHack.Client.UI.DisplayAtomicM: displayRespUpdAtomicUI :: MonadClientUI m => Bool -> StateClient -> UpdAtomic -> m ()

+ Game.LambdaHack.Client.UI.DrawM: drawArenaStatus :: Bool -> Level -> Int -> AttrLine

+ Game.LambdaHack.Client.UI.DrawM: drawBaseFrame :: MonadClientUI m => ColorMode -> LevelId -> m FrameForall

+ Game.LambdaHack.Client.UI.DrawM: drawFrameActor :: forall m. MonadClientUI m => LevelId -> m FrameForall

+ Game.LambdaHack.Client.UI.DrawM: drawFrameContent :: forall m. MonadClientUI m => LevelId -> m FrameForall

+ Game.LambdaHack.Client.UI.DrawM: drawFrameExtra :: forall m. MonadClientUI m => ColorMode -> LevelId -> m FrameForall

+ Game.LambdaHack.Client.UI.DrawM: drawFramePath :: forall m. MonadClientUI m => LevelId -> m FrameForall

+ Game.LambdaHack.Client.UI.DrawM: drawFrameStatus :: MonadClientUI m => LevelId -> m AttrLine

+ Game.LambdaHack.Client.UI.DrawM: drawFrameTerrain :: forall m. MonadClientUI m => LevelId -> m FrameForall

+ Game.LambdaHack.Client.UI.DrawM: drawLeaderDamage :: MonadClientUI m => Int -> m AttrLine

+ Game.LambdaHack.Client.UI.DrawM: drawLeaderStatus :: MonadClient m => Int -> m AttrLine

+ Game.LambdaHack.Client.UI.DrawM: drawSelected :: MonadClientUI m => LevelId -> Int -> EnumSet ActorId -> m (Int, AttrLine)

+ Game.LambdaHack.Client.UI.DrawM: targetDesc :: MonadClientUI m => Maybe Target -> m (Maybe Text, Maybe Text)

+ Game.LambdaHack.Client.UI.DrawM: targetDescLeader :: MonadClientUI m => ActorId -> m (Maybe Text, Maybe Text)

+ Game.LambdaHack.Client.UI.DrawM: targetDescXhair :: MonadClientUI m => m (Text, Maybe Text)

+ Game.LambdaHack.Client.UI.EffectDescription: affixDice :: Dice -> Text

+ Game.LambdaHack.Client.UI.EffectDescription: effectToSuffix :: Effect -> Text

+ Game.LambdaHack.Client.UI.EffectDescription: featureToSentence :: Feature -> Maybe Text

+ Game.LambdaHack.Client.UI.EffectDescription: featureToSuff :: Feature -> Text

+ Game.LambdaHack.Client.UI.EffectDescription: kindAspectToSuffix :: Aspect -> Text

+ Game.LambdaHack.Client.UI.EffectDescription: slotToDecorator :: EqpSlot -> Actor -> Int -> Text

+ Game.LambdaHack.Client.UI.EffectDescription: slotToDesc :: EqpSlot -> Text

+ Game.LambdaHack.Client.UI.EffectDescription: slotToName :: EqpSlot -> Text

+ Game.LambdaHack.Client.UI.EffectDescription: slotToSentence :: EqpSlot -> Text

+ Game.LambdaHack.Client.UI.EffectDescription: statSlots :: [EqpSlot]

+ Game.LambdaHack.Client.UI.Frame: SingleFrame :: GArray Word32 AttrCharW32 -> SingleFrame

+ Game.LambdaHack.Client.UI.Frame: [singleFrame] :: SingleFrame -> GArray Word32 AttrCharW32

+ Game.LambdaHack.Client.UI.Frame: blankSingleFrame :: SingleFrame

+ Game.LambdaHack.Client.UI.Frame: instance GHC.Classes.Eq Game.LambdaHack.Client.UI.Frame.SingleFrame

+ Game.LambdaHack.Client.UI.Frame: instance GHC.Show.Show Game.LambdaHack.Client.UI.Frame.SingleFrame

+ Game.LambdaHack.Client.UI.Frame: newtype SingleFrame

+ Game.LambdaHack.Client.UI.Frame: overlayFrame :: Overlay -> FrameForall -> FrameForall

+ Game.LambdaHack.Client.UI.Frame: overlayFrameWithLines :: Bool -> [AttrLine] -> FrameForall -> FrameForall

+ Game.LambdaHack.Client.UI.Frame: type Frames = [Maybe FrameForall]

+ Game.LambdaHack.Client.UI.FrameM: animate :: MonadClientUI m => LevelId -> Animation -> m ()

+ Game.LambdaHack.Client.UI.FrameM: drawOverlay :: MonadClientUI m => ColorMode -> Bool -> [AttrLine] -> LevelId -> m FrameForall

+ Game.LambdaHack.Client.UI.FrameM: fadeOutOrIn :: MonadClientUI m => Bool -> m ()

+ Game.LambdaHack.Client.UI.FrameM: promptGetKey :: MonadClientUI m => ColorMode -> [AttrLine] -> Bool -> [KM] -> m KM

+ Game.LambdaHack.Client.UI.FrameM: stopPlayBack :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.Frontend: KMP :: !KM -> !Point -> KMP

+ Game.LambdaHack.Client.UI.Frontend: [FrontAdd] :: KMP -> FrontReq ()

+ Game.LambdaHack.Client.UI.Frontend: [FrontAutoYes] :: Bool -> FrontReq ()

+ Game.LambdaHack.Client.UI.Frontend: [FrontDelay] :: !Int -> FrontReq ()

+ Game.LambdaHack.Client.UI.Frontend: [FrontDiscard] :: FrontReq ()

+ Game.LambdaHack.Client.UI.Frontend: [FrontFrame] :: {frontFrame :: !FrameForall} -> FrontReq ()

+ Game.LambdaHack.Client.UI.Frontend: [FrontKey] :: {frontKeyKeys :: ![KM], frontKeyFrame :: !FrameForall} -> FrontReq KMP

+ Game.LambdaHack.Client.UI.Frontend: [FrontPressed] :: FrontReq Bool

+ Game.LambdaHack.Client.UI.Frontend: [FrontShutdown] :: FrontReq ()

+ Game.LambdaHack.Client.UI.Frontend: [kmpKeyMod] :: KMP -> !KM

+ Game.LambdaHack.Client.UI.Frontend: [kmpPointer] :: KMP -> !Point

+ Game.LambdaHack.Client.UI.Frontend: chanFrontendIO :: DebugModeCli -> IO ChanFrontend

+ Game.LambdaHack.Client.UI.Frontend: data KMP

+ Game.LambdaHack.Client.UI.Frontend: defaultMaxFps :: Int

+ Game.LambdaHack.Client.UI.Frontend: display :: RawFrontend -> FrameForall -> IO ()

+ Game.LambdaHack.Client.UI.Frontend: fchanFrontend :: DebugModeCli -> FSession -> RawFrontend -> ChanFrontend

+ Game.LambdaHack.Client.UI.Frontend: frameTimeoutThread :: Int -> MVar Int -> RawFrontend -> IO ()

+ Game.LambdaHack.Client.UI.Frontend: getKey :: DebugModeCli -> FSession -> RawFrontend -> [KM] -> FrameForall -> IO KMP

+ Game.LambdaHack.Client.UI.Frontend: lazyStartup :: IO RawFrontend

+ Game.LambdaHack.Client.UI.Frontend: microInSec :: Int

+ Game.LambdaHack.Client.UI.Frontend: newtype ChanFrontend

+ Game.LambdaHack.Client.UI.Frontend: nullStartup :: IO RawFrontend

+ Game.LambdaHack.Client.UI.Frontend: seqFrame :: SingleFrame -> IO ()

+ Game.LambdaHack.Client.UI.Frontend.Chosen: startup :: DebugModeCli -> IO RawFrontend

+ Game.LambdaHack.Client.UI.Frontend.Common: KMP :: !KM -> !Point -> KMP

+ Game.LambdaHack.Client.UI.Frontend.Common: RawFrontend :: !(SingleFrame -> IO ()) -> !(IO ()) -> !(MVar ()) -> !(TQueue KMP) -> RawFrontend

+ Game.LambdaHack.Client.UI.Frontend.Common: [fchanKey] :: RawFrontend -> !(TQueue KMP)

+ Game.LambdaHack.Client.UI.Frontend.Common: [fdisplay] :: RawFrontend -> !(SingleFrame -> IO ())

+ Game.LambdaHack.Client.UI.Frontend.Common: [fshowNow] :: RawFrontend -> !(MVar ())

+ Game.LambdaHack.Client.UI.Frontend.Common: [fshutdown] :: RawFrontend -> !(IO ())

+ Game.LambdaHack.Client.UI.Frontend.Common: [kmpKeyMod] :: KMP -> !KM

+ Game.LambdaHack.Client.UI.Frontend.Common: [kmpPointer] :: KMP -> !Point

+ Game.LambdaHack.Client.UI.Frontend.Common: createRawFrontend :: (SingleFrame -> IO ()) -> IO () -> IO RawFrontend

+ Game.LambdaHack.Client.UI.Frontend.Common: data KMP

+ Game.LambdaHack.Client.UI.Frontend.Common: data RawFrontend

+ Game.LambdaHack.Client.UI.Frontend.Common: modifierTranslate :: Bool -> Bool -> Bool -> Bool -> Modifier

+ Game.LambdaHack.Client.UI.Frontend.Common: resetChanKey :: TQueue KMP -> IO ()

+ Game.LambdaHack.Client.UI.Frontend.Common: saveKMP :: RawFrontend -> Modifier -> Key -> Point -> IO ()

+ Game.LambdaHack.Client.UI.Frontend.Common: startupBound :: (MVar RawFrontend -> IO ()) -> IO RawFrontend

+ Game.LambdaHack.Client.UI.Frontend.Teletype: display :: SingleFrame -> IO ()

+ Game.LambdaHack.Client.UI.Frontend.Teletype: frontendName :: String

+ Game.LambdaHack.Client.UI.Frontend.Teletype: shutdown :: IO ()

+ Game.LambdaHack.Client.UI.Frontend.Teletype: startup :: DebugModeCli -> IO RawFrontend

+ Game.LambdaHack.Client.UI.HandleHelperM: failMsg :: MonadClientUI m => Text -> m MError

+ Game.LambdaHack.Client.UI.HandleHelperM: failSer :: MonadClientUI m => ReqFailure -> m (FailOrCmd a)

+ Game.LambdaHack.Client.UI.HandleHelperM: failWith :: MonadClientUI m => Text -> m (FailOrCmd a)

+ Game.LambdaHack.Client.UI.HandleHelperM: instance GHC.Show.Show Game.LambdaHack.Client.UI.HandleHelperM.FailError

+ Game.LambdaHack.Client.UI.HandleHelperM: itemOverlay :: MonadClientUI m => CStore -> LevelId -> ItemBag -> m OKX

+ Game.LambdaHack.Client.UI.HandleHelperM: memberBack :: MonadClientUI m => Bool -> m MError

+ Game.LambdaHack.Client.UI.HandleHelperM: memberCycle :: MonadClientUI m => Bool -> m MError

+ Game.LambdaHack.Client.UI.HandleHelperM: mergeMError :: MError -> MError -> MError

+ Game.LambdaHack.Client.UI.HandleHelperM: partyAfterLeader :: MonadClientUI m => ActorId -> m [(ActorId, Actor, ActorUI)]

+ Game.LambdaHack.Client.UI.HandleHelperM: pickLeader :: MonadClientUI m => Bool -> ActorId -> m Bool

+ Game.LambdaHack.Client.UI.HandleHelperM: pickLeaderWithPointer :: MonadClientUI m => m MError

+ Game.LambdaHack.Client.UI.HandleHelperM: pickNumber :: MonadClientUI m => Bool -> Int -> m (Either MError Int)

+ Game.LambdaHack.Client.UI.HandleHelperM: showFailError :: FailError -> Text

+ Game.LambdaHack.Client.UI.HandleHelperM: sortSlots :: MonadClientUI m => FactionId -> Maybe Actor -> m ()

+ Game.LambdaHack.Client.UI.HandleHelperM: statsOverlay :: MonadClient m => ActorId -> m OKX

+ Game.LambdaHack.Client.UI.HandleHelperM: type FailOrCmd a = Either FailError a

+ Game.LambdaHack.Client.UI.HandleHelperM: type MError = Maybe FailError

+ Game.LambdaHack.Client.UI.HandleHelperM: weaveJust :: FailOrCmd a -> Either MError a

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: alterDirHuman :: MonadClientUI m => [Trigger] -> m (FailOrCmd (RequestTimed AbAlter))

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: alterWithPointerHuman :: MonadClientUI m => [Trigger] -> m (FailOrCmd (RequestTimed AbAlter))

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: applyHuman :: MonadClientUI m => [Trigger] -> m (FailOrCmd (RequestTimed AbApply))

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: automateHuman :: MonadClientUI m => m (FailOrCmd ReqUI)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: byAimModeHuman :: MonadClientUI m => m (Either MError ReqUI) -> m (Either MError ReqUI) -> m (Either MError ReqUI)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: byAreaHuman :: MonadClientUI m => (HumanCmd -> m (Either MError ReqUI)) -> [(CmdArea, HumanCmd)] -> m (Either MError ReqUI)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: byItemModeHuman :: MonadClientUI m => [Trigger] -> m (Either MError ReqUI) -> m (Either MError ReqUI) -> m (Either MError ReqUI)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: challengesMenuHuman :: MonadClientUI m => (HumanCmd -> m (Either MError ReqUI)) -> m (Either MError ReqUI)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: chooseItemMenuHuman :: MonadClientUI m => (HumanCmd -> m (Either MError ReqUI)) -> ItemDialogMode -> m (Either MError ReqUI)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: compose2ndLocalHuman :: MonadClientUI m => m (Either MError ReqUI) -> m (Either MError ReqUI) -> m (Either MError ReqUI)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: composeIfLocalHuman :: MonadClientUI m => m (Either MError ReqUI) -> m (Either MError ReqUI) -> m (Either MError ReqUI)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: composeUnlessErrorHuman :: MonadClientUI m => m (Either MError ReqUI) -> m (Either MError ReqUI) -> m (Either MError ReqUI)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: continueToXhairHuman :: MonadClientUI m => m (FailOrCmd RequestAnyAbility)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: gameDifficultyIncr :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: gameExitHuman :: MonadClientUI m => m ReqUI

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: gameFishToggle :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: gameRestartHuman :: MonadClientUI m => m (FailOrCmd ReqUI)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: gameSaveHuman :: MonadClientUI m => m ReqUI

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: gameScenarioIncr :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: gameWolfToggle :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: helpHuman :: MonadClientUI m => (HumanCmd -> m (Either MError ReqUI)) -> m (Either MError ReqUI)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: itemMenuHuman :: MonadClientUI m => (HumanCmd -> m (Either MError ReqUI)) -> m (Either MError ReqUI)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: loopOnNothingHuman :: MonadClientUI m => m (Either MError ReqUI) -> m (Either MError ReqUI)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: mainMenuHuman :: MonadClientUI m => (HumanCmd -> m (Either MError ReqUI)) -> m (Either MError ReqUI)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: moveItemHuman :: forall m. MonadClientUI m => [CStore] -> CStore -> Maybe Part -> Bool -> m (FailOrCmd (RequestTimed AbMoveItem))

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: moveOnceToXhairHuman :: MonadClientUI m => m (FailOrCmd RequestAnyAbility)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: moveRunHuman :: MonadClientUI m => Bool -> Bool -> Bool -> Bool -> Vector -> m (FailOrCmd RequestAnyAbility)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: projectHuman :: MonadClientUI m => [Trigger] -> m (FailOrCmd (RequestTimed AbProject))

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: runOnceAheadHuman :: MonadClientUI m => m (Either MError ReqUI)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: runOnceToXhairHuman :: MonadClientUI m => m (FailOrCmd RequestAnyAbility)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: settingsMenuHuman :: MonadClientUI m => (HumanCmd -> m (Either MError ReqUI)) -> m (Either MError ReqUI)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: tacticHuman :: MonadClientUI m => m (FailOrCmd ReqUI)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: waitHuman :: MonadClientUI m => m (RequestTimed AbWait)

+ Game.LambdaHack.Client.UI.HandleHumanGlobalM: waitHuman10 :: MonadClientUI m => m (RequestTimed AbWait)

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: acceptHuman :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: aimAscendHuman :: MonadClientUI m => Int -> m MError

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: aimEnemyHuman :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: aimFloorHuman :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: aimItemHuman :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: aimPointerEnemyHuman :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: aimPointerFloorHuman :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: aimTgtHuman :: MonadClientUI m => m MError

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: cancelHuman :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: chooseItemApplyHuman :: forall m. MonadClientUI m => [Trigger] -> m MError

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: chooseItemDialogMode :: MonadClientUI m => ItemDialogMode -> m (FailOrCmd ItemDialogMode)

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: chooseItemHuman :: MonadClientUI m => ItemDialogMode -> m MError

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: chooseItemProjectHuman :: forall m. MonadClientUI m => [Trigger] -> m MError

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: clearHuman :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: epsIncrHuman :: MonadClientUI m => Bool -> m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: historyHuman :: forall m. MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: itemClearHuman :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: macroHuman :: MonadClientUI m => [String] -> m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: markSmellHuman :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: markSuspectHuman :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: markVisionHuman :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: memberBackHuman :: MonadClientUI m => m MError

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: memberCycleHuman :: MonadClientUI m => m MError

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: moveXhairHuman :: MonadClientUI m => Vector -> Int -> m MError

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: permittedApplyClient :: MonadClientUI m => [Char] -> m (ItemFull -> Either ReqFailure Bool)

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: pickLeaderHuman :: MonadClientUI m => Int -> m MError

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: pickLeaderWithPointerHuman :: MonadClientUI m => m MError

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: psuitReq :: MonadClientUI m => [Trigger] -> m (Either Text (ItemFull -> Either ReqFailure (Point, Bool)))

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: recordHuman :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: repeatHuman :: MonadClientUI m => Int -> m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: selectActorHuman :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: selectNoneHuman :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: selectWithPointerHuman :: MonadClientUI m => m MError

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: sortSlotsHuman :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: tgtClearHuman :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: triggerSymbols :: [Trigger] -> [Char]

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: xhairItemHuman :: MonadClientUI m => m MError

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: xhairPointerEnemyHuman :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: xhairPointerFloorHuman :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: xhairStairHuman :: MonadClientUI m => Bool -> m MError

+ Game.LambdaHack.Client.UI.HandleHumanLocalM: xhairUnknownHuman :: MonadClientUI m => m MError

+ Game.LambdaHack.Client.UI.HandleHumanM: cmdHumanSem :: MonadClientUI m => HumanCmd -> m (Either MError ReqUI)

+ Game.LambdaHack.Client.UI.HumanCmd: AimAscend :: !Int -> HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: AimEnemy :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: AimFloor :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: AimItem :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: AimPointerEnemy :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: AimPointerFloor :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: AimTgt :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: AlterWithPointer :: ![Trigger] -> HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: ByAimMode :: !HumanCmd -> !HumanCmd -> HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: ByArea :: ![(CmdArea, HumanCmd)] -> HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: ByItemMode :: ![Trigger] -> !HumanCmd -> !HumanCmd -> HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: CaArenaName :: CmdArea

+ Game.LambdaHack.Client.UI.HumanCmd: CaCalmGauge :: CmdArea

+ Game.LambdaHack.Client.UI.HumanCmd: CaHPGauge :: CmdArea

+ Game.LambdaHack.Client.UI.HumanCmd: CaLevelNumber :: CmdArea

+ Game.LambdaHack.Client.UI.HumanCmd: CaMap :: CmdArea

+ Game.LambdaHack.Client.UI.HumanCmd: CaMapLeader :: CmdArea

+ Game.LambdaHack.Client.UI.HumanCmd: CaMapParty :: CmdArea

+ Game.LambdaHack.Client.UI.HumanCmd: CaMessage :: CmdArea

+ Game.LambdaHack.Client.UI.HumanCmd: CaPercentSeen :: CmdArea

+ Game.LambdaHack.Client.UI.HumanCmd: CaSelected :: CmdArea

+ Game.LambdaHack.Client.UI.HumanCmd: CaTargetDesc :: CmdArea

+ Game.LambdaHack.Client.UI.HumanCmd: CaXhairDesc :: CmdArea

+ Game.LambdaHack.Client.UI.HumanCmd: ChallengesMenu :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: ChooseItem :: !ItemDialogMode -> HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: ChooseItemApply :: ![Trigger] -> HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: ChooseItemMenu :: !ItemDialogMode -> HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: ChooseItemProject :: ![Trigger] -> HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: CmdAim :: CmdCategory

+ Game.LambdaHack.Client.UI.HumanCmd: CmdItemMenu :: CmdCategory

+ Game.LambdaHack.Client.UI.HumanCmd: CmdMainMenu :: CmdCategory

+ Game.LambdaHack.Client.UI.HumanCmd: CmdNoHelp :: CmdCategory

+ Game.LambdaHack.Client.UI.HumanCmd: Compose2ndLocal :: !HumanCmd -> !HumanCmd -> HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: ComposeIfLocal :: !HumanCmd -> !HumanCmd -> HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: ComposeUnlessError :: !HumanCmd -> !HumanCmd -> HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: ContinueToXhair :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: GameDifficultyIncr :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: GameFishToggle :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: GameScenarioIncr :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: GameWolfToggle :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: ItemClear :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: ItemMenu :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: LoopOnNothing :: !HumanCmd -> HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: MoveDir :: !Vector -> HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: MoveOnceToXhair :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: MoveXhair :: !Vector -> !Int -> HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: PickLeaderWithPointer :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: RunDir :: !Vector -> HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: RunOnceToXhair :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: SettingsMenu :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: SortSlots :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: Wait10 :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: XhairItem :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: XhairPointerEnemy :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: XhairPointerFloor :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: XhairStair :: !Bool -> HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: XhairUnknown :: HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: [aiming] :: HumanCmd -> !HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: [chosen] :: HumanCmd -> !HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: [exploration] :: HumanCmd -> !HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: [feature] :: Trigger -> !Feature

+ Game.LambdaHack.Client.UI.HumanCmd: [notChosen] :: HumanCmd -> !HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: [object] :: Trigger -> !Part

+ Game.LambdaHack.Client.UI.HumanCmd: [symbol] :: Trigger -> !Char

+ Game.LambdaHack.Client.UI.HumanCmd: [ts] :: HumanCmd -> ![Trigger]

+ Game.LambdaHack.Client.UI.HumanCmd: [verb] :: Trigger -> !Part

+ Game.LambdaHack.Client.UI.HumanCmd: areaDescription :: CmdArea -> Text

+ Game.LambdaHack.Client.UI.HumanCmd: data CmdArea

+ Game.LambdaHack.Client.UI.HumanCmd: instance Control.DeepSeq.NFData Game.LambdaHack.Client.UI.HumanCmd.CmdArea

+ Game.LambdaHack.Client.UI.HumanCmd: instance Control.DeepSeq.NFData Game.LambdaHack.Client.UI.HumanCmd.CmdCategory

+ Game.LambdaHack.Client.UI.HumanCmd: instance Control.DeepSeq.NFData Game.LambdaHack.Client.UI.HumanCmd.HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: instance Control.DeepSeq.NFData Game.LambdaHack.Client.UI.HumanCmd.Trigger

+ Game.LambdaHack.Client.UI.HumanCmd: instance Data.Binary.Class.Binary Game.LambdaHack.Client.UI.HumanCmd.CmdArea

+ Game.LambdaHack.Client.UI.HumanCmd: instance Data.Binary.Class.Binary Game.LambdaHack.Client.UI.HumanCmd.CmdCategory

+ Game.LambdaHack.Client.UI.HumanCmd: instance Data.Binary.Class.Binary Game.LambdaHack.Client.UI.HumanCmd.HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: instance Data.Binary.Class.Binary Game.LambdaHack.Client.UI.HumanCmd.Trigger

+ Game.LambdaHack.Client.UI.HumanCmd: instance GHC.Classes.Eq Game.LambdaHack.Client.UI.HumanCmd.CmdArea

+ Game.LambdaHack.Client.UI.HumanCmd: instance GHC.Classes.Eq Game.LambdaHack.Client.UI.HumanCmd.CmdCategory

+ Game.LambdaHack.Client.UI.HumanCmd: instance GHC.Classes.Eq Game.LambdaHack.Client.UI.HumanCmd.HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: instance GHC.Classes.Eq Game.LambdaHack.Client.UI.HumanCmd.Trigger

+ Game.LambdaHack.Client.UI.HumanCmd: instance GHC.Classes.Ord Game.LambdaHack.Client.UI.HumanCmd.CmdArea

+ Game.LambdaHack.Client.UI.HumanCmd: instance GHC.Classes.Ord Game.LambdaHack.Client.UI.HumanCmd.HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: instance GHC.Classes.Ord Game.LambdaHack.Client.UI.HumanCmd.Trigger

+ Game.LambdaHack.Client.UI.HumanCmd: instance GHC.Generics.Generic Game.LambdaHack.Client.UI.HumanCmd.CmdArea

+ Game.LambdaHack.Client.UI.HumanCmd: instance GHC.Generics.Generic Game.LambdaHack.Client.UI.HumanCmd.CmdCategory

+ Game.LambdaHack.Client.UI.HumanCmd: instance GHC.Generics.Generic Game.LambdaHack.Client.UI.HumanCmd.HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: instance GHC.Generics.Generic Game.LambdaHack.Client.UI.HumanCmd.Trigger

+ Game.LambdaHack.Client.UI.HumanCmd: instance GHC.Read.Read Game.LambdaHack.Client.UI.HumanCmd.CmdArea

+ Game.LambdaHack.Client.UI.HumanCmd: instance GHC.Read.Read Game.LambdaHack.Client.UI.HumanCmd.CmdCategory

+ Game.LambdaHack.Client.UI.HumanCmd: instance GHC.Read.Read Game.LambdaHack.Client.UI.HumanCmd.HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: instance GHC.Read.Read Game.LambdaHack.Client.UI.HumanCmd.Trigger

+ Game.LambdaHack.Client.UI.HumanCmd: instance GHC.Show.Show Game.LambdaHack.Client.UI.HumanCmd.CmdArea

+ Game.LambdaHack.Client.UI.HumanCmd: instance GHC.Show.Show Game.LambdaHack.Client.UI.HumanCmd.CmdCategory

+ Game.LambdaHack.Client.UI.HumanCmd: instance GHC.Show.Show Game.LambdaHack.Client.UI.HumanCmd.HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: instance GHC.Show.Show Game.LambdaHack.Client.UI.HumanCmd.Trigger

+ Game.LambdaHack.Client.UI.HumanCmd: type CmdTriple = ([CmdCategory], Text, HumanCmd)

+ Game.LambdaHack.Client.UI.InventoryM: SuitsEverything :: Suitability

+ Game.LambdaHack.Client.UI.InventoryM: SuitsSomething :: (ItemFull -> Bool) -> Suitability

+ Game.LambdaHack.Client.UI.InventoryM: data Suitability

+ Game.LambdaHack.Client.UI.InventoryM: getFull :: MonadClientUI m => m Suitability -> (Actor -> ActorUI -> AspectRecord -> ItemDialogMode -> Text) -> (Actor -> ActorUI -> AspectRecord -> ItemDialogMode -> Text) -> [CStore] -> [CStore] -> Bool -> Bool -> m (Either Text ([(ItemId, ItemFull)], (ItemDialogMode, Either KM SlotChar)))

+ Game.LambdaHack.Client.UI.InventoryM: getGroupItem :: MonadClientUI m => m Suitability -> Text -> Text -> [CStore] -> [CStore] -> m (Either Text ((ItemId, ItemFull), (ItemDialogMode, Either KM SlotChar)))

+ Game.LambdaHack.Client.UI.InventoryM: getStoreItem :: MonadClientUI m => (Actor -> ActorUI -> AspectRecord -> ItemDialogMode -> Text) -> ItemDialogMode -> m (Either Text (ItemId, ItemFull), (ItemDialogMode, Either KM SlotChar))

+ Game.LambdaHack.Client.UI.InventoryM: instance GHC.Classes.Eq Game.LambdaHack.Client.UI.InventoryM.ItemDialogState

+ Game.LambdaHack.Client.UI.InventoryM: instance GHC.Show.Show Game.LambdaHack.Client.UI.InventoryM.ItemDialogState

+ Game.LambdaHack.Client.UI.InventoryM: ppItemDialogMode :: ItemDialogMode -> (Text, Text)

+ Game.LambdaHack.Client.UI.InventoryM: ppItemDialogModeFrom :: ItemDialogMode -> Text

+ Game.LambdaHack.Client.UI.InventoryM: storeFromMode :: ItemDialogMode -> CStore

+ Game.LambdaHack.Client.UI.ItemDescription: partItem :: FactionId -> FactionDict -> CStore -> Time -> ItemFull -> (Bool, Bool, Part, Part)

+ Game.LambdaHack.Client.UI.ItemDescription: partItemHigh :: FactionId -> FactionDict -> CStore -> Time -> ItemFull -> (Bool, Bool, Part, Part)

+ Game.LambdaHack.Client.UI.ItemDescription: partItemMediumAW :: FactionId -> FactionDict -> CStore -> Time -> ItemFull -> Part

+ Game.LambdaHack.Client.UI.ItemDescription: partItemShortAW :: FactionId -> FactionDict -> CStore -> Time -> ItemFull -> Part

+ Game.LambdaHack.Client.UI.ItemDescription: partItemShortWownW :: FactionId -> FactionDict -> Part -> CStore -> Time -> ItemFull -> Part

+ Game.LambdaHack.Client.UI.ItemDescription: partItemWs :: FactionId -> FactionDict -> Int -> CStore -> Time -> ItemFull -> Part

+ Game.LambdaHack.Client.UI.ItemDescription: partItemWsRanged :: FactionId -> FactionDict -> Int -> CStore -> Time -> ItemFull -> Part

+ Game.LambdaHack.Client.UI.ItemDescription: show64With2 :: Int64 -> Text

+ Game.LambdaHack.Client.UI.ItemDescription: viewItem :: Item -> AttrCharW32

+ Game.LambdaHack.Client.UI.ItemSlot: ItemSlots :: !(EnumMap SlotChar ItemId) -> !(EnumMap SlotChar ItemId) -> ItemSlots

+ Game.LambdaHack.Client.UI.ItemSlot: SlotChar :: !Int -> !Char -> SlotChar

+ Game.LambdaHack.Client.UI.ItemSlot: [slotChar] :: SlotChar -> !Char

+ Game.LambdaHack.Client.UI.ItemSlot: [slotPrefix] :: SlotChar -> !Int

+ Game.LambdaHack.Client.UI.ItemSlot: allSlots :: Int -> [SlotChar]

+ Game.LambdaHack.Client.UI.ItemSlot: allZeroSlots :: [SlotChar]

+ Game.LambdaHack.Client.UI.ItemSlot: assignSlot :: CStore -> Item -> FactionId -> Maybe Actor -> ItemSlots -> SlotChar -> State -> SlotChar

+ Game.LambdaHack.Client.UI.ItemSlot: data ItemSlots

+ Game.LambdaHack.Client.UI.ItemSlot: data SlotChar

+ Game.LambdaHack.Client.UI.ItemSlot: instance Data.Binary.Class.Binary Game.LambdaHack.Client.UI.ItemSlot.ItemSlots

+ Game.LambdaHack.Client.UI.ItemSlot: instance Data.Binary.Class.Binary Game.LambdaHack.Client.UI.ItemSlot.SlotChar

+ Game.LambdaHack.Client.UI.ItemSlot: instance GHC.Classes.Eq Game.LambdaHack.Client.UI.ItemSlot.SlotChar

+ Game.LambdaHack.Client.UI.ItemSlot: instance GHC.Classes.Ord Game.LambdaHack.Client.UI.ItemSlot.SlotChar

+ Game.LambdaHack.Client.UI.ItemSlot: instance GHC.Enum.Enum Game.LambdaHack.Client.UI.ItemSlot.SlotChar

+ Game.LambdaHack.Client.UI.ItemSlot: instance GHC.Show.Show Game.LambdaHack.Client.UI.ItemSlot.ItemSlots

+ Game.LambdaHack.Client.UI.ItemSlot: instance GHC.Show.Show Game.LambdaHack.Client.UI.ItemSlot.SlotChar

+ Game.LambdaHack.Client.UI.ItemSlot: intSlots :: [SlotChar]

+ Game.LambdaHack.Client.UI.ItemSlot: slotLabel :: SlotChar -> Text

+ Game.LambdaHack.Client.UI.Key: Alt :: Modifier

+ Game.LambdaHack.Client.UI.Key: BackSpace :: Key

+ Game.LambdaHack.Client.UI.Key: BackTab :: Key

+ Game.LambdaHack.Client.UI.Key: Begin :: Key

+ Game.LambdaHack.Client.UI.Key: Char :: !Char -> Key

+ Game.LambdaHack.Client.UI.Key: Control :: Modifier

+ Game.LambdaHack.Client.UI.Key: DeadKey :: Key

+ Game.LambdaHack.Client.UI.Key: Delete :: Key

+ Game.LambdaHack.Client.UI.Key: Down :: Key

+ Game.LambdaHack.Client.UI.Key: End :: Key

+ Game.LambdaHack.Client.UI.Key: Esc :: Key

+ Game.LambdaHack.Client.UI.Key: Fun :: !Int -> Key

+ Game.LambdaHack.Client.UI.Key: Home :: Key

+ Game.LambdaHack.Client.UI.Key: Insert :: Key

+ Game.LambdaHack.Client.UI.Key: KM :: !Modifier -> !Key -> KM

+ Game.LambdaHack.Client.UI.Key: KP :: !Char -> Key

+ Game.LambdaHack.Client.UI.Key: Left :: Key

+ Game.LambdaHack.Client.UI.Key: LeftButtonPress :: Key

+ Game.LambdaHack.Client.UI.Key: LeftButtonRelease :: Key

+ Game.LambdaHack.Client.UI.Key: MiddleButtonPress :: Key

+ Game.LambdaHack.Client.UI.Key: MiddleButtonRelease :: Key

+ Game.LambdaHack.Client.UI.Key: NoModifier :: Modifier

+ Game.LambdaHack.Client.UI.Key: PgDn :: Key

+ Game.LambdaHack.Client.UI.Key: PgUp :: Key

+ Game.LambdaHack.Client.UI.Key: Return :: Key

+ Game.LambdaHack.Client.UI.Key: Right :: Key

+ Game.LambdaHack.Client.UI.Key: RightButtonPress :: Key

+ Game.LambdaHack.Client.UI.Key: RightButtonRelease :: Key

+ Game.LambdaHack.Client.UI.Key: Shift :: Modifier

+ Game.LambdaHack.Client.UI.Key: Space :: Key

+ Game.LambdaHack.Client.UI.Key: Tab :: Key

+ Game.LambdaHack.Client.UI.Key: Unknown :: !String -> Key

+ Game.LambdaHack.Client.UI.Key: Up :: Key

+ Game.LambdaHack.Client.UI.Key: WheelNorth :: Key

+ Game.LambdaHack.Client.UI.Key: WheelSouth :: Key

+ Game.LambdaHack.Client.UI.Key: [key] :: KM -> !Key

+ Game.LambdaHack.Client.UI.Key: [modifier] :: KM -> !Modifier

+ Game.LambdaHack.Client.UI.Key: backspaceKM :: KM

+ Game.LambdaHack.Client.UI.Key: data KM

+ Game.LambdaHack.Client.UI.Key: data Key

+ Game.LambdaHack.Client.UI.Key: data Modifier

+ Game.LambdaHack.Client.UI.Key: dirAllKey :: Bool -> Bool -> [Key]

+ Game.LambdaHack.Client.UI.Key: downKM :: KM

+ Game.LambdaHack.Client.UI.Key: endKM :: KM

+ Game.LambdaHack.Client.UI.Key: escKM :: KM

+ Game.LambdaHack.Client.UI.Key: handleDir :: Bool -> Bool -> KM -> Maybe Vector

+ Game.LambdaHack.Client.UI.Key: homeKM :: KM

+ Game.LambdaHack.Client.UI.Key: instance Control.DeepSeq.NFData Game.LambdaHack.Client.UI.Key.KM

+ Game.LambdaHack.Client.UI.Key: instance Control.DeepSeq.NFData Game.LambdaHack.Client.UI.Key.Key

+ Game.LambdaHack.Client.UI.Key: instance Control.DeepSeq.NFData Game.LambdaHack.Client.UI.Key.Modifier

+ Game.LambdaHack.Client.UI.Key: instance Data.Binary.Class.Binary Game.LambdaHack.Client.UI.Key.KM

+ Game.LambdaHack.Client.UI.Key: instance Data.Binary.Class.Binary Game.LambdaHack.Client.UI.Key.Key

+ Game.LambdaHack.Client.UI.Key: instance Data.Binary.Class.Binary Game.LambdaHack.Client.UI.Key.Modifier

+ Game.LambdaHack.Client.UI.Key: instance GHC.Classes.Eq Game.LambdaHack.Client.UI.Key.KM

+ Game.LambdaHack.Client.UI.Key: instance GHC.Classes.Eq Game.LambdaHack.Client.UI.Key.Key

+ Game.LambdaHack.Client.UI.Key: instance GHC.Classes.Eq Game.LambdaHack.Client.UI.Key.Modifier

+ Game.LambdaHack.Client.UI.Key: instance GHC.Classes.Ord Game.LambdaHack.Client.UI.Key.KM

+ Game.LambdaHack.Client.UI.Key: instance GHC.Classes.Ord Game.LambdaHack.Client.UI.Key.Key

+ Game.LambdaHack.Client.UI.Key: instance GHC.Classes.Ord Game.LambdaHack.Client.UI.Key.Modifier

+ Game.LambdaHack.Client.UI.Key: instance GHC.Generics.Generic Game.LambdaHack.Client.UI.Key.KM

+ Game.LambdaHack.Client.UI.Key: instance GHC.Generics.Generic Game.LambdaHack.Client.UI.Key.Key

+ Game.LambdaHack.Client.UI.Key: instance GHC.Generics.Generic Game.LambdaHack.Client.UI.Key.Modifier

+ Game.LambdaHack.Client.UI.Key: instance GHC.Show.Show Game.LambdaHack.Client.UI.Key.KM

+ Game.LambdaHack.Client.UI.Key: instance GHC.Show.Show Game.LambdaHack.Client.UI.Key.Modifier

+ Game.LambdaHack.Client.UI.Key: keyTranslate :: String -> Key

+ Game.LambdaHack.Client.UI.Key: keyTranslateWeb :: String -> Bool -> Key

+ Game.LambdaHack.Client.UI.Key: leftButtonReleaseKM :: KM

+ Game.LambdaHack.Client.UI.Key: leftKM :: KM

+ Game.LambdaHack.Client.UI.Key: mkChar :: Char -> KM

+ Game.LambdaHack.Client.UI.Key: mkKM :: String -> KM

+ Game.LambdaHack.Client.UI.Key: mkKP :: Char -> KM

+ Game.LambdaHack.Client.UI.Key: moveBinding :: Bool -> Bool -> (Vector -> a) -> (Vector -> a) -> [(KM, a)]

+ Game.LambdaHack.Client.UI.Key: pgdnKM :: KM

+ Game.LambdaHack.Client.UI.Key: pgupKM :: KM

+ Game.LambdaHack.Client.UI.Key: returnKM :: KM

+ Game.LambdaHack.Client.UI.Key: rightButtonReleaseKM :: KM

+ Game.LambdaHack.Client.UI.Key: rightKM :: KM

+ Game.LambdaHack.Client.UI.Key: safeSpaceKM :: KM

+ Game.LambdaHack.Client.UI.Key: showKM :: KM -> String

+ Game.LambdaHack.Client.UI.Key: showKey :: Key -> String

+ Game.LambdaHack.Client.UI.Key: spaceKM :: KM

+ Game.LambdaHack.Client.UI.Key: upKM :: KM

+ Game.LambdaHack.Client.UI.Key: wheelNorthKM :: KM

+ Game.LambdaHack.Client.UI.Key: wheelSouthKM :: KM

+ Game.LambdaHack.Client.UI.KeyBindings: [bcmdList] :: Binding -> ![(KM, CmdTriple)]

+ Game.LambdaHack.Client.UI.KeyBindings: [bcmdMap] :: Binding -> !(Map KM CmdTriple)

+ Game.LambdaHack.Client.UI.KeyBindings: [brevMap] :: Binding -> !(Map HumanCmd [KM])

+ Game.LambdaHack.Client.UI.KeyBindings: okxsN :: Binding -> Int -> Int -> (HumanCmd -> Bool) -> CmdCategory -> [Text] -> [Text] -> OKX

+ Game.LambdaHack.Client.UI.MonadClientUI: addPressedEsc :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.MonadClientUI: anyKeyPressed :: MonadClientUI m => m Bool

+ Game.LambdaHack.Client.UI.MonadClientUI: chanFrontend :: MonadClientUI m => DebugModeCli -> m ChanFrontend

+ Game.LambdaHack.Client.UI.MonadClientUI: clearAimMode :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.MonadClientUI: clearXhair :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.MonadClientUI: clientPrintUI :: MonadClientUI m => Text -> m ()

+ Game.LambdaHack.Client.UI.MonadClientUI: connFrontendFrontKey :: MonadClientUI m => [KM] -> FrameForall -> m KM

+ Game.LambdaHack.Client.UI.MonadClientUI: defaultHistory :: MonadClientUI m => Int -> m History

+ Game.LambdaHack.Client.UI.MonadClientUI: discardPressedKey :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.MonadClientUI: displayFrames :: MonadClientUI m => LevelId -> Frames -> m ()

+ Game.LambdaHack.Client.UI.MonadClientUI: elapsedSessionTimeGT :: MonadClientUI m => Int -> m Bool

+ Game.LambdaHack.Client.UI.MonadClientUI: frontendShutdown :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.MonadClientUI: getReportUI :: MonadClientUI m => m Report

+ Game.LambdaHack.Client.UI.MonadClientUI: getSession :: MonadClientUI m => m SessionUI

+ Game.LambdaHack.Client.UI.MonadClientUI: leaderSkillsClientUI :: MonadClientUI m => m Skills

+ Game.LambdaHack.Client.UI.MonadClientUI: mapStartY :: Y

+ Game.LambdaHack.Client.UI.MonadClientUI: modifySession :: MonadClientUI m => (SessionUI -> SessionUI) -> m ()

+ Game.LambdaHack.Client.UI.MonadClientUI: partActorLeader :: MonadClientUI m => ActorId -> ActorUI -> m Part

+ Game.LambdaHack.Client.UI.MonadClientUI: partActorLeaderFun :: MonadClientUI m => m (ActorId -> Part)

+ Game.LambdaHack.Client.UI.MonadClientUI: partAidLeader :: MonadClientUI m => ActorId -> m Part

+ Game.LambdaHack.Client.UI.MonadClientUI: partPronounLeader :: MonadClient m => ActorId -> ActorUI -> m Part

+ Game.LambdaHack.Client.UI.MonadClientUI: putSession :: MonadClientUI m => SessionUI -> m ()

+ Game.LambdaHack.Client.UI.MonadClientUI: resetGameStart :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.MonadClientUI: resetSessionStart :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.MonadClientUI: tellAllClipPS :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.MonadClientUI: tellGameClipPS :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.MonadClientUI: tryRestore :: MonadClientUI m => m (Maybe (State, StateClient, Maybe SessionUI))

+ Game.LambdaHack.Client.UI.MonadClientUI: viewedLevelUI :: MonadClientUI m => m LevelId

+ Game.LambdaHack.Client.UI.MonadClientUI: xhairToPos :: MonadClientUI m => m (Maybe Point)

+ Game.LambdaHack.Client.UI.Msg: addReport :: History -> Time -> Report -> History

+ Game.LambdaHack.Client.UI.Msg: consReportNoScrub :: Msg -> Report -> Report

+ Game.LambdaHack.Client.UI.Msg: data History

+ Game.LambdaHack.Client.UI.Msg: data Msg

+ Game.LambdaHack.Client.UI.Msg: data RepMsgN

+ Game.LambdaHack.Client.UI.Msg: data Report

+ Game.LambdaHack.Client.UI.Msg: emptyHistory :: Int -> History

+ Game.LambdaHack.Client.UI.Msg: emptyReport :: Report

+ Game.LambdaHack.Client.UI.Msg: findInReport :: (AttrLine -> Bool) -> Report -> Maybe Msg

+ Game.LambdaHack.Client.UI.Msg: instance Data.Binary.Class.Binary Game.LambdaHack.Client.UI.Msg.History

+ Game.LambdaHack.Client.UI.Msg: instance Data.Binary.Class.Binary Game.LambdaHack.Client.UI.Msg.Msg

+ Game.LambdaHack.Client.UI.Msg: instance Data.Binary.Class.Binary Game.LambdaHack.Client.UI.Msg.RepMsgN

+ Game.LambdaHack.Client.UI.Msg: instance Data.Binary.Class.Binary Game.LambdaHack.Client.UI.Msg.Report

+ Game.LambdaHack.Client.UI.Msg: instance GHC.Classes.Eq Game.LambdaHack.Client.UI.Msg.Msg

+ Game.LambdaHack.Client.UI.Msg: instance GHC.Generics.Generic Game.LambdaHack.Client.UI.Msg.History

+ Game.LambdaHack.Client.UI.Msg: instance GHC.Generics.Generic Game.LambdaHack.Client.UI.Msg.Msg

+ Game.LambdaHack.Client.UI.Msg: instance GHC.Generics.Generic Game.LambdaHack.Client.UI.Msg.RepMsgN

+ Game.LambdaHack.Client.UI.Msg: instance GHC.Show.Show Game.LambdaHack.Client.UI.Msg.History

+ Game.LambdaHack.Client.UI.Msg: instance GHC.Show.Show Game.LambdaHack.Client.UI.Msg.Msg

+ Game.LambdaHack.Client.UI.Msg: instance GHC.Show.Show Game.LambdaHack.Client.UI.Msg.RepMsgN

+ Game.LambdaHack.Client.UI.Msg: instance GHC.Show.Show Game.LambdaHack.Client.UI.Msg.Report

+ Game.LambdaHack.Client.UI.Msg: lastMsgOfReport :: Report -> (AttrLine, Report)

+ Game.LambdaHack.Client.UI.Msg: lastReportOfHistory :: History -> Report

+ Game.LambdaHack.Client.UI.Msg: lengthHistory :: History -> Int

+ Game.LambdaHack.Client.UI.Msg: nullReport :: Report -> Bool

+ Game.LambdaHack.Client.UI.Msg: renderHistory :: History -> [AttrLine]

+ Game.LambdaHack.Client.UI.Msg: renderReport :: Report -> AttrLine

+ Game.LambdaHack.Client.UI.Msg: singletonReport :: Msg -> Report

+ Game.LambdaHack.Client.UI.Msg: snocReport :: Report -> Msg -> Report

+ Game.LambdaHack.Client.UI.Msg: splitReportForHistory :: X -> AttrLine -> [AttrLine]

+ Game.LambdaHack.Client.UI.Msg: toMsg :: AttrLine -> Msg

+ Game.LambdaHack.Client.UI.Msg: toPrompt :: AttrLine -> Msg

+ Game.LambdaHack.Client.UI.MsgM: msgAdd :: MonadClientUI m => Text -> m ()

+ Game.LambdaHack.Client.UI.MsgM: promptAdd :: MonadClientUI m => Text -> m ()

+ Game.LambdaHack.Client.UI.MsgM: promptAddAttr :: MonadClientUI m => AttrLine -> m ()

+ Game.LambdaHack.Client.UI.MsgM: recordHistory :: MonadClientUI m => m ()

+ Game.LambdaHack.Client.UI.Overlay: (<+:>) :: AttrLine -> AttrLine -> AttrLine

+ Game.LambdaHack.Client.UI.Overlay: ColorBW :: ColorMode

+ Game.LambdaHack.Client.UI.Overlay: ColorFull :: ColorMode

+ Game.LambdaHack.Client.UI.Overlay: FrameForall :: (forall s. FrameST s) -> FrameForall

+ Game.LambdaHack.Client.UI.Overlay: [unFrameForall] :: FrameForall -> forall s. FrameST s

+ Game.LambdaHack.Client.UI.Overlay: data ColorMode

+ Game.LambdaHack.Client.UI.Overlay: emptyAttrLine :: Int -> AttrLine

+ Game.LambdaHack.Client.UI.Overlay: fgToAL :: Color -> Text -> AttrLine

+ Game.LambdaHack.Client.UI.Overlay: glueLines :: [AttrLine] -> [AttrLine] -> [AttrLine]

+ Game.LambdaHack.Client.UI.Overlay: infixr 6 <+:>

+ Game.LambdaHack.Client.UI.Overlay: instance GHC.Classes.Eq Game.LambdaHack.Client.UI.Overlay.ColorMode

+ Game.LambdaHack.Client.UI.Overlay: itemDesc :: FactionId -> FactionDict -> Int -> CStore -> Time -> ItemFull -> AttrLine

+ Game.LambdaHack.Client.UI.Overlay: newtype FrameForall

+ Game.LambdaHack.Client.UI.Overlay: splitAttrLine :: X -> AttrLine -> [AttrLine]

+ Game.LambdaHack.Client.UI.Overlay: stringToAL :: String -> AttrLine

+ Game.LambdaHack.Client.UI.Overlay: textToAL :: Text -> AttrLine

+ Game.LambdaHack.Client.UI.Overlay: type AttrLine = [AttrCharW32]

+ Game.LambdaHack.Client.UI.Overlay: type FrameST s = Mutable Vector s Word32 -> ST s ()

+ Game.LambdaHack.Client.UI.Overlay: type Overlay = [(Int, AttrLine)]

+ Game.LambdaHack.Client.UI.Overlay: updateLines :: Int -> (AttrLine -> AttrLine) -> [AttrLine] -> [AttrLine]

+ Game.LambdaHack.Client.UI.Overlay: writeLine :: Int -> AttrLine -> FrameForall

+ Game.LambdaHack.Client.UI.OverlayM: describeMainKeys :: MonadClientUI m => m Text

+ Game.LambdaHack.Client.UI.OverlayM: lookAt :: MonadClientUI m => Bool -> Text -> Bool -> Point -> ActorId -> Text -> m Text

+ Game.LambdaHack.Client.UI.RunM: continueRun :: MonadClientUI m => LevelId -> RunParams -> m (Either Text RequestAnyAbility)

+ Game.LambdaHack.Client.UI.SessionUI: AimMode :: LevelId -> AimMode

+ Game.LambdaHack.Client.UI.SessionUI: KeysHintAbsent :: KeysHintMode

+ Game.LambdaHack.Client.UI.SessionUI: KeysHintBlocked :: KeysHintMode

+ Game.LambdaHack.Client.UI.SessionUI: KeysHintPresent :: KeysHintMode

+ Game.LambdaHack.Client.UI.SessionUI: RunParams :: !ActorId -> ![ActorId] -> !Bool -> !(Maybe Text) -> !Int -> RunParams

+ Game.LambdaHack.Client.UI.SessionUI: SessionUI :: !Target -> !ActorDictUI -> !ItemSlots -> !SlotChar -> !ChanFrontend -> !Binding -> !Config -> !(Maybe AimMode) -> !Bool -> !(Maybe (CStore, ItemId)) -> !(EnumSet ActorId) -> !(Maybe RunParams) -> !Report -> !History -> !Point -> !LastRecord -> ![KM] -> !(EnumSet ActorId) -> !Int -> !Bool -> !Bool -> !(Map String Int) -> !Bool -> !KeysHintMode -> !POSIXTime -> !POSIXTime -> !Time -> !Int -> !Int -> SessionUI

+ Game.LambdaHack.Client.UI.SessionUI: [_sreport] :: SessionUI -> !Report

+ Game.LambdaHack.Client.UI.SessionUI: [aimLevelId] :: AimMode -> LevelId

+ Game.LambdaHack.Client.UI.SessionUI: [runInitial] :: RunParams -> !Bool

+ Game.LambdaHack.Client.UI.SessionUI: [runLeader] :: RunParams -> !ActorId

+ Game.LambdaHack.Client.UI.SessionUI: [runMembers] :: RunParams -> ![ActorId]

+ Game.LambdaHack.Client.UI.SessionUI: [runStopMsg] :: RunParams -> !(Maybe Text)

+ Game.LambdaHack.Client.UI.SessionUI: [runWaiting] :: RunParams -> !Int

+ Game.LambdaHack.Client.UI.SessionUI: [sactorUI] :: SessionUI -> !ActorDictUI

+ Game.LambdaHack.Client.UI.SessionUI: [saimMode] :: SessionUI -> !(Maybe AimMode)

+ Game.LambdaHack.Client.UI.SessionUI: [sallNframes] :: SessionUI -> !Int

+ Game.LambdaHack.Client.UI.SessionUI: [sallTime] :: SessionUI -> !Time

+ Game.LambdaHack.Client.UI.SessionUI: [sbinding] :: SessionUI -> !Binding

+ Game.LambdaHack.Client.UI.SessionUI: [schanF] :: SessionUI -> !ChanFrontend

+ Game.LambdaHack.Client.UI.SessionUI: [sconfig] :: SessionUI -> !Config

+ Game.LambdaHack.Client.UI.SessionUI: [sdisplayNeeded] :: SessionUI -> !Bool

+ Game.LambdaHack.Client.UI.SessionUI: [sgstart] :: SessionUI -> !POSIXTime

+ Game.LambdaHack.Client.UI.SessionUI: [shistory] :: SessionUI -> !History

+ Game.LambdaHack.Client.UI.SessionUI: [sitemSel] :: SessionUI -> !(Maybe (CStore, ItemId))

+ Game.LambdaHack.Client.UI.SessionUI: [skeysHintMode] :: SessionUI -> !KeysHintMode

+ Game.LambdaHack.Client.UI.SessionUI: [slastLost] :: SessionUI -> !(EnumSet ActorId)

+ Game.LambdaHack.Client.UI.SessionUI: [slastPlay] :: SessionUI -> ![KM]

+ Game.LambdaHack.Client.UI.SessionUI: [slastRecord] :: SessionUI -> !LastRecord

+ Game.LambdaHack.Client.UI.SessionUI: [slastSlot] :: SessionUI -> !SlotChar

+ Game.LambdaHack.Client.UI.SessionUI: [smarkSmell] :: SessionUI -> !Bool

+ Game.LambdaHack.Client.UI.SessionUI: [smarkVision] :: SessionUI -> !Bool

+ Game.LambdaHack.Client.UI.SessionUI: [smenuIxMap] :: SessionUI -> !(Map String Int)

+ Game.LambdaHack.Client.UI.SessionUI: [snframes] :: SessionUI -> !Int

+ Game.LambdaHack.Client.UI.SessionUI: [spointer] :: SessionUI -> !Point

+ Game.LambdaHack.Client.UI.SessionUI: [srunning] :: SessionUI -> !(Maybe RunParams)

+ Game.LambdaHack.Client.UI.SessionUI: [sselected] :: SessionUI -> !(EnumSet ActorId)

+ Game.LambdaHack.Client.UI.SessionUI: [sslots] :: SessionUI -> !ItemSlots

+ Game.LambdaHack.Client.UI.SessionUI: [sstart] :: SessionUI -> !POSIXTime

+ Game.LambdaHack.Client.UI.SessionUI: [swaitTimes] :: SessionUI -> !Int

+ Game.LambdaHack.Client.UI.SessionUI: [sxhairMoused] :: SessionUI -> !Bool

+ Game.LambdaHack.Client.UI.SessionUI: [sxhair] :: SessionUI -> !Target

+ Game.LambdaHack.Client.UI.SessionUI: data KeysHintMode

+ Game.LambdaHack.Client.UI.SessionUI: data RunParams

+ Game.LambdaHack.Client.UI.SessionUI: data SessionUI

+ Game.LambdaHack.Client.UI.SessionUI: emptySessionUI :: Config -> SessionUI

+ Game.LambdaHack.Client.UI.SessionUI: getActorUI :: ActorId -> SessionUI -> ActorUI

+ Game.LambdaHack.Client.UI.SessionUI: instance Data.Binary.Class.Binary Game.LambdaHack.Client.UI.SessionUI.AimMode

+ Game.LambdaHack.Client.UI.SessionUI: instance Data.Binary.Class.Binary Game.LambdaHack.Client.UI.SessionUI.RunParams

+ Game.LambdaHack.Client.UI.SessionUI: instance Data.Binary.Class.Binary Game.LambdaHack.Client.UI.SessionUI.SessionUI

+ Game.LambdaHack.Client.UI.SessionUI: instance GHC.Classes.Eq Game.LambdaHack.Client.UI.SessionUI.AimMode

+ Game.LambdaHack.Client.UI.SessionUI: instance GHC.Classes.Eq Game.LambdaHack.Client.UI.SessionUI.KeysHintMode

+ Game.LambdaHack.Client.UI.SessionUI: instance GHC.Enum.Bounded Game.LambdaHack.Client.UI.SessionUI.KeysHintMode

+ Game.LambdaHack.Client.UI.SessionUI: instance GHC.Enum.Enum Game.LambdaHack.Client.UI.SessionUI.KeysHintMode

+ Game.LambdaHack.Client.UI.SessionUI: instance GHC.Show.Show Game.LambdaHack.Client.UI.SessionUI.AimMode

+ Game.LambdaHack.Client.UI.SessionUI: instance GHC.Show.Show Game.LambdaHack.Client.UI.SessionUI.RunParams

+ Game.LambdaHack.Client.UI.SessionUI: newtype AimMode

+ Game.LambdaHack.Client.UI.SessionUI: toggleMarkSmell :: SessionUI -> SessionUI

+ Game.LambdaHack.Client.UI.SessionUI: toggleMarkVision :: SessionUI -> SessionUI

+ Game.LambdaHack.Client.UI.SessionUI: type LastRecord = ([KM], [KM], Int)

+ Game.LambdaHack.Client.UI.Slideshow: data Slideshow

+ Game.LambdaHack.Client.UI.Slideshow: emptySlideshow :: Slideshow

+ Game.LambdaHack.Client.UI.Slideshow: instance GHC.Classes.Eq Game.LambdaHack.Client.UI.Slideshow.Slideshow

+ Game.LambdaHack.Client.UI.Slideshow: instance GHC.Show.Show Game.LambdaHack.Client.UI.Slideshow.Slideshow

+ Game.LambdaHack.Client.UI.Slideshow: menuToSlideshow :: OKX -> Slideshow

+ Game.LambdaHack.Client.UI.Slideshow: splitOKX :: X -> Y -> AttrLine -> [KM] -> OKX -> [OKX]

+ Game.LambdaHack.Client.UI.Slideshow: splitOverlay :: X -> Y -> Report -> [KM] -> OKX -> Slideshow

+ Game.LambdaHack.Client.UI.Slideshow: toSlideshow :: [OKX] -> Slideshow

+ Game.LambdaHack.Client.UI.Slideshow: type KYX = (Either [KM] SlotChar, (Y, X, X))

+ Game.LambdaHack.Client.UI.Slideshow: type OKX = ([AttrLine], [KYX])

+ Game.LambdaHack.Client.UI.Slideshow: unsnoc :: Slideshow -> Maybe (Slideshow, OKX)

+ Game.LambdaHack.Client.UI.Slideshow: wrapOKX :: Y -> X -> X -> [(KM, String)] -> OKX

+ Game.LambdaHack.Client.UI.SlideshowM: displayChoiceScreen :: forall m. MonadClientUI m => ColorMode -> Bool -> Int -> Slideshow -> [KM] -> m (Either KM SlotChar, Int)

+ Game.LambdaHack.Client.UI.SlideshowM: displayMore :: MonadClientUI m => ColorMode -> Text -> m ()

+ Game.LambdaHack.Client.UI.SlideshowM: displayMoreKeep :: MonadClientUI m => ColorMode -> Text -> m ()

+ Game.LambdaHack.Client.UI.SlideshowM: displaySpaceEsc :: MonadClientUI m => ColorMode -> Text -> m Bool

+ Game.LambdaHack.Client.UI.SlideshowM: displayYesNo :: MonadClientUI m => ColorMode -> Text -> m Bool

+ Game.LambdaHack.Client.UI.SlideshowM: getConfirms :: MonadClientUI m => ColorMode -> [KM] -> Slideshow -> m KM

+ Game.LambdaHack.Client.UI.SlideshowM: overlayToSlideshow :: MonadClientUI m => Y -> [KM] -> OKX -> m Slideshow

+ Game.LambdaHack.Client.UI.SlideshowM: reportToSlideshow :: MonadClientUI m => [KM] -> m Slideshow

+ Game.LambdaHack.Client.UI.SlideshowM: reportToSlideshowKeep :: MonadClientUI m => [KM] -> m Slideshow

+ Game.LambdaHack.Common.Ability: instance Control.DeepSeq.NFData Game.LambdaHack.Common.Ability.Ability

+ Game.LambdaHack.Common.Ability: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Ability.Ability

+ Game.LambdaHack.Common.Ability: instance Data.Hashable.Class.Hashable Game.LambdaHack.Common.Ability.Ability

+ Game.LambdaHack.Common.Ability: instance GHC.Classes.Eq Game.LambdaHack.Common.Ability.Ability

+ Game.LambdaHack.Common.Ability: instance GHC.Classes.Ord Game.LambdaHack.Common.Ability.Ability

+ Game.LambdaHack.Common.Ability: instance GHC.Enum.Bounded Game.LambdaHack.Common.Ability.Ability

+ Game.LambdaHack.Common.Ability: instance GHC.Enum.Enum Game.LambdaHack.Common.Ability.Ability

+ Game.LambdaHack.Common.Ability: instance GHC.Generics.Generic Game.LambdaHack.Common.Ability.Ability

+ Game.LambdaHack.Common.Ability: instance GHC.Show.Show Game.LambdaHack.Common.Ability.Ability

+ Game.LambdaHack.Common.Ability: tacticSkills :: Tactic -> Skills

+ Game.LambdaHack.Common.Actor: [bcalmDelta] :: Actor -> !ResDelta

+ Game.LambdaHack.Common.Actor: [bcalm] :: Actor -> !Int64

+ Game.LambdaHack.Common.Actor: [beqp] :: Actor -> !ItemBag

+ Game.LambdaHack.Common.Actor: [bfid] :: Actor -> !FactionId

+ Game.LambdaHack.Common.Actor: [bhpDelta] :: Actor -> !ResDelta

+ Game.LambdaHack.Common.Actor: [bhp] :: Actor -> !Int64

+ Game.LambdaHack.Common.Actor: [binv] :: Actor -> !ItemBag

+ Game.LambdaHack.Common.Actor: [blid] :: Actor -> !LevelId

+ Game.LambdaHack.Common.Actor: [boldpos] :: Actor -> !(Maybe Point)

+ Game.LambdaHack.Common.Actor: [borgan] :: Actor -> !ItemBag

+ Game.LambdaHack.Common.Actor: [bpos] :: Actor -> !Point

+ Game.LambdaHack.Common.Actor: [bproj] :: Actor -> !Bool

+ Game.LambdaHack.Common.Actor: [btrajectory] :: Actor -> !(Maybe ([Vector], Speed))

+ Game.LambdaHack.Common.Actor: [btrunk] :: Actor -> !ItemId

+ Game.LambdaHack.Common.Actor: [bwait] :: Actor -> !Bool

+ Game.LambdaHack.Common.Actor: [bweapon] :: Actor -> !Int

+ Game.LambdaHack.Common.Actor: [resCurrentTurn] :: ResDelta -> !(Int64, Int64)

+ Game.LambdaHack.Common.Actor: [resPreviousTurn] :: ResDelta -> !(Int64, Int64)

+ Game.LambdaHack.Common.Actor: actorCanMelee :: ActorAspect -> ActorId -> Actor -> Bool

+ Game.LambdaHack.Common.Actor: eqpFreeN :: Actor -> Int

+ Game.LambdaHack.Common.Actor: eqpOverfull :: Actor -> Int -> Bool

+ Game.LambdaHack.Common.Actor: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Actor.Actor

+ Game.LambdaHack.Common.Actor: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Actor.ResDelta

+ Game.LambdaHack.Common.Actor: instance GHC.Classes.Eq Game.LambdaHack.Common.Actor.Actor

+ Game.LambdaHack.Common.Actor: instance GHC.Classes.Eq Game.LambdaHack.Common.Actor.ResDelta

+ Game.LambdaHack.Common.Actor: instance GHC.Generics.Generic Game.LambdaHack.Common.Actor.Actor

+ Game.LambdaHack.Common.Actor: instance GHC.Generics.Generic Game.LambdaHack.Common.Actor.ResDelta

+ Game.LambdaHack.Common.Actor: instance GHC.Show.Show Game.LambdaHack.Common.Actor.Actor

+ Game.LambdaHack.Common.Actor: instance GHC.Show.Show Game.LambdaHack.Common.Actor.ResDelta

+ Game.LambdaHack.Common.Actor: type ActorAspect = EnumMap ActorId AspectRecord

+ Game.LambdaHack.Common.ActorState: actorAdjacentAssocs :: Actor -> State -> [(ActorId, Actor)]

+ Game.LambdaHack.Common.ActorState: anyFoeAdj :: ActorId -> State -> Bool

+ Game.LambdaHack.Common.ActorState: armorHurtBonus :: ActorAspect -> ActorId -> ActorId -> State -> Int

+ Game.LambdaHack.Common.ActorState: canDeAmbientList :: Actor -> State -> [Point]

+ Game.LambdaHack.Common.ActorState: fidActorRegularIds :: FactionId -> LevelId -> State -> [ActorId]

+ Game.LambdaHack.Common.ActorState: friendlyActorRegularList :: FactionId -> LevelId -> State -> [Actor]

+ Game.LambdaHack.Common.ActorState: getBodyStoreBag :: Actor -> CStore -> State -> ItemBag

+ Game.LambdaHack.Common.ActorState: getContainerBag :: Container -> State -> ItemBag

+ Game.LambdaHack.Common.ActorState: getEmbedBag :: LevelId -> Point -> State -> ItemBag

+ Game.LambdaHack.Common.ActorState: getFloorBag :: LevelId -> Point -> State -> ItemBag

+ Game.LambdaHack.Common.ActorState: isEscape :: LevelId -> Point -> State -> Bool

+ Game.LambdaHack.Common.ActorState: isStair :: LevelId -> Point -> State -> Bool

+ Game.LambdaHack.Common.ActorState: posFromC :: Container -> State -> Point

+ Game.LambdaHack.Common.ActorState: posToAids :: Point -> LevelId -> State -> [ActorId]

+ Game.LambdaHack.Common.ActorState: posToAidsLvl :: Point -> Level -> [ActorId]

+ Game.LambdaHack.Common.ActorState: posToAssocs :: Point -> LevelId -> State -> [(ActorId, Actor)]

+ Game.LambdaHack.Common.ActorState: sharedEqp :: FactionId -> State -> ItemBag

+ Game.LambdaHack.Common.ActorState: warActorRegularList :: FactionId -> LevelId -> State -> [Actor]

+ Game.LambdaHack.Common.ClientOptions: [sbenchmark] :: DebugModeCli -> !Bool

+ Game.LambdaHack.Common.ClientOptions: [scolorIsBold] :: DebugModeCli -> !(Maybe Bool)

+ Game.LambdaHack.Common.ClientOptions: [sdbgMsgCli] :: DebugModeCli -> !Bool

+ Game.LambdaHack.Common.ClientOptions: [sdisableAutoYes] :: DebugModeCli -> !Bool

+ Game.LambdaHack.Common.ClientOptions: [sdlFonSizeAdd] :: DebugModeCli -> !(Maybe Int)

+ Game.LambdaHack.Common.ClientOptions: [sdlFontFile] :: DebugModeCli -> !(Maybe Text)

+ Game.LambdaHack.Common.ClientOptions: [sdlTtfSizeAdd] :: DebugModeCli -> !(Maybe Int)

+ Game.LambdaHack.Common.ClientOptions: [sfontSize] :: DebugModeCli -> !(Maybe Int)

+ Game.LambdaHack.Common.ClientOptions: [sfrontendLazy] :: DebugModeCli -> !Bool

+ Game.LambdaHack.Common.ClientOptions: [sfrontendNull] :: DebugModeCli -> !Bool

+ Game.LambdaHack.Common.ClientOptions: [sfrontendTeletype] :: DebugModeCli -> !Bool

+ Game.LambdaHack.Common.ClientOptions: [sgtkFontFamily] :: DebugModeCli -> !(Maybe Text)

+ Game.LambdaHack.Common.ClientOptions: [smaxFps] :: DebugModeCli -> !(Maybe Int)

+ Game.LambdaHack.Common.ClientOptions: [snewGameCli] :: DebugModeCli -> !Bool

+ Game.LambdaHack.Common.ClientOptions: [snoAnim] :: DebugModeCli -> !(Maybe Bool)

+ Game.LambdaHack.Common.ClientOptions: [ssavePrefixCli] :: DebugModeCli -> !String

+ Game.LambdaHack.Common.ClientOptions: [sstopAfterFrames] :: DebugModeCli -> !(Maybe Int)

+ Game.LambdaHack.Common.ClientOptions: [sstopAfterSeconds] :: DebugModeCli -> !(Maybe Int)

+ Game.LambdaHack.Common.ClientOptions: [stitle] :: DebugModeCli -> !(Maybe Text)

+ Game.LambdaHack.Common.ClientOptions: instance Data.Binary.Class.Binary Game.LambdaHack.Common.ClientOptions.DebugModeCli

+ Game.LambdaHack.Common.ClientOptions: instance GHC.Classes.Eq Game.LambdaHack.Common.ClientOptions.DebugModeCli

+ Game.LambdaHack.Common.ClientOptions: instance GHC.Generics.Generic Game.LambdaHack.Common.ClientOptions.DebugModeCli

+ Game.LambdaHack.Common.ClientOptions: instance GHC.Show.Show Game.LambdaHack.Common.ClientOptions.DebugModeCli

+ Game.LambdaHack.Common.Color: AttrCharW32 :: Word32 -> AttrCharW32

+ Game.LambdaHack.Common.Color: HighlightBlue :: Highlight

+ Game.LambdaHack.Common.Color: HighlightGrey :: Highlight

+ Game.LambdaHack.Common.Color: HighlightNone :: Highlight

+ Game.LambdaHack.Common.Color: HighlightRed :: Highlight

+ Game.LambdaHack.Common.Color: HighlightYellow :: Highlight

+ Game.LambdaHack.Common.Color: [acAttr] :: AttrChar -> !Attr

+ Game.LambdaHack.Common.Color: [acChar] :: AttrChar -> !Char

+ Game.LambdaHack.Common.Color: [attrCharW32] :: AttrCharW32 -> Word32

+ Game.LambdaHack.Common.Color: [bg] :: Attr -> !Highlight

+ Game.LambdaHack.Common.Color: [fg] :: Attr -> !Color

+ Game.LambdaHack.Common.Color: attrChar1ToW32 :: Char -> AttrCharW32

+ Game.LambdaHack.Common.Color: attrChar2ToW32 :: Color -> Char -> AttrCharW32

+ Game.LambdaHack.Common.Color: attrCharFromW32 :: AttrCharW32 -> AttrChar

+ Game.LambdaHack.Common.Color: attrCharToW32 :: AttrChar -> AttrCharW32

+ Game.LambdaHack.Common.Color: attrEnumFromW32 :: AttrCharW32 -> Int

+ Game.LambdaHack.Common.Color: attrFromW32 :: AttrCharW32 -> Attr

+ Game.LambdaHack.Common.Color: bgFromW32 :: AttrCharW32 -> Highlight

+ Game.LambdaHack.Common.Color: charFromW32 :: AttrCharW32 -> Char

+ Game.LambdaHack.Common.Color: data Highlight

+ Game.LambdaHack.Common.Color: fgFromW32 :: AttrCharW32 -> Color

+ Game.LambdaHack.Common.Color: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Color.AttrCharW32

+ Game.LambdaHack.Common.Color: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Color.Color

+ Game.LambdaHack.Common.Color: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Color.Highlight

+ Game.LambdaHack.Common.Color: instance Data.Hashable.Class.Hashable Game.LambdaHack.Common.Color.Color

+ Game.LambdaHack.Common.Color: instance Data.Hashable.Class.Hashable Game.LambdaHack.Common.Color.Highlight

+ Game.LambdaHack.Common.Color: instance GHC.Classes.Eq Game.LambdaHack.Common.Color.Attr

+ Game.LambdaHack.Common.Color: instance GHC.Classes.Eq Game.LambdaHack.Common.Color.AttrChar

+ Game.LambdaHack.Common.Color: instance GHC.Classes.Eq Game.LambdaHack.Common.Color.AttrCharW32

+ Game.LambdaHack.Common.Color: instance GHC.Classes.Eq Game.LambdaHack.Common.Color.Color

+ Game.LambdaHack.Common.Color: instance GHC.Classes.Eq Game.LambdaHack.Common.Color.Highlight

+ Game.LambdaHack.Common.Color: instance GHC.Classes.Ord Game.LambdaHack.Common.Color.Attr

+ Game.LambdaHack.Common.Color: instance GHC.Classes.Ord Game.LambdaHack.Common.Color.AttrChar

+ Game.LambdaHack.Common.Color: instance GHC.Classes.Ord Game.LambdaHack.Common.Color.Color

+ Game.LambdaHack.Common.Color: instance GHC.Classes.Ord Game.LambdaHack.Common.Color.Highlight

+ Game.LambdaHack.Common.Color: instance GHC.Enum.Bounded Game.LambdaHack.Common.Color.Color

+ Game.LambdaHack.Common.Color: instance GHC.Enum.Bounded Game.LambdaHack.Common.Color.Highlight

+ Game.LambdaHack.Common.Color: instance GHC.Enum.Enum Game.LambdaHack.Common.Color.Attr

+ Game.LambdaHack.Common.Color: instance GHC.Enum.Enum Game.LambdaHack.Common.Color.AttrCharW32

+ Game.LambdaHack.Common.Color: instance GHC.Enum.Enum Game.LambdaHack.Common.Color.Color

+ Game.LambdaHack.Common.Color: instance GHC.Enum.Enum Game.LambdaHack.Common.Color.Highlight

+ Game.LambdaHack.Common.Color: instance GHC.Generics.Generic Game.LambdaHack.Common.Color.Color

+ Game.LambdaHack.Common.Color: instance GHC.Generics.Generic Game.LambdaHack.Common.Color.Highlight

+ Game.LambdaHack.Common.Color: instance GHC.Show.Show Game.LambdaHack.Common.Color.Attr

+ Game.LambdaHack.Common.Color: instance GHC.Show.Show Game.LambdaHack.Common.Color.AttrChar

+ Game.LambdaHack.Common.Color: instance GHC.Show.Show Game.LambdaHack.Common.Color.AttrCharW32

+ Game.LambdaHack.Common.Color: instance GHC.Show.Show Game.LambdaHack.Common.Color.Color

+ Game.LambdaHack.Common.Color: instance GHC.Show.Show Game.LambdaHack.Common.Color.Highlight

+ Game.LambdaHack.Common.Color: newtype AttrCharW32

+ Game.LambdaHack.Common.Color: retAttrW32 :: AttrCharW32

+ Game.LambdaHack.Common.Color: spaceAttrW32 :: AttrCharW32

+ Game.LambdaHack.Common.ContentDef: [content] :: ContentDef a -> !(Vector a)

+ Game.LambdaHack.Common.ContentDef: [getFreq] :: ContentDef a -> !(a -> Freqs a)

+ Game.LambdaHack.Common.ContentDef: [getName] :: ContentDef a -> !(a -> Text)

+ Game.LambdaHack.Common.ContentDef: [getSymbol] :: ContentDef a -> !(a -> Char)

+ Game.LambdaHack.Common.ContentDef: [validateAll] :: ContentDef a -> !([a] -> [Text])

+ Game.LambdaHack.Common.ContentDef: [validateSingle] :: ContentDef a -> !(a -> [Text])

+ Game.LambdaHack.Common.ContentDef: contentFromList :: [a] -> Vector a

+ Game.LambdaHack.Common.Dice: infixl 5 |*|

+ Game.LambdaHack.Common.Dice: instance Control.DeepSeq.NFData Game.LambdaHack.Common.Dice.Dice

+ Game.LambdaHack.Common.Dice: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Dice.Dice

+ Game.LambdaHack.Common.Dice: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Dice.DiceXY

+ Game.LambdaHack.Common.Dice: instance Data.Hashable.Class.Hashable Game.LambdaHack.Common.Dice.Dice

+ Game.LambdaHack.Common.Dice: instance Data.Hashable.Class.Hashable Game.LambdaHack.Common.Dice.DiceXY

+ Game.LambdaHack.Common.Dice: instance GHC.Classes.Eq Game.LambdaHack.Common.Dice.Dice

+ Game.LambdaHack.Common.Dice: instance GHC.Classes.Eq Game.LambdaHack.Common.Dice.DiceXY

+ Game.LambdaHack.Common.Dice: instance GHC.Classes.Ord Game.LambdaHack.Common.Dice.Dice

+ Game.LambdaHack.Common.Dice: instance GHC.Classes.Ord Game.LambdaHack.Common.Dice.DiceXY

+ Game.LambdaHack.Common.Dice: instance GHC.Generics.Generic Game.LambdaHack.Common.Dice.Dice

+ Game.LambdaHack.Common.Dice: instance GHC.Generics.Generic Game.LambdaHack.Common.Dice.DiceXY

+ Game.LambdaHack.Common.Dice: instance GHC.Num.Num Game.LambdaHack.Common.Dice.Dice

+ Game.LambdaHack.Common.Dice: instance GHC.Num.Num Game.LambdaHack.Common.Dice.SimpleDice

+ Game.LambdaHack.Common.Dice: instance GHC.Show.Show Game.LambdaHack.Common.Dice.Dice

+ Game.LambdaHack.Common.Dice: instance GHC.Show.Show Game.LambdaHack.Common.Dice.DiceXY

+ Game.LambdaHack.Common.Faction: Challenge :: !Int -> !Bool -> !Bool -> Challenge

+ Game.LambdaHack.Common.Faction: TAny :: TGoal

+ Game.LambdaHack.Common.Faction: TEmbed :: !ItemBag -> !Point -> TGoal

+ Game.LambdaHack.Common.Faction: TItem :: !ItemBag -> TGoal

+ Game.LambdaHack.Common.Faction: TKnown :: TGoal

+ Game.LambdaHack.Common.Faction: TSmell :: TGoal

+ Game.LambdaHack.Common.Faction: TUnknown :: TGoal

+ Game.LambdaHack.Common.Faction: [_gleader] :: Faction -> !(Maybe ActorId)

+ Game.LambdaHack.Common.Faction: [cdiff] :: Challenge -> !Int

+ Game.LambdaHack.Common.Faction: [cfish] :: Challenge -> !Bool

+ Game.LambdaHack.Common.Faction: [cwolf] :: Challenge -> !Bool

+ Game.LambdaHack.Common.Faction: [gcolor] :: Faction -> !Color

+ Game.LambdaHack.Common.Faction: [gdipl] :: Faction -> !Dipl

+ Game.LambdaHack.Common.Faction: [ginitial] :: Faction -> ![(Int, Int, GroupName ItemKind)]

+ Game.LambdaHack.Common.Faction: [gname] :: Faction -> !Text

+ Game.LambdaHack.Common.Faction: [gplayer] :: Faction -> !Player

+ Game.LambdaHack.Common.Faction: [gquit] :: Faction -> !(Maybe Status)

+ Game.LambdaHack.Common.Faction: [gsha] :: Faction -> !ItemBag

+ Game.LambdaHack.Common.Faction: [gvictimsD] :: Faction -> !(EnumMap (Id ModeKind) (IntMap (EnumMap (Id ItemKind) Int)))

+ Game.LambdaHack.Common.Faction: [gvictims] :: Faction -> !(EnumMap (Id ItemKind) Int)

+ Game.LambdaHack.Common.Faction: [stDepth] :: Status -> !Int

+ Game.LambdaHack.Common.Faction: [stNewGame] :: Status -> !(Maybe (GroupName ModeKind))

+ Game.LambdaHack.Common.Faction: [stOutcome] :: Status -> !Outcome

+ Game.LambdaHack.Common.Faction: data Challenge

+ Game.LambdaHack.Common.Faction: data TGoal

+ Game.LambdaHack.Common.Faction: defaultChallenge :: Challenge

+ Game.LambdaHack.Common.Faction: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Faction.Challenge

+ Game.LambdaHack.Common.Faction: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Faction.Diplomacy

+ Game.LambdaHack.Common.Faction: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Faction.Faction

+ Game.LambdaHack.Common.Faction: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Faction.Status

+ Game.LambdaHack.Common.Faction: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Faction.TGoal

+ Game.LambdaHack.Common.Faction: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Faction.Target

+ Game.LambdaHack.Common.Faction: instance GHC.Classes.Eq Game.LambdaHack.Common.Faction.Challenge

+ Game.LambdaHack.Common.Faction: instance GHC.Classes.Eq Game.LambdaHack.Common.Faction.Diplomacy

+ Game.LambdaHack.Common.Faction: instance GHC.Classes.Eq Game.LambdaHack.Common.Faction.Faction

+ Game.LambdaHack.Common.Faction: instance GHC.Classes.Eq Game.LambdaHack.Common.Faction.Status

+ Game.LambdaHack.Common.Faction: instance GHC.Classes.Eq Game.LambdaHack.Common.Faction.TGoal

+ Game.LambdaHack.Common.Faction: instance GHC.Classes.Eq Game.LambdaHack.Common.Faction.Target

+ Game.LambdaHack.Common.Faction: instance GHC.Classes.Ord Game.LambdaHack.Common.Faction.Challenge

+ Game.LambdaHack.Common.Faction: instance GHC.Classes.Ord Game.LambdaHack.Common.Faction.Diplomacy

+ Game.LambdaHack.Common.Faction: instance GHC.Classes.Ord Game.LambdaHack.Common.Faction.Faction

+ Game.LambdaHack.Common.Faction: instance GHC.Classes.Ord Game.LambdaHack.Common.Faction.Status

+ Game.LambdaHack.Common.Faction: instance GHC.Classes.Ord Game.LambdaHack.Common.Faction.TGoal

+ Game.LambdaHack.Common.Faction: instance GHC.Classes.Ord Game.LambdaHack.Common.Faction.Target

+ Game.LambdaHack.Common.Faction: instance GHC.Enum.Enum Game.LambdaHack.Common.Faction.Diplomacy

+ Game.LambdaHack.Common.Faction: instance GHC.Generics.Generic Game.LambdaHack.Common.Faction.Challenge

+ Game.LambdaHack.Common.Faction: instance GHC.Generics.Generic Game.LambdaHack.Common.Faction.Diplomacy

+ Game.LambdaHack.Common.Faction: instance GHC.Generics.Generic Game.LambdaHack.Common.Faction.Faction

+ Game.LambdaHack.Common.Faction: instance GHC.Generics.Generic Game.LambdaHack.Common.Faction.Status

+ Game.LambdaHack.Common.Faction: instance GHC.Generics.Generic Game.LambdaHack.Common.Faction.TGoal

+ Game.LambdaHack.Common.Faction: instance GHC.Generics.Generic Game.LambdaHack.Common.Faction.Target

+ Game.LambdaHack.Common.Faction: instance GHC.Show.Show Game.LambdaHack.Common.Faction.Challenge

+ Game.LambdaHack.Common.Faction: instance GHC.Show.Show Game.LambdaHack.Common.Faction.Diplomacy

+ Game.LambdaHack.Common.Faction: instance GHC.Show.Show Game.LambdaHack.Common.Faction.Faction

+ Game.LambdaHack.Common.Faction: instance GHC.Show.Show Game.LambdaHack.Common.Faction.Status

+ Game.LambdaHack.Common.Faction: instance GHC.Show.Show Game.LambdaHack.Common.Faction.TGoal

+ Game.LambdaHack.Common.Faction: instance GHC.Show.Show Game.LambdaHack.Common.Faction.Target

+ Game.LambdaHack.Common.Faction: nameOfHorrorFact :: GroupName ItemKind

+ Game.LambdaHack.Common.Faction: tgtKindDescription :: Target -> Text

+ Game.LambdaHack.Common.File: doesFileExist :: FilePath -> IO Bool

+ Game.LambdaHack.Common.File: readFile :: FilePath -> IO String

+ Game.LambdaHack.Common.File: renameFile :: FilePath -> FilePath -> IO ()

+ Game.LambdaHack.Common.File: tryWriteFile :: FilePath -> String -> IO ()

+ Game.LambdaHack.Common.Flavour: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Flavour.FancyName

+ Game.LambdaHack.Common.Flavour: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Flavour.Flavour

+ Game.LambdaHack.Common.Flavour: instance Data.Hashable.Class.Hashable Game.LambdaHack.Common.Flavour.FancyName

+ Game.LambdaHack.Common.Flavour: instance Data.Hashable.Class.Hashable Game.LambdaHack.Common.Flavour.Flavour

+ Game.LambdaHack.Common.Flavour: instance GHC.Classes.Eq Game.LambdaHack.Common.Flavour.FancyName

+ Game.LambdaHack.Common.Flavour: instance GHC.Classes.Eq Game.LambdaHack.Common.Flavour.Flavour

+ Game.LambdaHack.Common.Flavour: instance GHC.Classes.Ord Game.LambdaHack.Common.Flavour.FancyName

+ Game.LambdaHack.Common.Flavour: instance GHC.Classes.Ord Game.LambdaHack.Common.Flavour.Flavour

+ Game.LambdaHack.Common.Flavour: instance GHC.Generics.Generic Game.LambdaHack.Common.Flavour.FancyName

+ Game.LambdaHack.Common.Flavour: instance GHC.Generics.Generic Game.LambdaHack.Common.Flavour.Flavour

+ Game.LambdaHack.Common.Flavour: instance GHC.Show.Show Game.LambdaHack.Common.Flavour.FancyName

+ Game.LambdaHack.Common.Flavour: instance GHC.Show.Show Game.LambdaHack.Common.Flavour.Flavour

+ Game.LambdaHack.Common.Frequency: instance Control.DeepSeq.NFData a => Control.DeepSeq.NFData (Game.LambdaHack.Common.Frequency.Frequency a)

+ Game.LambdaHack.Common.Frequency: instance Data.Binary.Class.Binary a => Data.Binary.Class.Binary (Game.LambdaHack.Common.Frequency.Frequency a)

+ Game.LambdaHack.Common.Frequency: instance Data.Foldable.Foldable Game.LambdaHack.Common.Frequency.Frequency

+ Game.LambdaHack.Common.Frequency: instance Data.Hashable.Class.Hashable a => Data.Hashable.Class.Hashable (Game.LambdaHack.Common.Frequency.Frequency a)

+ Game.LambdaHack.Common.Frequency: instance Data.Traversable.Traversable Game.LambdaHack.Common.Frequency.Frequency

+ Game.LambdaHack.Common.Frequency: instance GHC.Base.Alternative Game.LambdaHack.Common.Frequency.Frequency

+ Game.LambdaHack.Common.Frequency: instance GHC.Base.Applicative Game.LambdaHack.Common.Frequency.Frequency

+ Game.LambdaHack.Common.Frequency: instance GHC.Base.Functor Game.LambdaHack.Common.Frequency.Frequency

+ Game.LambdaHack.Common.Frequency: instance GHC.Base.Monad Game.LambdaHack.Common.Frequency.Frequency

+ Game.LambdaHack.Common.Frequency: instance GHC.Base.MonadPlus Game.LambdaHack.Common.Frequency.Frequency

+ Game.LambdaHack.Common.Frequency: instance GHC.Classes.Eq a => GHC.Classes.Eq (Game.LambdaHack.Common.Frequency.Frequency a)

+ Game.LambdaHack.Common.Frequency: instance GHC.Classes.Ord a => GHC.Classes.Ord (Game.LambdaHack.Common.Frequency.Frequency a)

+ Game.LambdaHack.Common.Frequency: instance GHC.Generics.Generic (Game.LambdaHack.Common.Frequency.Frequency a)

+ Game.LambdaHack.Common.Frequency: instance GHC.Show.Show a => GHC.Show.Show (Game.LambdaHack.Common.Frequency.Frequency a)

+ Game.LambdaHack.Common.Frequency: mostFreq :: Frequency a -> Maybe a

+ Game.LambdaHack.Common.HighScore: instance Data.Binary.Class.Binary Game.LambdaHack.Common.HighScore.ScoreRecord

+ Game.LambdaHack.Common.HighScore: instance Data.Binary.Class.Binary Game.LambdaHack.Common.HighScore.ScoreTable

+ Game.LambdaHack.Common.HighScore: instance GHC.Classes.Eq Game.LambdaHack.Common.HighScore.ScoreRecord

+ Game.LambdaHack.Common.HighScore: instance GHC.Classes.Eq Game.LambdaHack.Common.HighScore.ScoreTable

+ Game.LambdaHack.Common.HighScore: instance GHC.Classes.Ord Game.LambdaHack.Common.HighScore.ScoreRecord

+ Game.LambdaHack.Common.HighScore: instance GHC.Generics.Generic Game.LambdaHack.Common.HighScore.ScoreRecord

+ Game.LambdaHack.Common.HighScore: instance GHC.Show.Show Game.LambdaHack.Common.HighScore.ScoreRecord

+ Game.LambdaHack.Common.HighScore: instance GHC.Show.Show Game.LambdaHack.Common.HighScore.ScoreTable

+ Game.LambdaHack.Common.Item: AspectRecord :: !Int -> !Int -> !Int -> !Int -> !Int -> !Int -> !Int -> !Int -> !Int -> !Int -> !Int -> !Int -> !Skills -> AspectRecord

+ Game.LambdaHack.Common.Item: Benefit :: Bool -> Int -> Int -> Int -> Int -> Benefit

+ Game.LambdaHack.Common.Item: ItemSourceFaction :: !FactionId -> ItemSource

+ Game.LambdaHack.Common.Item: ItemSourceLevel :: !LevelId -> ItemSource

+ Game.LambdaHack.Common.Item: KindMean :: !(Id ItemKind) -> !AspectRecord -> KindMean

+ Game.LambdaHack.Common.Item: [aAggression] :: AspectRecord -> !Int

+ Game.LambdaHack.Common.Item: [aArmorMelee] :: AspectRecord -> !Int

+ Game.LambdaHack.Common.Item: [aArmorRanged] :: AspectRecord -> !Int

+ Game.LambdaHack.Common.Item: [aHurtMelee] :: AspectRecord -> !Int

+ Game.LambdaHack.Common.Item: [aMaxCalm] :: AspectRecord -> !Int

+ Game.LambdaHack.Common.Item: [aMaxHP] :: AspectRecord -> !Int

+ Game.LambdaHack.Common.Item: [aNocto] :: AspectRecord -> !Int

+ Game.LambdaHack.Common.Item: [aShine] :: AspectRecord -> !Int

+ Game.LambdaHack.Common.Item: [aSight] :: AspectRecord -> !Int

+ Game.LambdaHack.Common.Item: [aSkills] :: AspectRecord -> !Skills

+ Game.LambdaHack.Common.Item: [aSmell] :: AspectRecord -> !Int

+ Game.LambdaHack.Common.Item: [aSpeed] :: AspectRecord -> !Int

+ Game.LambdaHack.Common.Item: [aTimeout] :: AspectRecord -> !Int

+ Game.LambdaHack.Common.Item: [benApply] :: Benefit -> Int

+ Game.LambdaHack.Common.Item: [benFling] :: Benefit -> Int

+ Game.LambdaHack.Common.Item: [benInEqp] :: Benefit -> Bool

+ Game.LambdaHack.Common.Item: [benMelee] :: Benefit -> Int

+ Game.LambdaHack.Common.Item: [benPickup] :: Benefit -> Int

+ Game.LambdaHack.Common.Item: [itemAspectMean] :: ItemDisco -> !AspectRecord

+ Game.LambdaHack.Common.Item: [itemAspect] :: ItemDisco -> !(Maybe AspectRecord)

+ Game.LambdaHack.Common.Item: [itemBase] :: ItemFull -> !Item

+ Game.LambdaHack.Common.Item: [itemDisco] :: ItemFull -> !(Maybe ItemDisco)

+ Game.LambdaHack.Common.Item: [itemK] :: ItemFull -> !Int

+ Game.LambdaHack.Common.Item: [itemKindId] :: ItemDisco -> !(Id ItemKind)

+ Game.LambdaHack.Common.Item: [itemKind] :: ItemDisco -> !ItemKind

+ Game.LambdaHack.Common.Item: [itemTimer] :: ItemFull -> !ItemTimer

+ Game.LambdaHack.Common.Item: [jdamage] :: Item -> !Dice

+ Game.LambdaHack.Common.Item: [jfeature] :: Item -> ![Feature]

+ Game.LambdaHack.Common.Item: [jfid] :: Item -> !(Maybe FactionId)

+ Game.LambdaHack.Common.Item: [jflavour] :: Item -> !Flavour

+ Game.LambdaHack.Common.Item: [jkindIx] :: Item -> !ItemKindIx

+ Game.LambdaHack.Common.Item: [jlid] :: Item -> !LevelId

+ Game.LambdaHack.Common.Item: [jname] :: Item -> !Text

+ Game.LambdaHack.Common.Item: [jsymbol] :: Item -> !Char

+ Game.LambdaHack.Common.Item: [jweight] :: Item -> !Int

+ Game.LambdaHack.Common.Item: [kmKind] :: KindMean -> !(Id ItemKind)

+ Game.LambdaHack.Common.Item: [kmMean] :: KindMean -> !AspectRecord

+ Game.LambdaHack.Common.Item: aspectRecordFull :: ItemFull -> AspectRecord

+ Game.LambdaHack.Common.Item: aspectRecordToList :: AspectRecord -> [Aspect]

+ Game.LambdaHack.Common.Item: aspectsRandom :: ItemKind -> Bool

+ Game.LambdaHack.Common.Item: data AspectRecord

+ Game.LambdaHack.Common.Item: data Benefit

+ Game.LambdaHack.Common.Item: data ItemSource

+ Game.LambdaHack.Common.Item: data KindMean

+ Game.LambdaHack.Common.Item: emptyAspectRecord :: AspectRecord

+ Game.LambdaHack.Common.Item: goesIntoEqp :: Item -> Bool

+ Game.LambdaHack.Common.Item: goesIntoInv :: Item -> Bool

+ Game.LambdaHack.Common.Item: goesIntoSha :: Item -> Bool

+ Game.LambdaHack.Common.Item: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Item.AspectRecord

+ Game.LambdaHack.Common.Item: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Item.Benefit

+ Game.LambdaHack.Common.Item: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Item.Item

+ Game.LambdaHack.Common.Item: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Item.ItemId

+ Game.LambdaHack.Common.Item: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Item.ItemKindIx

+ Game.LambdaHack.Common.Item: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Item.ItemSeed

+ Game.LambdaHack.Common.Item: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Item.ItemSource

+ Game.LambdaHack.Common.Item: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Item.KindMean

+ Game.LambdaHack.Common.Item: instance Data.Hashable.Class.Hashable Game.LambdaHack.Common.Item.AspectRecord

+ Game.LambdaHack.Common.Item: instance Data.Hashable.Class.Hashable Game.LambdaHack.Common.Item.Item

+ Game.LambdaHack.Common.Item: instance Data.Hashable.Class.Hashable Game.LambdaHack.Common.Item.ItemKindIx

+ Game.LambdaHack.Common.Item: instance Data.Hashable.Class.Hashable Game.LambdaHack.Common.Item.ItemSeed

+ Game.LambdaHack.Common.Item: instance Data.Hashable.Class.Hashable Game.LambdaHack.Common.Item.ItemSource

+ Game.LambdaHack.Common.Item: instance GHC.Arr.Ix Game.LambdaHack.Common.Item.ItemKindIx

+ Game.LambdaHack.Common.Item: instance GHC.Classes.Eq Game.LambdaHack.Common.Item.AspectRecord

+ Game.LambdaHack.Common.Item: instance GHC.Classes.Eq Game.LambdaHack.Common.Item.Item

+ Game.LambdaHack.Common.Item: instance GHC.Classes.Eq Game.LambdaHack.Common.Item.ItemId

+ Game.LambdaHack.Common.Item: instance GHC.Classes.Eq Game.LambdaHack.Common.Item.ItemKindIx

+ Game.LambdaHack.Common.Item: instance GHC.Classes.Eq Game.LambdaHack.Common.Item.ItemSeed

+ Game.LambdaHack.Common.Item: instance GHC.Classes.Eq Game.LambdaHack.Common.Item.ItemSource

+ Game.LambdaHack.Common.Item: instance GHC.Classes.Eq Game.LambdaHack.Common.Item.KindMean

+ Game.LambdaHack.Common.Item: instance GHC.Classes.Ord Game.LambdaHack.Common.Item.AspectRecord

+ Game.LambdaHack.Common.Item: instance GHC.Classes.Ord Game.LambdaHack.Common.Item.ItemId

+ Game.LambdaHack.Common.Item: instance GHC.Classes.Ord Game.LambdaHack.Common.Item.ItemKindIx

+ Game.LambdaHack.Common.Item: instance GHC.Classes.Ord Game.LambdaHack.Common.Item.ItemSeed

+ Game.LambdaHack.Common.Item: instance GHC.Enum.Enum Game.LambdaHack.Common.Item.ItemId

+ Game.LambdaHack.Common.Item: instance GHC.Enum.Enum Game.LambdaHack.Common.Item.ItemKindIx

+ Game.LambdaHack.Common.Item: instance GHC.Enum.Enum Game.LambdaHack.Common.Item.ItemSeed

+ Game.LambdaHack.Common.Item: instance GHC.Generics.Generic Game.LambdaHack.Common.Item.AspectRecord

+ Game.LambdaHack.Common.Item: instance GHC.Generics.Generic Game.LambdaHack.Common.Item.Benefit

+ Game.LambdaHack.Common.Item: instance GHC.Generics.Generic Game.LambdaHack.Common.Item.Item

+ Game.LambdaHack.Common.Item: instance GHC.Generics.Generic Game.LambdaHack.Common.Item.ItemSource

+ Game.LambdaHack.Common.Item: instance GHC.Generics.Generic Game.LambdaHack.Common.Item.KindMean

+ Game.LambdaHack.Common.Item: instance GHC.Show.Show Game.LambdaHack.Common.Item.AspectRecord

+ Game.LambdaHack.Common.Item: instance GHC.Show.Show Game.LambdaHack.Common.Item.Benefit

+ Game.LambdaHack.Common.Item: instance GHC.Show.Show Game.LambdaHack.Common.Item.Item

+ Game.LambdaHack.Common.Item: instance GHC.Show.Show Game.LambdaHack.Common.Item.ItemDisco

+ Game.LambdaHack.Common.Item: instance GHC.Show.Show Game.LambdaHack.Common.Item.ItemFull

+ Game.LambdaHack.Common.Item: instance GHC.Show.Show Game.LambdaHack.Common.Item.ItemId

+ Game.LambdaHack.Common.Item: instance GHC.Show.Show Game.LambdaHack.Common.Item.ItemKindIx

+ Game.LambdaHack.Common.Item: instance GHC.Show.Show Game.LambdaHack.Common.Item.ItemSeed

+ Game.LambdaHack.Common.Item: instance GHC.Show.Show Game.LambdaHack.Common.Item.ItemSource

+ Game.LambdaHack.Common.Item: instance GHC.Show.Show Game.LambdaHack.Common.Item.KindMean

+ Game.LambdaHack.Common.Item: isMelee :: Item -> Bool

+ Game.LambdaHack.Common.Item: itemPrice :: (Item, Int) -> Int

+ Game.LambdaHack.Common.Item: itemToFull :: COps -> DiscoveryKind -> DiscoveryAspect -> ItemId -> Item -> ItemQuant -> ItemFull

+ Game.LambdaHack.Common.Item: meanAspect :: ItemKind -> AspectRecord

+ Game.LambdaHack.Common.Item: seedToAspect :: ItemSeed -> ItemKind -> AbsDepth -> AbsDepth -> AspectRecord

+ Game.LambdaHack.Common.Item: sumAspectRecord :: [(AspectRecord, Int)] -> AspectRecord

+ Game.LambdaHack.Common.Item: type DiscoveryAspect = EnumMap ItemId AspectRecord

+ Game.LambdaHack.Common.Item: type DiscoveryBenefit = EnumMap ItemId Benefit

+ Game.LambdaHack.Common.ItemStrongest: damageUsefulness :: Item -> Int

+ Game.LambdaHack.Common.ItemStrongest: filterRecharging :: [Effect] -> [Effect]

+ Game.LambdaHack.Common.ItemStrongest: hasCharge :: Time -> ItemFull -> Bool

+ Game.LambdaHack.Common.ItemStrongest: prEqpSlot :: EqpSlot -> AspectRecord -> Int

+ Game.LambdaHack.Common.ItemStrongest: strongestMelee :: Maybe DiscoveryBenefit -> Time -> [(ItemId, ItemFull)] -> [(Int, (ItemId, ItemFull))]

+ Game.LambdaHack.Common.Kind: [coTileSpeedup] :: COps -> !TileSpeedup

+ Game.LambdaHack.Common.Kind: [cocave] :: COps -> !(Ops CaveKind)

+ Game.LambdaHack.Common.Kind: [coitem] :: COps -> !(Ops ItemKind)

+ Game.LambdaHack.Common.Kind: [comode] :: COps -> !(Ops ModeKind)

+ Game.LambdaHack.Common.Kind: [coplace] :: COps -> !(Ops PlaceKind)

+ Game.LambdaHack.Common.Kind: [corule] :: COps -> !(Ops RuleKind)

+ Game.LambdaHack.Common.Kind: [cotile] :: COps -> !(Ops TileKind)

+ Game.LambdaHack.Common.Kind: [ofoldlGroup'] :: Ops a -> !(forall b. GroupName a -> (b -> Int -> Id a -> a -> b) -> b -> b)

+ Game.LambdaHack.Common.Kind: [ofoldlWithKey'] :: Ops a -> !(forall b. (b -> Id a -> a -> b) -> b -> b)

+ Game.LambdaHack.Common.Kind: [ofoldrWithKey] :: Ops a -> !(forall b. (Id a -> a -> b -> b) -> b -> b)

+ Game.LambdaHack.Common.Kind: [okind] :: Ops a -> !(Id a -> a)

+ Game.LambdaHack.Common.Kind: [olength] :: Ops a -> !Int

+ Game.LambdaHack.Common.Kind: [opick] :: Ops a -> !(GroupName a -> (a -> Bool) -> Rnd (Maybe (Id a)))

+ Game.LambdaHack.Common.Kind: [ouniqGroup] :: Ops a -> !(GroupName a -> Id a)

+ Game.LambdaHack.Common.Kind: instance GHC.Classes.Eq Game.LambdaHack.Common.Kind.COps

+ Game.LambdaHack.Common.Kind: instance GHC.Show.Show Game.LambdaHack.Common.Kind.COps

+ Game.LambdaHack.Common.KindOps: Id :: Word16 -> Id c

+ Game.LambdaHack.Common.KindOps: Ops :: !(Id a -> a) -> !(GroupName a -> Id a) -> !(GroupName a -> (a -> Bool) -> Rnd (Maybe (Id a))) -> !(forall b. (Id a -> a -> b -> b) -> b -> b) -> !(forall b. (b -> Id a -> a -> b) -> b -> b) -> !(forall b. GroupName a -> (b -> Int -> Id a -> a -> b) -> b -> b) -> !Int -> Ops a

+ Game.LambdaHack.Common.KindOps: [ofoldlGroup'] :: Ops a -> !(forall b. GroupName a -> (b -> Int -> Id a -> a -> b) -> b -> b)

+ Game.LambdaHack.Common.KindOps: [ofoldlWithKey'] :: Ops a -> !(forall b. (b -> Id a -> a -> b) -> b -> b)

+ Game.LambdaHack.Common.KindOps: [ofoldrWithKey] :: Ops a -> !(forall b. (Id a -> a -> b -> b) -> b -> b)

+ Game.LambdaHack.Common.KindOps: [okind] :: Ops a -> !(Id a -> a)

+ Game.LambdaHack.Common.KindOps: [olength] :: Ops a -> !Int

+ Game.LambdaHack.Common.KindOps: [opick] :: Ops a -> !(GroupName a -> (a -> Bool) -> Rnd (Maybe (Id a)))

+ Game.LambdaHack.Common.KindOps: [ouniqGroup] :: Ops a -> !(GroupName a -> Id a)

+ Game.LambdaHack.Common.KindOps: data Ops a

+ Game.LambdaHack.Common.KindOps: instance Data.Binary.Class.Binary (Game.LambdaHack.Common.KindOps.Id c)

+ Game.LambdaHack.Common.KindOps: instance GHC.Classes.Eq (Game.LambdaHack.Common.KindOps.Id c)

+ Game.LambdaHack.Common.KindOps: instance GHC.Classes.Ord (Game.LambdaHack.Common.KindOps.Id c)

+ Game.LambdaHack.Common.KindOps: instance GHC.Enum.Bounded (Game.LambdaHack.Common.KindOps.Id c)

+ Game.LambdaHack.Common.KindOps: instance GHC.Enum.Enum (Game.LambdaHack.Common.KindOps.Id c)

+ Game.LambdaHack.Common.KindOps: instance GHC.Show.Show (Game.LambdaHack.Common.KindOps.Id c)

+ Game.LambdaHack.Common.KindOps: newtype Id c

+ Game.LambdaHack.Common.Level: [lactorCoeff] :: Level -> !Int

+ Game.LambdaHack.Common.Level: [lactorFreq] :: Level -> !(Freqs ItemKind)

+ Game.LambdaHack.Common.Level: [lactor] :: Level -> !ActorMap

+ Game.LambdaHack.Common.Level: [lclear] :: Level -> !Int

+ Game.LambdaHack.Common.Level: [ldepth] :: Level -> !AbsDepth

+ Game.LambdaHack.Common.Level: [ldesc] :: Level -> !Text

+ Game.LambdaHack.Common.Level: [lembed] :: Level -> !ItemFloor

+ Game.LambdaHack.Common.Level: [lescape] :: Level -> ![Point]

+ Game.LambdaHack.Common.Level: [lfloor] :: Level -> !ItemFloor

+ Game.LambdaHack.Common.Level: [litemFreq] :: Level -> !(Freqs ItemKind)

+ Game.LambdaHack.Common.Level: [litemNum] :: Level -> !Int

+ Game.LambdaHack.Common.Level: [lnight] :: Level -> !Bool

+ Game.LambdaHack.Common.Level: [lseen] :: Level -> !Int

+ Game.LambdaHack.Common.Level: [lsmell] :: Level -> !SmellMap

+ Game.LambdaHack.Common.Level: [lstair] :: Level -> !([Point], [Point])

+ Game.LambdaHack.Common.Level: [ltile] :: Level -> !TileMap

+ Game.LambdaHack.Common.Level: [ltime] :: Level -> !Time

+ Game.LambdaHack.Common.Level: [lxsize] :: Level -> !X

+ Game.LambdaHack.Common.Level: [lysize] :: Level -> !Y

+ Game.LambdaHack.Common.Level: findPoint :: X -> Y -> (Point -> Maybe Point) -> Rnd Point

+ Game.LambdaHack.Common.Level: findPosTry2 :: Int -> TileMap -> (Point -> Id TileKind -> Bool) -> [Point -> Id TileKind -> Bool] -> (Point -> Id TileKind -> Bool) -> [Point -> Id TileKind -> Bool] -> Rnd Point

+ Game.LambdaHack.Common.Level: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Level.Level

+ Game.LambdaHack.Common.Level: instance GHC.Classes.Eq Game.LambdaHack.Common.Level.Level

+ Game.LambdaHack.Common.Level: instance GHC.Show.Show Game.LambdaHack.Common.Level.Level

+ Game.LambdaHack.Common.Level: type ActorMap = EnumMap Point [ActorId]

+ Game.LambdaHack.Common.Level: whereTo :: LevelId -> Point -> Maybe Bool -> Dungeon -> (LevelId, Point)

+ Game.LambdaHack.Common.Misc: MLoreItem :: ItemDialogMode

+ Game.LambdaHack.Common.Misc: MLoreOrgan :: ItemDialogMode

+ Game.LambdaHack.Common.Misc: appDataDir :: IO FilePath

+ Game.LambdaHack.Common.Misc: describeTactic :: Tactic -> Text

+ Game.LambdaHack.Common.Misc: instance (Data.Hashable.Class.Hashable k, GHC.Classes.Eq k, Data.Binary.Class.Binary k, Data.Binary.Class.Binary v) => Data.Binary.Class.Binary (Data.HashMap.Base.HashMap k v)

+ Game.LambdaHack.Common.Misc: instance (GHC.Enum.Enum k, Data.Binary.Class.Binary k) => Data.Binary.Class.Binary (Data.EnumSet.EnumSet k)

+ Game.LambdaHack.Common.Misc: instance (GHC.Enum.Enum k, Data.Binary.Class.Binary k, Data.Binary.Class.Binary e) => Data.Binary.Class.Binary (Data.EnumMap.Strict.EnumMap k e)

+ Game.LambdaHack.Common.Misc: instance (GHC.Enum.Enum k, Data.Hashable.Class.Hashable k, Data.Hashable.Class.Hashable e) => Data.Hashable.Class.Hashable (Data.EnumMap.Strict.EnumMap k e)

+ Game.LambdaHack.Common.Misc: instance Control.DeepSeq.NFData (Game.LambdaHack.Common.Misc.GroupName a)

+ Game.LambdaHack.Common.Misc: instance Control.DeepSeq.NFData Game.LambdaHack.Common.Misc.CStore

+ Game.LambdaHack.Common.Misc: instance Control.DeepSeq.NFData Game.LambdaHack.Common.Misc.ItemDialogMode

+ Game.LambdaHack.Common.Misc: instance Control.DeepSeq.NFData NLP.Miniutter.English.Part

+ Game.LambdaHack.Common.Misc: instance Control.DeepSeq.NFData NLP.Miniutter.English.Person

+ Game.LambdaHack.Common.Misc: instance Control.DeepSeq.NFData NLP.Miniutter.English.Polarity

+ Game.LambdaHack.Common.Misc: instance Data.Binary.Class.Binary (Game.LambdaHack.Common.Misc.GroupName a)

+ Game.LambdaHack.Common.Misc: instance Data.Binary.Class.Binary Data.Time.Clock.UTC.NominalDiffTime

+ Game.LambdaHack.Common.Misc: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Misc.AbsDepth

+ Game.LambdaHack.Common.Misc: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Misc.ActorId

+ Game.LambdaHack.Common.Misc: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Misc.CStore

+ Game.LambdaHack.Common.Misc: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Misc.Container

+ Game.LambdaHack.Common.Misc: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Misc.FactionId

+ Game.LambdaHack.Common.Misc: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Misc.ItemDialogMode

+ Game.LambdaHack.Common.Misc: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Misc.LevelId

+ Game.LambdaHack.Common.Misc: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Misc.Tactic

+ Game.LambdaHack.Common.Misc: instance Data.Hashable.Class.Hashable (Game.LambdaHack.Common.Misc.GroupName a)

+ Game.LambdaHack.Common.Misc: instance Data.Hashable.Class.Hashable Game.LambdaHack.Common.Misc.AbsDepth

+ Game.LambdaHack.Common.Misc: instance Data.Hashable.Class.Hashable Game.LambdaHack.Common.Misc.CStore

+ Game.LambdaHack.Common.Misc: instance Data.Hashable.Class.Hashable Game.LambdaHack.Common.Misc.FactionId

+ Game.LambdaHack.Common.Misc: instance Data.Hashable.Class.Hashable Game.LambdaHack.Common.Misc.LevelId

+ Game.LambdaHack.Common.Misc: instance Data.Hashable.Class.Hashable Game.LambdaHack.Common.Misc.Tactic

+ Game.LambdaHack.Common.Misc: instance Data.Key.Zip (Data.EnumMap.Strict.EnumMap k)

+ Game.LambdaHack.Common.Misc: instance Data.String.IsString (Game.LambdaHack.Common.Misc.GroupName a)

+ Game.LambdaHack.Common.Misc: instance GHC.Classes.Eq (Game.LambdaHack.Common.Misc.GroupName a)

+ Game.LambdaHack.Common.Misc: instance GHC.Classes.Eq Game.LambdaHack.Common.Misc.AbsDepth

+ Game.LambdaHack.Common.Misc: instance GHC.Classes.Eq Game.LambdaHack.Common.Misc.ActorId

+ Game.LambdaHack.Common.Misc: instance GHC.Classes.Eq Game.LambdaHack.Common.Misc.CStore

+ Game.LambdaHack.Common.Misc: instance GHC.Classes.Eq Game.LambdaHack.Common.Misc.Container

+ Game.LambdaHack.Common.Misc: instance GHC.Classes.Eq Game.LambdaHack.Common.Misc.FactionId

+ Game.LambdaHack.Common.Misc: instance GHC.Classes.Eq Game.LambdaHack.Common.Misc.ItemDialogMode

+ Game.LambdaHack.Common.Misc: instance GHC.Classes.Eq Game.LambdaHack.Common.Misc.LevelId

+ Game.LambdaHack.Common.Misc: instance GHC.Classes.Eq Game.LambdaHack.Common.Misc.Tactic

+ Game.LambdaHack.Common.Misc: instance GHC.Classes.Ord (Game.LambdaHack.Common.Misc.GroupName a)

+ Game.LambdaHack.Common.Misc: instance GHC.Classes.Ord Game.LambdaHack.Common.Misc.AbsDepth

+ Game.LambdaHack.Common.Misc: instance GHC.Classes.Ord Game.LambdaHack.Common.Misc.ActorId

+ Game.LambdaHack.Common.Misc: instance GHC.Classes.Ord Game.LambdaHack.Common.Misc.CStore

+ Game.LambdaHack.Common.Misc: instance GHC.Classes.Ord Game.LambdaHack.Common.Misc.Container

+ Game.LambdaHack.Common.Misc: instance GHC.Classes.Ord Game.LambdaHack.Common.Misc.FactionId

+ Game.LambdaHack.Common.Misc: instance GHC.Classes.Ord Game.LambdaHack.Common.Misc.ItemDialogMode

+ Game.LambdaHack.Common.Misc: instance GHC.Classes.Ord Game.LambdaHack.Common.Misc.LevelId

+ Game.LambdaHack.Common.Misc: instance GHC.Classes.Ord Game.LambdaHack.Common.Misc.Tactic

+ Game.LambdaHack.Common.Misc: instance GHC.Enum.Bounded Game.LambdaHack.Common.Misc.CStore

+ Game.LambdaHack.Common.Misc: instance GHC.Enum.Bounded Game.LambdaHack.Common.Misc.Tactic

+ Game.LambdaHack.Common.Misc: instance GHC.Enum.Enum Game.LambdaHack.Common.Misc.ActorId

+ Game.LambdaHack.Common.Misc: instance GHC.Enum.Enum Game.LambdaHack.Common.Misc.CStore

+ Game.LambdaHack.Common.Misc: instance GHC.Enum.Enum Game.LambdaHack.Common.Misc.FactionId

+ Game.LambdaHack.Common.Misc: instance GHC.Enum.Enum Game.LambdaHack.Common.Misc.LevelId

+ Game.LambdaHack.Common.Misc: instance GHC.Enum.Enum Game.LambdaHack.Common.Misc.Tactic

+ Game.LambdaHack.Common.Misc: instance GHC.Enum.Enum k => Data.Key.Adjustable (Data.EnumMap.Strict.EnumMap k)

+ Game.LambdaHack.Common.Misc: instance GHC.Enum.Enum k => Data.Key.FoldableWithKey (Data.EnumMap.Strict.EnumMap k)

+ Game.LambdaHack.Common.Misc: instance GHC.Enum.Enum k => Data.Key.Indexable (Data.EnumMap.Strict.EnumMap k)

+ Game.LambdaHack.Common.Misc: instance GHC.Enum.Enum k => Data.Key.Keyed (Data.EnumMap.Strict.EnumMap k)

+ Game.LambdaHack.Common.Misc: instance GHC.Enum.Enum k => Data.Key.Lookup (Data.EnumMap.Strict.EnumMap k)

+ Game.LambdaHack.Common.Misc: instance GHC.Enum.Enum k => Data.Key.TraversableWithKey (Data.EnumMap.Strict.EnumMap k)

+ Game.LambdaHack.Common.Misc: instance GHC.Enum.Enum k => Data.Key.ZipWithKey (Data.EnumMap.Strict.EnumMap k)

+ Game.LambdaHack.Common.Misc: instance GHC.Generics.Generic (Game.LambdaHack.Common.Misc.GroupName a)

+ Game.LambdaHack.Common.Misc: instance GHC.Generics.Generic Game.LambdaHack.Common.Misc.CStore

+ Game.LambdaHack.Common.Misc: instance GHC.Generics.Generic Game.LambdaHack.Common.Misc.Container

+ Game.LambdaHack.Common.Misc: instance GHC.Generics.Generic Game.LambdaHack.Common.Misc.ItemDialogMode

+ Game.LambdaHack.Common.Misc: instance GHC.Generics.Generic Game.LambdaHack.Common.Misc.Tactic

+ Game.LambdaHack.Common.Misc: instance GHC.Read.Read (Game.LambdaHack.Common.Misc.GroupName a)

+ Game.LambdaHack.Common.Misc: instance GHC.Read.Read Game.LambdaHack.Common.Misc.CStore

+ Game.LambdaHack.Common.Misc: instance GHC.Read.Read Game.LambdaHack.Common.Misc.ItemDialogMode

+ Game.LambdaHack.Common.Misc: instance GHC.Show.Show (Game.LambdaHack.Common.Misc.GroupName a)

+ Game.LambdaHack.Common.Misc: instance GHC.Show.Show Game.LambdaHack.Common.Misc.AbsDepth

+ Game.LambdaHack.Common.Misc: instance GHC.Show.Show Game.LambdaHack.Common.Misc.ActorId

+ Game.LambdaHack.Common.Misc: instance GHC.Show.Show Game.LambdaHack.Common.Misc.CStore

+ Game.LambdaHack.Common.Misc: instance GHC.Show.Show Game.LambdaHack.Common.Misc.Container

+ Game.LambdaHack.Common.Misc: instance GHC.Show.Show Game.LambdaHack.Common.Misc.FactionId

+ Game.LambdaHack.Common.Misc: instance GHC.Show.Show Game.LambdaHack.Common.Misc.ItemDialogMode

+ Game.LambdaHack.Common.Misc: instance GHC.Show.Show Game.LambdaHack.Common.Misc.LevelId

+ Game.LambdaHack.Common.Misc: instance GHC.Show.Show Game.LambdaHack.Common.Misc.Tactic

+ Game.LambdaHack.Common.Misc: makePhrase :: [Part] -> Text

+ Game.LambdaHack.Common.Misc: makeSentence :: [Part] -> Text

+ Game.LambdaHack.Common.Misc: minusM :: Int64

+ Game.LambdaHack.Common.Misc: minusM1 :: Int64

+ Game.LambdaHack.Common.Misc: oneM :: Int64

+ Game.LambdaHack.Common.Misc: xM :: Int -> Int64

+ Game.LambdaHack.Common.MonadStateRead: isNoConfirmsGame :: MonadStateRead m => m Bool

+ Game.LambdaHack.Common.MonadStateRead: pickWeaponM :: MonadStateRead m => Maybe DiscoveryBenefit -> [(ItemId, ItemFull)] -> Skills -> ActorAspect -> ActorId -> m [(Int, (ItemId, ItemFull))]

+ Game.LambdaHack.Common.Perception: PerSmelled :: EnumSet Point -> PerSmelled

+ Game.LambdaHack.Common.Perception: PerVisible :: EnumSet Point -> PerVisible

+ Game.LambdaHack.Common.Perception: [psight] :: Perception -> !PerVisible

+ Game.LambdaHack.Common.Perception: [psmell] :: Perception -> !PerSmelled

+ Game.LambdaHack.Common.Perception: [psmelled] :: PerSmelled -> EnumSet Point

+ Game.LambdaHack.Common.Perception: [pvisible] :: PerVisible -> EnumSet Point

+ Game.LambdaHack.Common.Perception: emptyPer :: Perception

+ Game.LambdaHack.Common.Perception: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Perception.PerSmelled

+ Game.LambdaHack.Common.Perception: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Perception.PerVisible

+ Game.LambdaHack.Common.Perception: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Perception.Perception

+ Game.LambdaHack.Common.Perception: instance GHC.Classes.Eq Game.LambdaHack.Common.Perception.PerSmelled

+ Game.LambdaHack.Common.Perception: instance GHC.Classes.Eq Game.LambdaHack.Common.Perception.PerVisible

+ Game.LambdaHack.Common.Perception: instance GHC.Classes.Eq Game.LambdaHack.Common.Perception.Perception

+ Game.LambdaHack.Common.Perception: instance GHC.Generics.Generic Game.LambdaHack.Common.Perception.Perception

+ Game.LambdaHack.Common.Perception: instance GHC.Show.Show Game.LambdaHack.Common.Perception.PerSmelled

+ Game.LambdaHack.Common.Perception: instance GHC.Show.Show Game.LambdaHack.Common.Perception.PerVisible

+ Game.LambdaHack.Common.Perception: instance GHC.Show.Show Game.LambdaHack.Common.Perception.Perception

+ Game.LambdaHack.Common.Perception: newtype PerSmelled

+ Game.LambdaHack.Common.Perception: newtype PerVisible

+ Game.LambdaHack.Common.Perception: totalSmelled :: Perception -> EnumSet Point

+ Game.LambdaHack.Common.Perception: type PerFid = EnumMap FactionId PerLid

+ Game.LambdaHack.Common.Perception: type PerLid = EnumMap LevelId Perception

+ Game.LambdaHack.Common.Point: [px] :: Point -> !X

+ Game.LambdaHack.Common.Point: [py] :: Point -> !Y

+ Game.LambdaHack.Common.Point: instance Control.DeepSeq.NFData Game.LambdaHack.Common.Point.Point

+ Game.LambdaHack.Common.Point: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Point.Point

+ Game.LambdaHack.Common.Point: instance GHC.Classes.Eq Game.LambdaHack.Common.Point.Point

+ Game.LambdaHack.Common.Point: instance GHC.Classes.Ord Game.LambdaHack.Common.Point.Point

+ Game.LambdaHack.Common.Point: instance GHC.Enum.Enum Game.LambdaHack.Common.Point.Point

+ Game.LambdaHack.Common.Point: instance GHC.Generics.Generic Game.LambdaHack.Common.Point.Point

+ Game.LambdaHack.Common.Point: instance GHC.Show.Show Game.LambdaHack.Common.Point.Point

+ Game.LambdaHack.Common.Point: originPoint :: Point

+ Game.LambdaHack.Common.PointArray: Array :: !X -> !Y -> !(Vector w) -> GArray w c

+ Game.LambdaHack.Common.PointArray: [avector] :: GArray w c -> !(Vector w)

+ Game.LambdaHack.Common.PointArray: [axsize] :: GArray w c -> !X

+ Game.LambdaHack.Common.PointArray: [aysize] :: GArray w c -> !Y

+ Game.LambdaHack.Common.PointArray: accessI :: Unbox w => GArray w c -> Int -> w

+ Game.LambdaHack.Common.PointArray: data GArray w c

+ Game.LambdaHack.Common.PointArray: foldMA' :: (Monad m, Unbox w, Enum w, Enum c) => (a -> c -> m a) -> a -> GArray w c -> m a

+ Game.LambdaHack.Common.PointArray: foldlA' :: (Unbox w, Enum w, Enum c) => (a -> c -> a) -> a -> GArray w c -> a

+ Game.LambdaHack.Common.PointArray: foldrA :: (Unbox w, Enum w, Enum c) => (c -> a -> a) -> a -> GArray w c -> a

+ Game.LambdaHack.Common.PointArray: foldrA' :: (Unbox w, Enum w, Enum c) => (c -> a -> a) -> a -> GArray w c -> a

+ Game.LambdaHack.Common.PointArray: fromListA :: (Unbox w, Enum w, Enum c) => X -> Y -> [c] -> GArray w c

+ Game.LambdaHack.Common.PointArray: ifoldMA' :: (Monad m, Unbox w, Enum w, Enum c) => (a -> Point -> c -> m a) -> a -> GArray w c -> m a

+ Game.LambdaHack.Common.PointArray: ifoldlA' :: (Unbox w, Enum w, Enum c) => (a -> Point -> c -> a) -> a -> GArray w c -> a

+ Game.LambdaHack.Common.PointArray: ifoldrA :: (Unbox w, Enum w, Enum c) => (Point -> c -> a -> a) -> a -> GArray w c -> a

+ Game.LambdaHack.Common.PointArray: ifoldrA' :: (Unbox w, Enum w, Enum c) => (Point -> c -> a -> a) -> a -> GArray w c -> a

+ Game.LambdaHack.Common.PointArray: imapMA_ :: (Unbox w, Enum w, Enum c, Monad m) => (Point -> c -> m ()) -> GArray w c -> m ()

+ Game.LambdaHack.Common.PointArray: instance (Data.Vector.Unboxed.Base.Unbox w, Data.Binary.Class.Binary w) => Data.Binary.Class.Binary (Game.LambdaHack.Common.PointArray.GArray w c)

+ Game.LambdaHack.Common.PointArray: instance (GHC.Classes.Eq w, Data.Vector.Unboxed.Base.Unbox w) => GHC.Classes.Eq (Game.LambdaHack.Common.PointArray.GArray w c)

+ Game.LambdaHack.Common.PointArray: instance GHC.Show.Show (Game.LambdaHack.Common.PointArray.GArray w c)

+ Game.LambdaHack.Common.PointArray: pindex :: X -> Point -> Int

+ Game.LambdaHack.Common.PointArray: punindex :: X -> Int -> Point

+ Game.LambdaHack.Common.PointArray: toListA :: (Unbox w, Enum w, Enum c) => GArray w c -> [c]

+ Game.LambdaHack.Common.PointArray: type Array c = GArray Word8 c

+ Game.LambdaHack.Common.PointArray: unfoldrNA :: (Unbox w, Enum w, Enum c) => X -> Y -> (b -> (c, b)) -> b -> GArray w c

+ Game.LambdaHack.Common.PointArray: unsafeWriteA :: (Unbox w, Enum w, Enum c) => GArray w c -> Point -> c -> ()

+ Game.LambdaHack.Common.PointArray: unsafeWriteManyA :: (Unbox w, Enum w, Enum c) => GArray w c -> [Point] -> c -> ()

+ Game.LambdaHack.Common.Prelude: (&&&) :: Arrow a => forall b c c'. a b c -> a b c' -> a b (c, c')

+ Game.LambdaHack.Common.Prelude: (***) :: Arrow a => forall b c b' c'. a b c -> a b' c' -> a (b, b') (c, c')

+ Game.LambdaHack.Common.Prelude: (<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)

+ Game.LambdaHack.Common.Prelude: (<+>) :: Text -> Text -> Text

+ Game.LambdaHack.Common.Prelude: data Text :: *

+ Game.LambdaHack.Common.Prelude: divUp :: Integral a => a -> a -> a

+ Game.LambdaHack.Common.Prelude: first :: Arrow a => forall b c d. a b c -> a (b, d) (c, d)

+ Game.LambdaHack.Common.Prelude: infixl 4 <$$>

+ Game.LambdaHack.Common.Prelude: infixl 7 `divUp`

+ Game.LambdaHack.Common.Prelude: infixr 6 <+>

+ Game.LambdaHack.Common.Prelude: partitionM :: Applicative m => (a -> m Bool) -> [a] -> m ([a], [a])

+ Game.LambdaHack.Common.Prelude: second :: Arrow a => forall b c d. a b c -> a (d, b) (d, c)

+ Game.LambdaHack.Common.Prelude: tshow :: Show a => a -> Text

+ Game.LambdaHack.Common.Random: foldlM' :: Foldable t => (b -> a -> Rnd b) -> b -> t a -> Rnd b

+ Game.LambdaHack.Common.Random: foldrM :: Foldable t => (a -> b -> Rnd b) -> b -> t a -> Rnd b

+ Game.LambdaHack.Common.Request: AlterUnwalked :: ReqFailure

+ Game.LambdaHack.Common.Request: ApplyNoEffects :: ReqFailure

+ Game.LambdaHack.Common.Request: ProjectLobable :: ReqFailure

+ Game.LambdaHack.Common.Request: ReqAINop :: ReqAI

+ Game.LambdaHack.Common.Request: ReqUINop :: ReqUI

+ Game.LambdaHack.Common.Request: [ReqAlter] :: !Point -> RequestTimed AbAlter

+ Game.LambdaHack.Common.Request: [ReqApply] :: !ItemId -> !CStore -> RequestTimed AbApply

+ Game.LambdaHack.Common.Request: [ReqDisplace] :: !ActorId -> RequestTimed AbDisplace

+ Game.LambdaHack.Common.Request: [ReqMelee] :: !ActorId -> !ItemId -> !CStore -> RequestTimed AbMelee

+ Game.LambdaHack.Common.Request: [ReqMoveItems] :: ![(ItemId, Int, CStore, CStore)] -> RequestTimed AbMoveItem

+ Game.LambdaHack.Common.Request: [ReqMove] :: !Vector -> RequestTimed AbMove

+ Game.LambdaHack.Common.Request: [ReqProject] :: !Point -> !Int -> !ItemId -> !CStore -> RequestTimed AbProject

+ Game.LambdaHack.Common.Request: [ReqWait10] :: RequestTimed AbWait

+ Game.LambdaHack.Common.Request: [ReqWait] :: RequestTimed AbWait

+ Game.LambdaHack.Common.Request: data ReqAI

+ Game.LambdaHack.Common.Request: data ReqUI

+ Game.LambdaHack.Common.Request: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Request.ReqFailure

+ Game.LambdaHack.Common.Request: instance GHC.Classes.Eq Game.LambdaHack.Common.Request.ReqFailure

+ Game.LambdaHack.Common.Request: instance GHC.Generics.Generic Game.LambdaHack.Common.Request.ReqFailure

+ Game.LambdaHack.Common.Request: instance GHC.Show.Show (Game.LambdaHack.Common.Request.RequestTimed a)

+ Game.LambdaHack.Common.Request: instance GHC.Show.Show Game.LambdaHack.Common.Request.ReqAI

+ Game.LambdaHack.Common.Request: instance GHC.Show.Show Game.LambdaHack.Common.Request.ReqFailure

+ Game.LambdaHack.Common.Request: instance GHC.Show.Show Game.LambdaHack.Common.Request.ReqUI

+ Game.LambdaHack.Common.Request: instance GHC.Show.Show Game.LambdaHack.Common.Request.RequestAnyAbility

+ Game.LambdaHack.Common.Request: permittedProjectAI :: Int -> Bool -> ItemFull -> Bool

+ Game.LambdaHack.Common.Request: timedToUI :: RequestTimed a -> ReqUI

+ Game.LambdaHack.Common.Request: type RequestAI = (ReqAI, Maybe ActorId)

+ Game.LambdaHack.Common.Request: type RequestUI = (ReqUI, Maybe ActorId)

+ Game.LambdaHack.Common.Response: ChanServer :: !(CliSerQueue Response) -> !(CliSerQueue RequestAI) -> !(Maybe (CliSerQueue RequestUI)) -> ChanServer

+ Game.LambdaHack.Common.Response: RespSfxAtomic :: !SfxAtomic -> Response

+ Game.LambdaHack.Common.Response: RespUpdAtomic :: !UpdAtomic -> Response

+ Game.LambdaHack.Common.Response: [requestAIS] :: ChanServer -> !(CliSerQueue RequestAI)

+ Game.LambdaHack.Common.Response: [requestUIS] :: ChanServer -> !(Maybe (CliSerQueue RequestUI))

+ Game.LambdaHack.Common.Response: [responseS] :: ChanServer -> !(CliSerQueue Response)

+ Game.LambdaHack.Common.Response: data ChanServer

+ Game.LambdaHack.Common.Response: data Response

+ Game.LambdaHack.Common.Response: instance GHC.Show.Show Game.LambdaHack.Common.Response.Response

+ Game.LambdaHack.Common.Response: type CliSerQueue = MVar

+ Game.LambdaHack.Common.RingBuffer: instance Data.Binary.Class.Binary a => Data.Binary.Class.Binary (Game.LambdaHack.Common.RingBuffer.RingBuffer a)

+ Game.LambdaHack.Common.RingBuffer: instance GHC.Generics.Generic (Game.LambdaHack.Common.RingBuffer.RingBuffer a)

+ Game.LambdaHack.Common.RingBuffer: instance GHC.Show.Show a => GHC.Show.Show (Game.LambdaHack.Common.RingBuffer.RingBuffer a)

+ Game.LambdaHack.Common.RingBuffer: length :: RingBuffer a -> Int

+ Game.LambdaHack.Common.Save: loopSave :: Binary a => COps -> (a -> FilePath) -> ChanSave a -> IO ()

+ Game.LambdaHack.Common.Save: saveNameCli :: FactionId -> String

+ Game.LambdaHack.Common.Save: saveNameSer :: String

+ Game.LambdaHack.Common.State: instance Data.Binary.Class.Binary Game.LambdaHack.Common.State.State

+ Game.LambdaHack.Common.State: instance GHC.Classes.Eq Game.LambdaHack.Common.State.State

+ Game.LambdaHack.Common.State: instance GHC.Show.Show Game.LambdaHack.Common.State.State

+ Game.LambdaHack.Common.Tile: alterMinSkill :: TileSpeedup -> Id TileKind -> Int

+ Game.LambdaHack.Common.Tile: alterMinWalk :: TileSpeedup -> Id TileKind -> Int

+ Game.LambdaHack.Common.Tile: buildAs :: Ops TileKind -> Id TileKind -> Id TileKind

+ Game.LambdaHack.Common.Tile: consideredByAI :: TileSpeedup -> Id TileKind -> Bool

+ Game.LambdaHack.Common.Tile: createTabWithKey :: Unbox a => Ops TileKind -> (Id TileKind -> TileKind -> a) -> Tab a

+ Game.LambdaHack.Common.Tile: embeddedItems :: Ops TileKind -> Id TileKind -> [GroupName ItemKind]

+ Game.LambdaHack.Common.Tile: isChangable :: TileSpeedup -> Id TileKind -> Bool

+ Game.LambdaHack.Common.Tile: isEasyOpen :: TileSpeedup -> Id TileKind -> Bool

+ Game.LambdaHack.Common.Tile: isEasyOpenKind :: TileKind -> Bool

+ Game.LambdaHack.Common.Tile: isHideAs :: TileSpeedup -> Id TileKind -> Bool

+ Game.LambdaHack.Common.Tile: isNoActor :: TileSpeedup -> Id TileKind -> Bool

+ Game.LambdaHack.Common.Tile: isNoItem :: TileSpeedup -> Id TileKind -> Bool

+ Game.LambdaHack.Common.Tile: isOftenActor :: TileSpeedup -> Id TileKind -> Bool

+ Game.LambdaHack.Common.Tile: isOftenItem :: TileSpeedup -> Id TileKind -> Bool

+ Game.LambdaHack.Common.Tile: obscureAs :: Ops TileKind -> Id TileKind -> Rnd (Id TileKind)

+ Game.LambdaHack.Common.Time: absoluteTimeSubtract :: Time -> Time -> Time

+ Game.LambdaHack.Common.Time: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Time.Speed

+ Game.LambdaHack.Common.Time: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Time.Time

+ Game.LambdaHack.Common.Time: instance Data.Binary.Class.Binary a => Data.Binary.Class.Binary (Game.LambdaHack.Common.Time.Delta a)

+ Game.LambdaHack.Common.Time: instance GHC.Base.Functor Game.LambdaHack.Common.Time.Delta

+ Game.LambdaHack.Common.Time: instance GHC.Classes.Eq Game.LambdaHack.Common.Time.Speed

+ Game.LambdaHack.Common.Time: instance GHC.Classes.Eq Game.LambdaHack.Common.Time.Time

+ Game.LambdaHack.Common.Time: instance GHC.Classes.Eq a => GHC.Classes.Eq (Game.LambdaHack.Common.Time.Delta a)

+ Game.LambdaHack.Common.Time: instance GHC.Classes.Ord Game.LambdaHack.Common.Time.Speed

+ Game.LambdaHack.Common.Time: instance GHC.Classes.Ord Game.LambdaHack.Common.Time.Time

+ Game.LambdaHack.Common.Time: instance GHC.Classes.Ord a => GHC.Classes.Ord (Game.LambdaHack.Common.Time.Delta a)

+ Game.LambdaHack.Common.Time: instance GHC.Enum.Bounded Game.LambdaHack.Common.Time.Time

+ Game.LambdaHack.Common.Time: instance GHC.Enum.Bounded a => GHC.Enum.Bounded (Game.LambdaHack.Common.Time.Delta a)

+ Game.LambdaHack.Common.Time: instance GHC.Enum.Enum Game.LambdaHack.Common.Time.Time

+ Game.LambdaHack.Common.Time: instance GHC.Enum.Enum a => GHC.Enum.Enum (Game.LambdaHack.Common.Time.Delta a)

+ Game.LambdaHack.Common.Time: instance GHC.Show.Show Game.LambdaHack.Common.Time.Speed

+ Game.LambdaHack.Common.Time: instance GHC.Show.Show Game.LambdaHack.Common.Time.Time

+ Game.LambdaHack.Common.Time: instance GHC.Show.Show a => GHC.Show.Show (Game.LambdaHack.Common.Time.Delta a)

+ Game.LambdaHack.Common.Time: modifyDamageBySpeed :: Int64 -> Speed -> Int64

+ Game.LambdaHack.Common.Time: speedThrust :: Speed

+ Game.LambdaHack.Common.Time: speedWalk :: Speed

+ Game.LambdaHack.Common.Time: timeDeltaPercent :: Delta Time -> Int -> Delta Time

+ Game.LambdaHack.Common.Vector: [vx] :: Vector -> !X

+ Game.LambdaHack.Common.Vector: [vy] :: Vector -> !Y

+ Game.LambdaHack.Common.Vector: instance Control.DeepSeq.NFData Game.LambdaHack.Common.Vector.Vector

+ Game.LambdaHack.Common.Vector: instance Data.Binary.Class.Binary Game.LambdaHack.Common.Vector.Vector

+ Game.LambdaHack.Common.Vector: instance GHC.Classes.Eq Game.LambdaHack.Common.Vector.Vector

+ Game.LambdaHack.Common.Vector: instance GHC.Classes.Ord Game.LambdaHack.Common.Vector.Vector

+ Game.LambdaHack.Common.Vector: instance GHC.Enum.Enum Game.LambdaHack.Common.Vector.Vector

+ Game.LambdaHack.Common.Vector: instance GHC.Generics.Generic Game.LambdaHack.Common.Vector.Vector

+ Game.LambdaHack.Common.Vector: instance GHC.Read.Read Game.LambdaHack.Common.Vector.Vector

+ Game.LambdaHack.Common.Vector: instance GHC.Show.Show Game.LambdaHack.Common.Vector.Vector

+ Game.LambdaHack.Common.Vector: squareUnsafeSet :: Point -> EnumSet Point

+ Game.LambdaHack.Common.Vector: vicinityCardinalUnsafe :: Point -> [Point]

+ Game.LambdaHack.Common.Vector: vicinityUnsafe :: Point -> [Point]

+ Game.LambdaHack.Content.CaveKind: [cactorCoeff] :: CaveKind -> !Int

+ Game.LambdaHack.Content.CaveKind: [cactorFreq] :: CaveKind -> !(Freqs ItemKind)

+ Game.LambdaHack.Content.CaveKind: [cauxConnects] :: CaveKind -> !Rational

+ Game.LambdaHack.Content.CaveKind: [cdarkChance] :: CaveKind -> !Dice

+ Game.LambdaHack.Content.CaveKind: [cdarkCorTile] :: CaveKind -> !(GroupName TileKind)

+ Game.LambdaHack.Content.CaveKind: [cdefTile] :: CaveKind -> !(GroupName TileKind)

+ Game.LambdaHack.Content.CaveKind: [cdoorChance] :: CaveKind -> !Chance

+ Game.LambdaHack.Content.CaveKind: [cescapeGroup] :: CaveKind -> !(Maybe (GroupName PlaceKind))

+ Game.LambdaHack.Content.CaveKind: [cextraStairs] :: CaveKind -> !Dice

+ Game.LambdaHack.Content.CaveKind: [cfillerTile] :: CaveKind -> !(GroupName TileKind)

+ Game.LambdaHack.Content.CaveKind: [cfreq] :: CaveKind -> !(Freqs CaveKind)

+ Game.LambdaHack.Content.CaveKind: [cgrid] :: CaveKind -> !DiceXY

+ Game.LambdaHack.Content.CaveKind: [chidden] :: CaveKind -> !Int

+ Game.LambdaHack.Content.CaveKind: [citemFreq] :: CaveKind -> !(Freqs ItemKind)

+ Game.LambdaHack.Content.CaveKind: [citemNum] :: CaveKind -> !Dice

+ Game.LambdaHack.Content.CaveKind: [clegendDarkTile] :: CaveKind -> !(GroupName TileKind)

+ Game.LambdaHack.Content.CaveKind: [clegendLitTile] :: CaveKind -> !(GroupName TileKind)

+ Game.LambdaHack.Content.CaveKind: [clitCorTile] :: CaveKind -> !(GroupName TileKind)

+ Game.LambdaHack.Content.CaveKind: [cmaxPlaceSize] :: CaveKind -> !DiceXY

+ Game.LambdaHack.Content.CaveKind: [cmaxVoid] :: CaveKind -> !Rational

+ Game.LambdaHack.Content.CaveKind: [cminPlaceSize] :: CaveKind -> !DiceXY

+ Game.LambdaHack.Content.CaveKind: [cminStairDist] :: CaveKind -> !Int

+ Game.LambdaHack.Content.CaveKind: [cname] :: CaveKind -> !Text

+ Game.LambdaHack.Content.CaveKind: [cnightChance] :: CaveKind -> !Dice

+ Game.LambdaHack.Content.CaveKind: [copenChance] :: CaveKind -> !Chance

+ Game.LambdaHack.Content.CaveKind: [couterFenceTile] :: CaveKind -> !(GroupName TileKind)

+ Game.LambdaHack.Content.CaveKind: [cpassable] :: CaveKind -> !Bool

+ Game.LambdaHack.Content.CaveKind: [cplaceFreq] :: CaveKind -> !(Freqs PlaceKind)

+ Game.LambdaHack.Content.CaveKind: [cstairFreq] :: CaveKind -> !(Freqs PlaceKind)

+ Game.LambdaHack.Content.CaveKind: [csymbol] :: CaveKind -> !Char

+ Game.LambdaHack.Content.CaveKind: [cxsize] :: CaveKind -> !X

+ Game.LambdaHack.Content.CaveKind: [cysize] :: CaveKind -> !Y

+ Game.LambdaHack.Content.CaveKind: instance GHC.Show.Show Game.LambdaHack.Content.CaveKind.CaveKind

+ Game.LambdaHack.Content.ItemKind: AddAbility :: !Ability -> !Dice -> Aspect

+ Game.LambdaHack.Content.ItemKind: AddAggression :: !Dice -> Aspect

+ Game.LambdaHack.Content.ItemKind: AddNocto :: !Dice -> Aspect

+ Game.LambdaHack.Content.ItemKind: AddShine :: !Dice -> Aspect

+ Game.LambdaHack.Content.ItemKind: Detect :: !Int -> Effect

+ Game.LambdaHack.Content.ItemKind: DetectActor :: !Int -> Effect

+ Game.LambdaHack.Content.ItemKind: DetectExit :: !Int -> Effect

+ Game.LambdaHack.Content.ItemKind: DetectHidden :: !Int -> Effect

+ Game.LambdaHack.Content.ItemKind: DetectItem :: !Int -> Effect

+ Game.LambdaHack.Content.ItemKind: ELabel :: !Text -> Effect

+ Game.LambdaHack.Content.ItemKind: EqpSlotAbAlter :: EqpSlot

+ Game.LambdaHack.Content.ItemKind: EqpSlotAbApply :: EqpSlot

+ Game.LambdaHack.Content.ItemKind: EqpSlotAbDisplace :: EqpSlot

+ Game.LambdaHack.Content.ItemKind: EqpSlotAbMelee :: EqpSlot

+ Game.LambdaHack.Content.ItemKind: EqpSlotAbMove :: EqpSlot

+ Game.LambdaHack.Content.ItemKind: EqpSlotAbMoveItem :: EqpSlot

+ Game.LambdaHack.Content.ItemKind: EqpSlotAbProject :: EqpSlot

+ Game.LambdaHack.Content.ItemKind: EqpSlotAbWait :: EqpSlot

+ Game.LambdaHack.Content.ItemKind: EqpSlotAddAggression :: EqpSlot

+ Game.LambdaHack.Content.ItemKind: EqpSlotAddNocto :: EqpSlot

+ Game.LambdaHack.Content.ItemKind: EqpSlotLightSource :: EqpSlot

+ Game.LambdaHack.Content.ItemKind: EqpSlotMiscAbility :: EqpSlot

+ Game.LambdaHack.Content.ItemKind: EqpSlotMiscBonus :: EqpSlot

+ Game.LambdaHack.Content.ItemKind: Equipable :: Feature

+ Game.LambdaHack.Content.ItemKind: Lobable :: Feature

+ Game.LambdaHack.Content.ItemKind: Meleeable :: Feature

+ Game.LambdaHack.Content.ItemKind: [iaspects] :: ItemKind -> ![Aspect]

+ Game.LambdaHack.Content.ItemKind: [icount] :: ItemKind -> !Dice

+ Game.LambdaHack.Content.ItemKind: [idamage] :: ItemKind -> ![(Int, Dice)]

+ Game.LambdaHack.Content.ItemKind: [idesc] :: ItemKind -> !Text

+ Game.LambdaHack.Content.ItemKind: [ieffects] :: ItemKind -> ![Effect]

+ Game.LambdaHack.Content.ItemKind: [ifeature] :: ItemKind -> ![Feature]

+ Game.LambdaHack.Content.ItemKind: [iflavour] :: ItemKind -> ![Flavour]

+ Game.LambdaHack.Content.ItemKind: [ifreq] :: ItemKind -> !(Freqs ItemKind)

+ Game.LambdaHack.Content.ItemKind: [ikit] :: ItemKind -> ![(GroupName ItemKind, CStore)]

+ Game.LambdaHack.Content.ItemKind: [iname] :: ItemKind -> !Text

+ Game.LambdaHack.Content.ItemKind: [irarity] :: ItemKind -> !Rarity

+ Game.LambdaHack.Content.ItemKind: [isymbol] :: ItemKind -> !Char

+ Game.LambdaHack.Content.ItemKind: [iverbHit] :: ItemKind -> !Part

+ Game.LambdaHack.Content.ItemKind: [iweight] :: ItemKind -> !Int

+ Game.LambdaHack.Content.ItemKind: [throwLinger] :: ThrowMod -> !Int

+ Game.LambdaHack.Content.ItemKind: [throwVelocity] :: ThrowMod -> !Int

+ Game.LambdaHack.Content.ItemKind: forApplyEffect :: Effect -> Bool

+ Game.LambdaHack.Content.ItemKind: forIdEffect :: Effect -> Bool

+ Game.LambdaHack.Content.ItemKind: instance Control.DeepSeq.NFData Game.LambdaHack.Content.ItemKind.Effect

+ Game.LambdaHack.Content.ItemKind: instance Control.DeepSeq.NFData Game.LambdaHack.Content.ItemKind.EqpSlot

+ Game.LambdaHack.Content.ItemKind: instance Control.DeepSeq.NFData Game.LambdaHack.Content.ItemKind.ThrowMod

+ Game.LambdaHack.Content.ItemKind: instance Control.DeepSeq.NFData Game.LambdaHack.Content.ItemKind.TimerDice

+ Game.LambdaHack.Content.ItemKind: instance Data.Binary.Class.Binary Game.LambdaHack.Content.ItemKind.Aspect

+ Game.LambdaHack.Content.ItemKind: instance Data.Binary.Class.Binary Game.LambdaHack.Content.ItemKind.Effect

+ Game.LambdaHack.Content.ItemKind: instance Data.Binary.Class.Binary Game.LambdaHack.Content.ItemKind.EqpSlot

+ Game.LambdaHack.Content.ItemKind: instance Data.Binary.Class.Binary Game.LambdaHack.Content.ItemKind.Feature

+ Game.LambdaHack.Content.ItemKind: instance Data.Binary.Class.Binary Game.LambdaHack.Content.ItemKind.ThrowMod

+ Game.LambdaHack.Content.ItemKind: instance Data.Binary.Class.Binary Game.LambdaHack.Content.ItemKind.TimerDice

+ Game.LambdaHack.Content.ItemKind: instance Data.Hashable.Class.Hashable Game.LambdaHack.Content.ItemKind.Aspect

+ Game.LambdaHack.Content.ItemKind: instance Data.Hashable.Class.Hashable Game.LambdaHack.Content.ItemKind.Effect

+ Game.LambdaHack.Content.ItemKind: instance Data.Hashable.Class.Hashable Game.LambdaHack.Content.ItemKind.EqpSlot

+ Game.LambdaHack.Content.ItemKind: instance Data.Hashable.Class.Hashable Game.LambdaHack.Content.ItemKind.Feature

+ Game.LambdaHack.Content.ItemKind: instance Data.Hashable.Class.Hashable Game.LambdaHack.Content.ItemKind.ThrowMod

+ Game.LambdaHack.Content.ItemKind: instance Data.Hashable.Class.Hashable Game.LambdaHack.Content.ItemKind.TimerDice

+ Game.LambdaHack.Content.ItemKind: instance GHC.Classes.Eq Game.LambdaHack.Content.ItemKind.Aspect

+ Game.LambdaHack.Content.ItemKind: instance GHC.Classes.Eq Game.LambdaHack.Content.ItemKind.Effect

+ Game.LambdaHack.Content.ItemKind: instance GHC.Classes.Eq Game.LambdaHack.Content.ItemKind.EqpSlot

+ Game.LambdaHack.Content.ItemKind: instance GHC.Classes.Eq Game.LambdaHack.Content.ItemKind.Feature

+ Game.LambdaHack.Content.ItemKind: instance GHC.Classes.Eq Game.LambdaHack.Content.ItemKind.ThrowMod

+ Game.LambdaHack.Content.ItemKind: instance GHC.Classes.Eq Game.LambdaHack.Content.ItemKind.TimerDice

+ Game.LambdaHack.Content.ItemKind: instance GHC.Classes.Ord Game.LambdaHack.Content.ItemKind.Aspect

+ Game.LambdaHack.Content.ItemKind: instance GHC.Classes.Ord Game.LambdaHack.Content.ItemKind.Effect

+ Game.LambdaHack.Content.ItemKind: instance GHC.Classes.Ord Game.LambdaHack.Content.ItemKind.EqpSlot

+ Game.LambdaHack.Content.ItemKind: instance GHC.Classes.Ord Game.LambdaHack.Content.ItemKind.Feature

+ Game.LambdaHack.Content.ItemKind: instance GHC.Classes.Ord Game.LambdaHack.Content.ItemKind.ThrowMod

+ Game.LambdaHack.Content.ItemKind: instance GHC.Classes.Ord Game.LambdaHack.Content.ItemKind.TimerDice

+ Game.LambdaHack.Content.ItemKind: instance GHC.Enum.Bounded Game.LambdaHack.Content.ItemKind.EqpSlot

+ Game.LambdaHack.Content.ItemKind: instance GHC.Enum.Enum Game.LambdaHack.Content.ItemKind.EqpSlot

+ Game.LambdaHack.Content.ItemKind: instance GHC.Generics.Generic Game.LambdaHack.Content.ItemKind.Aspect

+ Game.LambdaHack.Content.ItemKind: instance GHC.Generics.Generic Game.LambdaHack.Content.ItemKind.Effect

+ Game.LambdaHack.Content.ItemKind: instance GHC.Generics.Generic Game.LambdaHack.Content.ItemKind.EqpSlot

+ Game.LambdaHack.Content.ItemKind: instance GHC.Generics.Generic Game.LambdaHack.Content.ItemKind.Feature

+ Game.LambdaHack.Content.ItemKind: instance GHC.Generics.Generic Game.LambdaHack.Content.ItemKind.ThrowMod

+ Game.LambdaHack.Content.ItemKind: instance GHC.Generics.Generic Game.LambdaHack.Content.ItemKind.TimerDice

+ Game.LambdaHack.Content.ItemKind: instance GHC.Show.Show Game.LambdaHack.Content.ItemKind.Aspect

+ Game.LambdaHack.Content.ItemKind: instance GHC.Show.Show Game.LambdaHack.Content.ItemKind.Effect

+ Game.LambdaHack.Content.ItemKind: instance GHC.Show.Show Game.LambdaHack.Content.ItemKind.EqpSlot

+ Game.LambdaHack.Content.ItemKind: instance GHC.Show.Show Game.LambdaHack.Content.ItemKind.Feature

+ Game.LambdaHack.Content.ItemKind: instance GHC.Show.Show Game.LambdaHack.Content.ItemKind.ItemKind

+ Game.LambdaHack.Content.ItemKind: instance GHC.Show.Show Game.LambdaHack.Content.ItemKind.ThrowMod

+ Game.LambdaHack.Content.ItemKind: instance GHC.Show.Show Game.LambdaHack.Content.ItemKind.TimerDice

+ Game.LambdaHack.Content.ItemKind: toDmg :: Dice -> [(Int, Dice)]

+ Game.LambdaHack.Content.ModeKind: [autoDungeon] :: AutoLeader -> !Bool

+ Game.LambdaHack.Content.ModeKind: [autoLevel] :: AutoLeader -> !Bool

+ Game.LambdaHack.Content.ModeKind: [fcanEscape] :: Player -> !Bool

+ Game.LambdaHack.Content.ModeKind: [fgroups] :: Player -> ![GroupName ItemKind]

+ Game.LambdaHack.Content.ModeKind: [fhasGender] :: Player -> !Bool

+ Game.LambdaHack.Content.ModeKind: [fhasUI] :: Player -> !Bool

+ Game.LambdaHack.Content.ModeKind: [fhiCondPoly] :: Player -> !HiCondPoly

+ Game.LambdaHack.Content.ModeKind: [fleaderMode] :: Player -> !LeaderMode

+ Game.LambdaHack.Content.ModeKind: [fname] :: Player -> !Text

+ Game.LambdaHack.Content.ModeKind: [fneverEmpty] :: Player -> !Bool

+ Game.LambdaHack.Content.ModeKind: [fskillsOther] :: Player -> !Skills

+ Game.LambdaHack.Content.ModeKind: [ftactic] :: Player -> !Tactic

+ Game.LambdaHack.Content.ModeKind: [mcaves] :: ModeKind -> !Caves

+ Game.LambdaHack.Content.ModeKind: [mdesc] :: ModeKind -> !Text

+ Game.LambdaHack.Content.ModeKind: [mfreq] :: ModeKind -> !(Freqs ModeKind)

+ Game.LambdaHack.Content.ModeKind: [mname] :: ModeKind -> !Text

+ Game.LambdaHack.Content.ModeKind: [mroster] :: ModeKind -> !Roster

+ Game.LambdaHack.Content.ModeKind: [msymbol] :: ModeKind -> !Char

+ Game.LambdaHack.Content.ModeKind: [rosterAlly] :: Roster -> ![(Text, Text)]

+ Game.LambdaHack.Content.ModeKind: [rosterEnemy] :: Roster -> ![(Text, Text)]

+ Game.LambdaHack.Content.ModeKind: [rosterList] :: Roster -> ![(Player, [(Int, Dice, GroupName ItemKind)])]

+ Game.LambdaHack.Content.ModeKind: instance Data.Binary.Class.Binary Game.LambdaHack.Content.ModeKind.AutoLeader

+ Game.LambdaHack.Content.ModeKind: instance Data.Binary.Class.Binary Game.LambdaHack.Content.ModeKind.HiIndeterminant

+ Game.LambdaHack.Content.ModeKind: instance Data.Binary.Class.Binary Game.LambdaHack.Content.ModeKind.LeaderMode

+ Game.LambdaHack.Content.ModeKind: instance Data.Binary.Class.Binary Game.LambdaHack.Content.ModeKind.Outcome

+ Game.LambdaHack.Content.ModeKind: instance Data.Binary.Class.Binary Game.LambdaHack.Content.ModeKind.Player

+ Game.LambdaHack.Content.ModeKind: instance GHC.Classes.Eq Game.LambdaHack.Content.ModeKind.AutoLeader

+ Game.LambdaHack.Content.ModeKind: instance GHC.Classes.Eq Game.LambdaHack.Content.ModeKind.HiIndeterminant

+ Game.LambdaHack.Content.ModeKind: instance GHC.Classes.Eq Game.LambdaHack.Content.ModeKind.LeaderMode

+ Game.LambdaHack.Content.ModeKind: instance GHC.Classes.Eq Game.LambdaHack.Content.ModeKind.Outcome

+ Game.LambdaHack.Content.ModeKind: instance GHC.Classes.Eq Game.LambdaHack.Content.ModeKind.Player

+ Game.LambdaHack.Content.ModeKind: instance GHC.Classes.Eq Game.LambdaHack.Content.ModeKind.Roster

+ Game.LambdaHack.Content.ModeKind: instance GHC.Classes.Ord Game.LambdaHack.Content.ModeKind.AutoLeader

+ Game.LambdaHack.Content.ModeKind: instance GHC.Classes.Ord Game.LambdaHack.Content.ModeKind.HiIndeterminant

+ Game.LambdaHack.Content.ModeKind: instance GHC.Classes.Ord Game.LambdaHack.Content.ModeKind.LeaderMode

+ Game.LambdaHack.Content.ModeKind: instance GHC.Classes.Ord Game.LambdaHack.Content.ModeKind.Outcome

+ Game.LambdaHack.Content.ModeKind: instance GHC.Classes.Ord Game.LambdaHack.Content.ModeKind.Player

+ Game.LambdaHack.Content.ModeKind: instance GHC.Enum.Bounded Game.LambdaHack.Content.ModeKind.Outcome

+ Game.LambdaHack.Content.ModeKind: instance GHC.Enum.Enum Game.LambdaHack.Content.ModeKind.Outcome

+ Game.LambdaHack.Content.ModeKind: instance GHC.Generics.Generic Game.LambdaHack.Content.ModeKind.AutoLeader

+ Game.LambdaHack.Content.ModeKind: instance GHC.Generics.Generic Game.LambdaHack.Content.ModeKind.HiIndeterminant

+ Game.LambdaHack.Content.ModeKind: instance GHC.Generics.Generic Game.LambdaHack.Content.ModeKind.LeaderMode

+ Game.LambdaHack.Content.ModeKind: instance GHC.Generics.Generic Game.LambdaHack.Content.ModeKind.Outcome

+ Game.LambdaHack.Content.ModeKind: instance GHC.Generics.Generic Game.LambdaHack.Content.ModeKind.Player

+ Game.LambdaHack.Content.ModeKind: instance GHC.Show.Show Game.LambdaHack.Content.ModeKind.AutoLeader

+ Game.LambdaHack.Content.ModeKind: instance GHC.Show.Show Game.LambdaHack.Content.ModeKind.HiIndeterminant

+ Game.LambdaHack.Content.ModeKind: instance GHC.Show.Show Game.LambdaHack.Content.ModeKind.LeaderMode

+ Game.LambdaHack.Content.ModeKind: instance GHC.Show.Show Game.LambdaHack.Content.ModeKind.ModeKind

+ Game.LambdaHack.Content.ModeKind: instance GHC.Show.Show Game.LambdaHack.Content.ModeKind.Outcome

+ Game.LambdaHack.Content.ModeKind: instance GHC.Show.Show Game.LambdaHack.Content.ModeKind.Player

+ Game.LambdaHack.Content.ModeKind: instance GHC.Show.Show Game.LambdaHack.Content.ModeKind.Roster

+ Game.LambdaHack.Content.PlaceKind: CMirror :: Cover

+ Game.LambdaHack.Content.PlaceKind: [pcover] :: PlaceKind -> !Cover

+ Game.LambdaHack.Content.PlaceKind: [pfence] :: PlaceKind -> !Fence

+ Game.LambdaHack.Content.PlaceKind: [pfreq] :: PlaceKind -> !(Freqs PlaceKind)

+ Game.LambdaHack.Content.PlaceKind: [pname] :: PlaceKind -> !Text

+ Game.LambdaHack.Content.PlaceKind: [poverride] :: PlaceKind -> ![(Char, GroupName TileKind)]

+ Game.LambdaHack.Content.PlaceKind: [prarity] :: PlaceKind -> !Rarity

+ Game.LambdaHack.Content.PlaceKind: [psymbol] :: PlaceKind -> !Char

+ Game.LambdaHack.Content.PlaceKind: [ptopLeft] :: PlaceKind -> ![Text]

+ Game.LambdaHack.Content.PlaceKind: instance GHC.Classes.Eq Game.LambdaHack.Content.PlaceKind.Cover

+ Game.LambdaHack.Content.PlaceKind: instance GHC.Classes.Eq Game.LambdaHack.Content.PlaceKind.Fence

+ Game.LambdaHack.Content.PlaceKind: instance GHC.Show.Show Game.LambdaHack.Content.PlaceKind.Cover

+ Game.LambdaHack.Content.PlaceKind: instance GHC.Show.Show Game.LambdaHack.Content.PlaceKind.Fence

+ Game.LambdaHack.Content.PlaceKind: instance GHC.Show.Show Game.LambdaHack.Content.PlaceKind.PlaceKind

+ Game.LambdaHack.Content.RuleKind: [rcfgUIDefault] :: RuleKind -> !String

+ Game.LambdaHack.Content.RuleKind: [rcfgUIName] :: RuleKind -> !FilePath

+ Game.LambdaHack.Content.RuleKind: [rexeVersion] :: RuleKind -> !Version

+ Game.LambdaHack.Content.RuleKind: [rfirstDeathEnds] :: RuleKind -> !Bool

+ Game.LambdaHack.Content.RuleKind: [rfreq] :: RuleKind -> !(Freqs RuleKind)

+ Game.LambdaHack.Content.RuleKind: [rleadLevelClips] :: RuleKind -> !Int

+ Game.LambdaHack.Content.RuleKind: [rmainMenuArt] :: RuleKind -> !Text

+ Game.LambdaHack.Content.RuleKind: [rname] :: RuleKind -> !Text

+ Game.LambdaHack.Content.RuleKind: [rnearby] :: RuleKind -> !Int

+ Game.LambdaHack.Content.RuleKind: [rscoresFile] :: RuleKind -> !FilePath

+ Game.LambdaHack.Content.RuleKind: [rsymbol] :: RuleKind -> !Char

+ Game.LambdaHack.Content.RuleKind: [rtitle] :: RuleKind -> !Text

+ Game.LambdaHack.Content.RuleKind: [rwriteSaveClips] :: RuleKind -> !Int

+ Game.LambdaHack.Content.RuleKind: instance GHC.Show.Show Game.LambdaHack.Content.RuleKind.RuleKind

+ Game.LambdaHack.Content.TileKind: BuildAs :: !(GroupName TileKind) -> Feature

+ Game.LambdaHack.Content.TileKind: ConsideredByAI :: Feature

+ Game.LambdaHack.Content.TileKind: Indistinct :: Feature

+ Game.LambdaHack.Content.TileKind: ObscureAs :: !(GroupName TileKind) -> Feature

+ Game.LambdaHack.Content.TileKind: Spice :: Feature

+ Game.LambdaHack.Content.TileKind: Tab :: (Vector a) -> Tab a

+ Game.LambdaHack.Content.TileKind: TileSpeedup :: !(Tab Bool) -> !(Tab Bool) -> !(Tab Bool) -> !(Tab Bool) -> !(Tab Bool) -> !(Tab Bool) -> !(Tab Bool) -> !(Tab Bool) -> !(Tab Bool) -> !(Tab Bool) -> !(Tab Bool) -> !(Tab Bool) -> !(Tab Bool) -> !(Tab Word8) -> !(Tab Word8) -> TileSpeedup

+ Game.LambdaHack.Content.TileKind: [alterMinSkillTab] :: TileSpeedup -> !(Tab Word8)

+ Game.LambdaHack.Content.TileKind: [alterMinWalkTab] :: TileSpeedup -> !(Tab Word8)

+ Game.LambdaHack.Content.TileKind: [consideredByAITab] :: TileSpeedup -> !(Tab Bool)

+ Game.LambdaHack.Content.TileKind: [isChangableTab] :: TileSpeedup -> !(Tab Bool)

+ Game.LambdaHack.Content.TileKind: [isClearTab] :: TileSpeedup -> !(Tab Bool)

+ Game.LambdaHack.Content.TileKind: [isDoorTab] :: TileSpeedup -> !(Tab Bool)

+ Game.LambdaHack.Content.TileKind: [isEasyOpenTab] :: TileSpeedup -> !(Tab Bool)

+ Game.LambdaHack.Content.TileKind: [isHideAsTab] :: TileSpeedup -> !(Tab Bool)

+ Game.LambdaHack.Content.TileKind: [isLitTab] :: TileSpeedup -> !(Tab Bool)

+ Game.LambdaHack.Content.TileKind: [isNoActorTab] :: TileSpeedup -> !(Tab Bool)

+ Game.LambdaHack.Content.TileKind: [isNoItemTab] :: TileSpeedup -> !(Tab Bool)

+ Game.LambdaHack.Content.TileKind: [isOftenActorTab] :: TileSpeedup -> !(Tab Bool)

+ Game.LambdaHack.Content.TileKind: [isOftenItemTab] :: TileSpeedup -> !(Tab Bool)

+ Game.LambdaHack.Content.TileKind: [isSuspectTab] :: TileSpeedup -> !(Tab Bool)

+ Game.LambdaHack.Content.TileKind: [isWalkableTab] :: TileSpeedup -> !(Tab Bool)

+ Game.LambdaHack.Content.TileKind: [talter] :: TileKind -> !Word8

+ Game.LambdaHack.Content.TileKind: [tcolor2] :: TileKind -> !Color

+ Game.LambdaHack.Content.TileKind: [tcolor] :: TileKind -> !Color

+ Game.LambdaHack.Content.TileKind: [tfeature] :: TileKind -> ![Feature]

+ Game.LambdaHack.Content.TileKind: [tfreq] :: TileKind -> !(Freqs TileKind)

+ Game.LambdaHack.Content.TileKind: [tname] :: TileKind -> !Text

+ Game.LambdaHack.Content.TileKind: [tsymbol] :: TileKind -> !Char

+ Game.LambdaHack.Content.TileKind: data TileSpeedup

+ Game.LambdaHack.Content.TileKind: floorSymbol :: Char

+ Game.LambdaHack.Content.TileKind: instance Control.DeepSeq.NFData Game.LambdaHack.Content.TileKind.Feature

+ Game.LambdaHack.Content.TileKind: instance Data.Binary.Class.Binary Game.LambdaHack.Content.TileKind.Feature

+ Game.LambdaHack.Content.TileKind: instance Data.Hashable.Class.Hashable Game.LambdaHack.Content.TileKind.Feature

+ Game.LambdaHack.Content.TileKind: instance GHC.Classes.Eq Game.LambdaHack.Content.TileKind.Feature

+ Game.LambdaHack.Content.TileKind: instance GHC.Classes.Ord Game.LambdaHack.Content.TileKind.Feature

+ Game.LambdaHack.Content.TileKind: instance GHC.Generics.Generic Game.LambdaHack.Content.TileKind.Feature

+ Game.LambdaHack.Content.TileKind: instance GHC.Show.Show Game.LambdaHack.Content.TileKind.Feature

+ Game.LambdaHack.Content.TileKind: instance GHC.Show.Show Game.LambdaHack.Content.TileKind.TileKind

+ Game.LambdaHack.Content.TileKind: isClosableKind :: TileKind -> Bool

+ Game.LambdaHack.Content.TileKind: isOpenableKind :: TileKind -> Bool

+ Game.LambdaHack.Content.TileKind: isSuspectKind :: TileKind -> Bool

+ Game.LambdaHack.Content.TileKind: isUknownSpace :: Id TileKind -> Bool

+ Game.LambdaHack.Content.TileKind: newtype Tab a

+ Game.LambdaHack.Content.TileKind: talterForStairs :: Word8

+ Game.LambdaHack.Content.TileKind: unknownId :: Id TileKind

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: CliImplementation :: StateT CliState IO a -> CliImplementation a

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: CliState :: !State -> !StateClient -> !(Maybe SessionUI) -> !ChanServer -> !(ChanSave (State, StateClient, Maybe SessionUI)) -> CliState

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: [cliClient] :: CliState -> !StateClient

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: [cliDict] :: CliState -> !ChanServer

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: [cliSession] :: CliState -> !(Maybe SessionUI)

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: [cliState] :: CliState -> !State

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: [cliToSave] :: CliState -> !(ChanSave (State, StateClient, Maybe SessionUI))

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: [runCliImplementation] :: CliImplementation a -> StateT CliState IO a

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: data CliState

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: instance GHC.Base.Applicative Game.LambdaHack.SampleImplementation.SampleMonadClient.CliImplementation

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: instance GHC.Base.Functor Game.LambdaHack.SampleImplementation.SampleMonadClient.CliImplementation

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: instance GHC.Base.Monad Game.LambdaHack.SampleImplementation.SampleMonadClient.CliImplementation

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: instance GHC.Generics.Generic Game.LambdaHack.SampleImplementation.SampleMonadClient.CliState

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: instance Game.LambdaHack.Atomic.MonadAtomic.MonadAtomic Game.LambdaHack.SampleImplementation.SampleMonadClient.CliImplementation

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: instance Game.LambdaHack.Atomic.MonadStateWrite.MonadStateWrite Game.LambdaHack.SampleImplementation.SampleMonadClient.CliImplementation

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: instance Game.LambdaHack.Client.HandleResponseM.MonadClientReadResponse Game.LambdaHack.SampleImplementation.SampleMonadClient.CliImplementation

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: instance Game.LambdaHack.Client.HandleResponseM.MonadClientWriteRequest Game.LambdaHack.SampleImplementation.SampleMonadClient.CliImplementation

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: instance Game.LambdaHack.Client.MonadClient.MonadClient Game.LambdaHack.SampleImplementation.SampleMonadClient.CliImplementation

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: instance Game.LambdaHack.Client.MonadClient.MonadClientSetup Game.LambdaHack.SampleImplementation.SampleMonadClient.CliImplementation

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: instance Game.LambdaHack.Client.UI.MonadClientUI.MonadClientUI Game.LambdaHack.SampleImplementation.SampleMonadClient.CliImplementation

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: instance Game.LambdaHack.Common.MonadStateRead.MonadStateRead Game.LambdaHack.SampleImplementation.SampleMonadClient.CliImplementation

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: newtype CliImplementation a

+ Game.LambdaHack.SampleImplementation.SampleMonadServer: SerImplementation :: StateT SerState IO a -> SerImplementation a

+ Game.LambdaHack.SampleImplementation.SampleMonadServer: SerState :: !State -> !StateServer -> !ConnServerDict -> !(ChanSave (State, StateServer)) -> SerState

+ Game.LambdaHack.SampleImplementation.SampleMonadServer: [runSerImplementation] :: SerImplementation a -> StateT SerState IO a

+ Game.LambdaHack.SampleImplementation.SampleMonadServer: [serDict] :: SerState -> !ConnServerDict

+ Game.LambdaHack.SampleImplementation.SampleMonadServer: [serServer] :: SerState -> !StateServer

+ Game.LambdaHack.SampleImplementation.SampleMonadServer: [serState] :: SerState -> !State

+ Game.LambdaHack.SampleImplementation.SampleMonadServer: [serToSave] :: SerState -> !(ChanSave (State, StateServer))

+ Game.LambdaHack.SampleImplementation.SampleMonadServer: data SerState

+ Game.LambdaHack.SampleImplementation.SampleMonadServer: instance GHC.Base.Applicative Game.LambdaHack.SampleImplementation.SampleMonadServer.SerImplementation

+ Game.LambdaHack.SampleImplementation.SampleMonadServer: instance GHC.Base.Functor Game.LambdaHack.SampleImplementation.SampleMonadServer.SerImplementation

+ Game.LambdaHack.SampleImplementation.SampleMonadServer: instance GHC.Base.Monad Game.LambdaHack.SampleImplementation.SampleMonadServer.SerImplementation

+ Game.LambdaHack.SampleImplementation.SampleMonadServer: instance Game.LambdaHack.Atomic.MonadAtomic.MonadAtomic Game.LambdaHack.SampleImplementation.SampleMonadServer.SerImplementation

+ Game.LambdaHack.SampleImplementation.SampleMonadServer: instance Game.LambdaHack.Atomic.MonadStateWrite.MonadStateWrite Game.LambdaHack.SampleImplementation.SampleMonadServer.SerImplementation

+ Game.LambdaHack.SampleImplementation.SampleMonadServer: instance Game.LambdaHack.Common.MonadStateRead.MonadStateRead Game.LambdaHack.SampleImplementation.SampleMonadServer.SerImplementation

+ Game.LambdaHack.SampleImplementation.SampleMonadServer: instance Game.LambdaHack.Server.MonadServer.MonadServer Game.LambdaHack.SampleImplementation.SampleMonadServer.SerImplementation

+ Game.LambdaHack.SampleImplementation.SampleMonadServer: instance Game.LambdaHack.Server.ProtocolM.MonadServerReadRequest Game.LambdaHack.SampleImplementation.SampleMonadServer.SerImplementation

+ Game.LambdaHack.SampleImplementation.SampleMonadServer: newtype SerImplementation a

+ Game.LambdaHack.Server: DebugModeSer :: !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !(Maybe (GroupName ModeKind)) -> !Bool -> !Bool -> !(Maybe StdGen) -> !(Maybe StdGen) -> !Bool -> !Challenge -> !Bool -> !String -> !Bool -> !DebugModeCli -> DebugModeSer

+ Game.LambdaHack.Server: [sallClear] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server: [sautomateAll] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server: [sboostRandomItem] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server: [scurChalSer] :: DebugModeSer -> !Challenge

+ Game.LambdaHack.Server: [sdbgMsgSer] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server: [sdebugCli] :: DebugModeSer -> !DebugModeCli

+ Game.LambdaHack.Server: [sdumpInitRngs] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server: [sdungeonRng] :: DebugModeSer -> !(Maybe StdGen)

+ Game.LambdaHack.Server: [sgameMode] :: DebugModeSer -> !(Maybe (GroupName ModeKind))

+ Game.LambdaHack.Server: [skeepAutomated] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server: [sknowEvents] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server: [sknowItems] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server: [sknowMap] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server: [smainRng] :: DebugModeSer -> !(Maybe StdGen)

+ Game.LambdaHack.Server: [snewGameSer] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server: [sniffIn] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server: [sniffOut] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server: [ssavePrefixSer] :: DebugModeSer -> !String

+ Game.LambdaHack.Server: data DebugModeSer

+ Game.LambdaHack.Server.BroadcastAtomic: atomicRemember :: LevelId -> Perception -> State -> [UpdAtomic]

+ Game.LambdaHack.Server.BroadcastAtomic: handleAndBroadcast :: (MonadStateWrite m, MonadServerReadRequest m) => CmdAtomic -> m ()

+ Game.LambdaHack.Server.BroadcastAtomic: handleCmdAtomicServer :: MonadStateWrite m => PosAtomic -> UpdAtomic -> m ()

+ Game.LambdaHack.Server.BroadcastAtomic: sendPer :: MonadServerReadRequest m => FactionId -> LevelId -> Perception -> Perception -> Perception -> m ()

+ Game.LambdaHack.Server.CommonM: addActor :: (MonadAtomic m, MonadServer m) => GroupName ItemKind -> FactionId -> Point -> LevelId -> (Actor -> Actor) -> Time -> m (Maybe ActorId)

+ Game.LambdaHack.Server.CommonM: addActorIid :: (MonadAtomic m, MonadServer m) => ItemId -> ItemFull -> Bool -> FactionId -> Point -> LevelId -> (Actor -> Actor) -> Time -> m (Maybe ActorId)

+ Game.LambdaHack.Server.CommonM: currentSkillsServer :: MonadServer m => ActorId -> m Skills

+ Game.LambdaHack.Server.CommonM: deduceKilled :: (MonadAtomic m, MonadServer m) => ActorId -> m ()

+ Game.LambdaHack.Server.CommonM: deduceQuits :: (MonadAtomic m, MonadServer m) => FactionId -> Status -> m ()

+ Game.LambdaHack.Server.CommonM: electLeader :: MonadAtomic m => FactionId -> LevelId -> ActorId -> m ()

+ Game.LambdaHack.Server.CommonM: execFailure :: (MonadAtomic m, MonadServer m) => ActorId -> RequestTimed a -> ReqFailure -> m ()

+ Game.LambdaHack.Server.CommonM: getPerFid :: MonadServer m => FactionId -> LevelId -> m Perception

+ Game.LambdaHack.Server.CommonM: moveStores :: (MonadAtomic m, MonadServer m) => Bool -> ActorId -> CStore -> CStore -> m ()

+ Game.LambdaHack.Server.CommonM: pickWeaponServer :: MonadServer m => ActorId -> m (Maybe (ItemId, CStore))

+ Game.LambdaHack.Server.CommonM: projectFail :: (MonadAtomic m, MonadServer m) => ActorId -> Point -> Int -> ItemId -> CStore -> Bool -> m (Maybe ReqFailure)

+ Game.LambdaHack.Server.CommonM: recomputeCachePer :: MonadServer m => FactionId -> LevelId -> m Perception

+ Game.LambdaHack.Server.CommonM: revealItems :: (MonadAtomic m, MonadServer m) => Maybe FactionId -> m ()

+ Game.LambdaHack.Server.CommonM: supplantLeader :: MonadAtomic m => FactionId -> ActorId -> m ()

+ Game.LambdaHack.Server.DebugM: debugRequestAI :: MonadServer m => ActorId -> RequestAI -> m ()

+ Game.LambdaHack.Server.DebugM: debugRequestUI :: MonadServer m => ActorId -> RequestUI -> m ()

+ Game.LambdaHack.Server.DebugM: debugResponse :: MonadServer m => FactionId -> Response -> m ()

+ Game.LambdaHack.Server.DebugM: instance GHC.Show.Show a => GHC.Show.Show (Game.LambdaHack.Server.DebugM.DebugAid a)

+ Game.LambdaHack.Server.DungeonGen: [freshDungeon] :: FreshDungeon -> !Dungeon

+ Game.LambdaHack.Server.DungeonGen: [freshTotalDepth] :: FreshDungeon -> !AbsDepth

+ Game.LambdaHack.Server.DungeonGen: placeDownStairs :: CaveKind -> [Point] -> Rnd Point

+ Game.LambdaHack.Server.DungeonGen.Area: SpecialArea :: !Area -> SpecialArea

+ Game.LambdaHack.Server.DungeonGen.Area: SpecialFixed :: !Point -> !(GroupName PlaceKind) -> !Area -> SpecialArea

+ Game.LambdaHack.Server.DungeonGen.Area: SpecialMerged :: !SpecialArea -> !Point -> SpecialArea

+ Game.LambdaHack.Server.DungeonGen.Area: data SpecialArea

+ Game.LambdaHack.Server.DungeonGen.Area: expand :: Area -> Area

+ Game.LambdaHack.Server.DungeonGen.Area: instance Data.Binary.Class.Binary Game.LambdaHack.Server.DungeonGen.Area.Area

+ Game.LambdaHack.Server.DungeonGen.Area: instance GHC.Classes.Eq Game.LambdaHack.Server.DungeonGen.Area.Area

+ Game.LambdaHack.Server.DungeonGen.Area: instance GHC.Show.Show Game.LambdaHack.Server.DungeonGen.Area.Area

+ Game.LambdaHack.Server.DungeonGen.Area: instance GHC.Show.Show Game.LambdaHack.Server.DungeonGen.Area.SpecialArea

+ Game.LambdaHack.Server.DungeonGen.Area: isTrivialArea :: Area -> Bool

+ Game.LambdaHack.Server.DungeonGen.Area: sumAreas :: Area -> Area -> Area

+ Game.LambdaHack.Server.DungeonGen.AreaRnd: Horiz :: HV

+ Game.LambdaHack.Server.DungeonGen.AreaRnd: Vert :: HV

+ Game.LambdaHack.Server.DungeonGen.AreaRnd: data HV

+ Game.LambdaHack.Server.DungeonGen.AreaRnd: instance GHC.Classes.Eq Game.LambdaHack.Server.DungeonGen.AreaRnd.HV

+ Game.LambdaHack.Server.DungeonGen.AreaRnd: mkFixed :: (X, Y) -> Area -> Point -> Area

+ Game.LambdaHack.Server.DungeonGen.Cave: [dkind] :: Cave -> !(Id CaveKind)

+ Game.LambdaHack.Server.DungeonGen.Cave: [dmap] :: Cave -> !TileMapEM

+ Game.LambdaHack.Server.DungeonGen.Cave: [dnight] :: Cave -> !Bool

+ Game.LambdaHack.Server.DungeonGen.Cave: [dplaces] :: Cave -> ![Place]

+ Game.LambdaHack.Server.DungeonGen.Cave: [dsecret] :: Cave -> !Int

+ Game.LambdaHack.Server.DungeonGen.Cave: bootFixedCenters :: CaveKind -> [Point]

+ Game.LambdaHack.Server.DungeonGen.Cave: instance GHC.Show.Show Game.LambdaHack.Server.DungeonGen.Cave.Cave

+ Game.LambdaHack.Server.DungeonGen.Place: [qFFloor] :: Place -> !(Id TileKind)

+ Game.LambdaHack.Server.DungeonGen.Place: [qFGround] :: Place -> !(Id TileKind)

+ Game.LambdaHack.Server.DungeonGen.Place: [qFWall] :: Place -> !(Id TileKind)

+ Game.LambdaHack.Server.DungeonGen.Place: [qarea] :: Place -> !Area

+ Game.LambdaHack.Server.DungeonGen.Place: [qkind] :: Place -> !(Id PlaceKind)

+ Game.LambdaHack.Server.DungeonGen.Place: [qlegend] :: Place -> !(GroupName TileKind)

+ Game.LambdaHack.Server.DungeonGen.Place: [qseen] :: Place -> !Bool

+ Game.LambdaHack.Server.DungeonGen.Place: instance Data.Binary.Class.Binary Game.LambdaHack.Server.DungeonGen.Place.Place

+ Game.LambdaHack.Server.DungeonGen.Place: instance GHC.Show.Show Game.LambdaHack.Server.DungeonGen.Place.Place

+ Game.LambdaHack.Server.DungeonGen.Place: isChancePos :: Int -> Int -> Point -> Bool

+ Game.LambdaHack.Server.EndM: dieSer :: (MonadAtomic m, MonadServer m) => ActorId -> Actor -> m ()

+ Game.LambdaHack.Server.EndM: endOrLoop :: (MonadAtomic m, MonadServer m) => m () -> (Maybe (GroupName ModeKind) -> m ()) -> m () -> m () -> m ()

+ Game.LambdaHack.Server.Fov: CacheBeforeLucid :: !PerReachable -> !PerVisible -> !PerSmelled -> CacheBeforeLucid

+ Game.LambdaHack.Server.Fov: FovClear :: Array Bool -> FovClear

+ Game.LambdaHack.Server.Fov: FovInvalid :: FovValid a

+ Game.LambdaHack.Server.Fov: FovLit :: EnumSet Point -> FovLit

+ Game.LambdaHack.Server.Fov: FovLucid :: EnumSet Point -> FovLucid

+ Game.LambdaHack.Server.Fov: FovShine :: EnumMap Point Int -> FovShine

+ Game.LambdaHack.Server.Fov: FovValid :: !a -> FovValid a

+ Game.LambdaHack.Server.Fov: PerReachable :: EnumSet Point -> PerReachable

+ Game.LambdaHack.Server.Fov: PerceptionCache :: !(FovValid CacheBeforeLucid) -> !PerActor -> PerceptionCache

+ Game.LambdaHack.Server.Fov: [cnocto] :: CacheBeforeLucid -> !PerVisible

+ Game.LambdaHack.Server.Fov: [creachable] :: CacheBeforeLucid -> !PerReachable

+ Game.LambdaHack.Server.Fov: [csmell] :: CacheBeforeLucid -> !PerSmelled

+ Game.LambdaHack.Server.Fov: [fovClear] :: FovClear -> Array Bool

+ Game.LambdaHack.Server.Fov: [fovLit] :: FovLit -> EnumSet Point

+ Game.LambdaHack.Server.Fov: [fovLucid] :: FovLucid -> EnumSet Point

+ Game.LambdaHack.Server.Fov: [fovShine] :: FovShine -> EnumMap Point Int

+ Game.LambdaHack.Server.Fov: [perActor] :: PerceptionCache -> !PerActor

+ Game.LambdaHack.Server.Fov: [preachable] :: PerReachable -> EnumSet Point

+ Game.LambdaHack.Server.Fov: [ptotal] :: PerceptionCache -> !(FovValid CacheBeforeLucid)

+ Game.LambdaHack.Server.Fov: aspectRecordFromActorServer :: DiscoveryAspect -> Actor -> AspectRecord

+ Game.LambdaHack.Server.Fov: boundSightByCalm :: Int -> Int64 -> Int

+ Game.LambdaHack.Server.Fov: cacheBeforeLucidFromActor :: FovClear -> Actor -> AspectRecord -> CacheBeforeLucid

+ Game.LambdaHack.Server.Fov: clearFromLevel :: COps -> Level -> FovClear

+ Game.LambdaHack.Server.Fov: clearInDungeon :: State -> FovClearLid

+ Game.LambdaHack.Server.Fov: data CacheBeforeLucid

+ Game.LambdaHack.Server.Fov: data FovValid a

+ Game.LambdaHack.Server.Fov: data PerceptionCache

+ Game.LambdaHack.Server.Fov: floorLightSources :: DiscoveryAspect -> Level -> [(Point, Int)]

+ Game.LambdaHack.Server.Fov: fullscan :: FovClear -> Int -> Point -> EnumSet Point

+ Game.LambdaHack.Server.Fov: instance GHC.Classes.Eq Game.LambdaHack.Server.Fov.CacheBeforeLucid

+ Game.LambdaHack.Server.Fov: instance GHC.Classes.Eq Game.LambdaHack.Server.Fov.FovClear

+ Game.LambdaHack.Server.Fov: instance GHC.Classes.Eq Game.LambdaHack.Server.Fov.FovLit

+ Game.LambdaHack.Server.Fov: instance GHC.Classes.Eq Game.LambdaHack.Server.Fov.FovLucid

+ Game.LambdaHack.Server.Fov: instance GHC.Classes.Eq Game.LambdaHack.Server.Fov.FovShine

+ Game.LambdaHack.Server.Fov: instance GHC.Classes.Eq Game.LambdaHack.Server.Fov.PerReachable

+ Game.LambdaHack.Server.Fov: instance GHC.Classes.Eq Game.LambdaHack.Server.Fov.PerceptionCache

+ Game.LambdaHack.Server.Fov: instance GHC.Classes.Eq a => GHC.Classes.Eq (Game.LambdaHack.Server.Fov.FovValid a)

+ Game.LambdaHack.Server.Fov: instance GHC.Show.Show Game.LambdaHack.Server.Fov.CacheBeforeLucid

+ Game.LambdaHack.Server.Fov: instance GHC.Show.Show Game.LambdaHack.Server.Fov.FovClear

+ Game.LambdaHack.Server.Fov: instance GHC.Show.Show Game.LambdaHack.Server.Fov.FovLit

+ Game.LambdaHack.Server.Fov: instance GHC.Show.Show Game.LambdaHack.Server.Fov.FovLucid

+ Game.LambdaHack.Server.Fov: instance GHC.Show.Show Game.LambdaHack.Server.Fov.FovShine

+ Game.LambdaHack.Server.Fov: instance GHC.Show.Show Game.LambdaHack.Server.Fov.PerReachable

+ Game.LambdaHack.Server.Fov: instance GHC.Show.Show Game.LambdaHack.Server.Fov.PerceptionCache

+ Game.LambdaHack.Server.Fov: instance GHC.Show.Show a => GHC.Show.Show (Game.LambdaHack.Server.Fov.FovValid a)

+ Game.LambdaHack.Server.Fov: litFromLevel :: COps -> Level -> FovLit

+ Game.LambdaHack.Server.Fov: lucidFromItems :: FovClear -> [(Point, Int)] -> [FovLucid]

+ Game.LambdaHack.Server.Fov: lucidFromLevel :: DiscoveryAspect -> ActorAspect -> FovClearLid -> FovLitLid -> State -> LevelId -> Level -> FovLucid

+ Game.LambdaHack.Server.Fov: lucidInDungeon :: DiscoveryAspect -> ActorAspect -> FovClearLid -> FovLitLid -> State -> FovLucidLid

+ Game.LambdaHack.Server.Fov: newtype FovClear

+ Game.LambdaHack.Server.Fov: newtype FovLit

+ Game.LambdaHack.Server.Fov: newtype FovLucid

+ Game.LambdaHack.Server.Fov: newtype FovShine

+ Game.LambdaHack.Server.Fov: newtype PerReachable

+ Game.LambdaHack.Server.Fov: perActorFromLevel :: PerActor -> (ActorId -> Actor) -> ActorAspect -> FovClear -> PerActor

+ Game.LambdaHack.Server.Fov: perFidInDungeon :: DiscoveryAspect -> State -> (ActorAspect, FovLitLid, FovClearLid, FovLucidLid, PerValidFid, PerCacheFid, PerFid)

+ Game.LambdaHack.Server.Fov: perLidFromFaction :: ActorAspect -> FovLucidLid -> FovClearLid -> FactionId -> State -> (PerLid, PerCacheLid)

+ Game.LambdaHack.Server.Fov: perceptionCacheFromLevel :: ActorAspect -> FovClearLid -> FactionId -> LevelId -> State -> PerceptionCache

+ Game.LambdaHack.Server.Fov: perceptionFromPTotal :: FovLucid -> CacheBeforeLucid -> Perception

+ Game.LambdaHack.Server.Fov: shineFromLevel :: DiscoveryAspect -> ActorAspect -> State -> LevelId -> Level -> FovShine

+ Game.LambdaHack.Server.Fov: totalFromPerActor :: PerActor -> CacheBeforeLucid

+ Game.LambdaHack.Server.Fov: type FovClearLid = EnumMap LevelId FovClear

+ Game.LambdaHack.Server.Fov: type FovLitLid = EnumMap LevelId FovLit

+ Game.LambdaHack.Server.Fov: type FovLucidLid = EnumMap LevelId (FovValid FovLucid)

+ Game.LambdaHack.Server.Fov: type PerActor = EnumMap ActorId (FovValid CacheBeforeLucid)

+ Game.LambdaHack.Server.Fov: type PerCacheFid = EnumMap FactionId PerCacheLid

+ Game.LambdaHack.Server.Fov: type PerCacheLid = EnumMap LevelId PerceptionCache

+ Game.LambdaHack.Server.Fov: type PerValidFid = EnumMap FactionId (EnumMap LevelId Bool)

+ Game.LambdaHack.Server.FovDigital: B :: !Int -> !Int -> Bump

+ Game.LambdaHack.Server.FovDigital: Line :: !Bump -> !Bump -> Line

+ Game.LambdaHack.Server.FovDigital: [bx] :: Bump -> !Int

+ Game.LambdaHack.Server.FovDigital: [by] :: Bump -> !Int

+ Game.LambdaHack.Server.FovDigital: _debugLine :: Line -> (Bool, String)

+ Game.LambdaHack.Server.FovDigital: _debugSteeper :: Bump -> Bump -> Bump -> Ordering

+ Game.LambdaHack.Server.FovDigital: addHull :: (Bump -> Bump -> Ordering) -> Bump -> ConvexHull -> ConvexHull

+ Game.LambdaHack.Server.FovDigital: data Bump

+ Game.LambdaHack.Server.FovDigital: data Line

+ Game.LambdaHack.Server.FovDigital: dline :: Bump -> Bump -> Line

+ Game.LambdaHack.Server.FovDigital: dsteeper :: Bump -> Bump -> Bump -> Ordering

+ Game.LambdaHack.Server.FovDigital: instance GHC.Show.Show Game.LambdaHack.Server.FovDigital.Bump

+ Game.LambdaHack.Server.FovDigital: instance GHC.Show.Show Game.LambdaHack.Server.FovDigital.Line

+ Game.LambdaHack.Server.FovDigital: intersect :: Line -> Distance -> (Int, Int)

+ Game.LambdaHack.Server.FovDigital: scan :: EnumSet Point -> Distance -> Array Bool -> (Bump -> Point) -> EnumSet Point

+ Game.LambdaHack.Server.FovDigital: steeper :: Bump -> Bump -> Bump -> Ordering

+ Game.LambdaHack.Server.FovDigital: type ConvexHull = [Bump]

+ Game.LambdaHack.Server.FovDigital: type Distance = Int

+ Game.LambdaHack.Server.FovDigital: type Edge = (Line, ConvexHull)

+ Game.LambdaHack.Server.FovDigital: type EdgeInterval = (Edge, Edge)

+ Game.LambdaHack.Server.FovDigital: type Progress = Int

+ Game.LambdaHack.Server.HandleAtomicM: actorHasShine :: ActorAspect -> ActorId -> Bool

+ Game.LambdaHack.Server.HandleAtomicM: addItemToActor :: MonadServer m => ItemId -> Int -> ActorId -> m ()

+ Game.LambdaHack.Server.HandleAtomicM: addPerActor :: MonadServer m => ActorId -> Actor -> m ()

+ Game.LambdaHack.Server.HandleAtomicM: addPerActorAny :: MonadServer m => ActorId -> Actor -> m ()

+ Game.LambdaHack.Server.HandleAtomicM: cmdAtomicSemSer :: MonadServer m => UpdAtomic -> m ()

+ Game.LambdaHack.Server.HandleAtomicM: deletePerActor :: MonadServer m => ActorId -> Actor -> m ()

+ Game.LambdaHack.Server.HandleAtomicM: deletePerActorAny :: MonadServer m => ActorId -> Actor -> m ()

+ Game.LambdaHack.Server.HandleAtomicM: invalidateLucidAid :: MonadServer m => ActorId -> m ()

+ Game.LambdaHack.Server.HandleAtomicM: invalidateLucidLid :: MonadServer m => LevelId -> m ()

+ Game.LambdaHack.Server.HandleAtomicM: invalidatePerActor :: MonadServer m => ActorId -> m ()

+ Game.LambdaHack.Server.HandleAtomicM: invalidatePerLid :: MonadServer m => LevelId -> m ()

+ Game.LambdaHack.Server.HandleAtomicM: itemAffectsPerRadius :: DiscoveryAspect -> ItemId -> Bool

+ Game.LambdaHack.Server.HandleAtomicM: itemAffectsShineRadius :: DiscoveryAspect -> ItemId -> [CStore] -> Bool

+ Game.LambdaHack.Server.HandleAtomicM: reconsiderPerActor :: MonadServer m => ActorId -> m ()

+ Game.LambdaHack.Server.HandleAtomicM: updateSclear :: MonadServer m => LevelId -> Point -> Id TileKind -> Id TileKind -> m Bool

+ Game.LambdaHack.Server.HandleAtomicM: updateSlit :: MonadServer m => LevelId -> Point -> Id TileKind -> Id TileKind -> m Bool

+ Game.LambdaHack.Server.HandleEffectM: applyItem :: (MonadAtomic m, MonadServer m) => ActorId -> ItemId -> CStore -> m ()

+ Game.LambdaHack.Server.HandleEffectM: cutCalm :: (MonadAtomic m, MonadServer m) => ActorId -> m ()

+ Game.LambdaHack.Server.HandleEffectM: dominateFidSfx :: (MonadAtomic m, MonadServer m) => FactionId -> ActorId -> m Bool

+ Game.LambdaHack.Server.HandleEffectM: dropCStoreItem :: (MonadAtomic m, MonadServer m) => Bool -> CStore -> ActorId -> Actor -> Int -> ItemId -> ItemQuant -> m ()

+ Game.LambdaHack.Server.HandleEffectM: effectAndDestroy :: (MonadAtomic m, MonadServer m) => Bool -> ActorId -> ActorId -> ItemId -> Container -> Bool -> [Effect] -> ItemFull -> m ()

+ Game.LambdaHack.Server.HandleEffectM: itemEffectEmbedded :: (MonadAtomic m, MonadServer m) => ActorId -> Point -> ItemBag -> m ()

+ Game.LambdaHack.Server.HandleEffectM: meleeEffectAndDestroy :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> ItemId -> Container -> m ()

+ Game.LambdaHack.Server.HandleEffectM: pickDroppable :: MonadStateRead m => ActorId -> Actor -> m Container

+ Game.LambdaHack.Server.HandleRequestM: affectSmell :: (MonadAtomic m, MonadServer m) => ActorId -> m ()

+ Game.LambdaHack.Server.HandleRequestM: computeRndTimeout :: Time -> ItemId -> ItemFull -> Rnd (Maybe Time)

+ Game.LambdaHack.Server.HandleRequestM: handleRequestAI :: (MonadAtomic m) => ReqAI -> m (Maybe RequestAnyAbility)

+ Game.LambdaHack.Server.HandleRequestM: handleRequestTimed :: (MonadAtomic m, MonadServer m) => FactionId -> ActorId -> RequestTimed a -> m Bool

+ Game.LambdaHack.Server.HandleRequestM: handleRequestTimedCases :: (MonadAtomic m, MonadServer m) => ActorId -> RequestTimed a -> m ()

+ Game.LambdaHack.Server.HandleRequestM: handleRequestUI :: (MonadAtomic m, MonadServer m) => FactionId -> ActorId -> ReqUI -> m (Maybe RequestAnyAbility)

+ Game.LambdaHack.Server.HandleRequestM: reqAlter :: (MonadAtomic m, MonadServer m) => ActorId -> Point -> m ()

+ Game.LambdaHack.Server.HandleRequestM: reqApply :: (MonadAtomic m, MonadServer m) => ActorId -> ItemId -> CStore -> m ()

+ Game.LambdaHack.Server.HandleRequestM: reqAutomate :: MonadAtomic m => FactionId -> m ()

+ Game.LambdaHack.Server.HandleRequestM: reqDisplace :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m ()

+ Game.LambdaHack.Server.HandleRequestM: reqGameExit :: (MonadAtomic m, MonadServer m) => ActorId -> m ()

+ Game.LambdaHack.Server.HandleRequestM: reqGameRestart :: (MonadAtomic m, MonadServer m) => ActorId -> GroupName ModeKind -> Challenge -> m ()

+ Game.LambdaHack.Server.HandleRequestM: reqGameSave :: MonadServer m => m ()

+ Game.LambdaHack.Server.HandleRequestM: reqMelee :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> ItemId -> CStore -> m ()

+ Game.LambdaHack.Server.HandleRequestM: reqMove :: (MonadAtomic m, MonadServer m) => ActorId -> Vector -> m ()

+ Game.LambdaHack.Server.HandleRequestM: reqMoveItem :: (MonadAtomic m, MonadServer m) => ActorId -> Bool -> (ItemId, Int, CStore, CStore) -> m ()

+ Game.LambdaHack.Server.HandleRequestM: reqMoveItems :: (MonadAtomic m, MonadServer m) => ActorId -> [(ItemId, Int, CStore, CStore)] -> m ()

+ Game.LambdaHack.Server.HandleRequestM: reqProject :: (MonadAtomic m, MonadServer m) => ActorId -> Point -> Int -> ItemId -> CStore -> m ()

+ Game.LambdaHack.Server.HandleRequestM: reqTactic :: MonadAtomic m => FactionId -> Tactic -> m ()

+ Game.LambdaHack.Server.HandleRequestM: reqWait :: MonadAtomic m => ActorId -> m ()

+ Game.LambdaHack.Server.HandleRequestM: setBWait :: (MonadAtomic m) => RequestTimed a -> ActorId -> m (Maybe Bool)

+ Game.LambdaHack.Server.HandleRequestM: switchLeader :: (MonadAtomic m, MonadServer m) => FactionId -> ActorId -> m ()

+ Game.LambdaHack.Server.ItemM: embedItemsInDungeon :: (MonadAtomic m, MonadServer m) => m ()

+ Game.LambdaHack.Server.ItemM: fullAssocsServer :: MonadServer m => ActorId -> [CStore] -> m [(ItemId, ItemFull)]

+ Game.LambdaHack.Server.ItemM: itemToFullServer :: MonadServer m => m (ItemId -> ItemQuant -> ItemFull)

+ Game.LambdaHack.Server.ItemM: mapActorCStore_ :: MonadServer m => CStore -> (ItemId -> ItemQuant -> m a) -> Actor -> m ()

+ Game.LambdaHack.Server.ItemM: placeItemsInDungeon :: forall m. (MonadAtomic m, MonadServer m) => m ()

+ Game.LambdaHack.Server.ItemM: registerItem :: (MonadAtomic m, MonadServer m) => ItemFull -> ItemKnown -> ItemSeed -> Container -> Bool -> m ItemId

+ Game.LambdaHack.Server.ItemM: rollAndRegisterItem :: (MonadAtomic m, MonadServer m) => LevelId -> Freqs ItemKind -> Container -> Bool -> Maybe Int -> m (Maybe (ItemId, (ItemFull, GroupName ItemKind)))

+ Game.LambdaHack.Server.ItemM: rollItem :: (MonadAtomic m, MonadServer m) => Int -> LevelId -> Freqs ItemKind -> m (Maybe (ItemKnown, ItemFull, ItemDisco, ItemSeed, GroupName ItemKind))

+ Game.LambdaHack.Server.ItemRev: instance Data.Binary.Class.Binary Game.LambdaHack.Server.ItemRev.FlavourMap

+ Game.LambdaHack.Server.ItemRev: instance GHC.Show.Show Game.LambdaHack.Server.ItemRev.FlavourMap

+ Game.LambdaHack.Server.ItemRev: type ItemKnown = (ItemKindIx, AspectRecord, Dice, Maybe FactionId)

+ Game.LambdaHack.Server.LoopM: applyPeriodicLevel :: (MonadAtomic m, MonadServer m) => m ()

+ Game.LambdaHack.Server.LoopM: arenasForLoop :: MonadStateRead m => m [LevelId]

+ Game.LambdaHack.Server.LoopM: endClip :: forall m. (MonadAtomic m, MonadServer m) => (FactionId -> m ()) -> m ()

+ Game.LambdaHack.Server.LoopM: factionArena :: MonadStateRead m => Faction -> m (Maybe LevelId)

+ Game.LambdaHack.Server.LoopM: gameExit :: (MonadAtomic m, MonadServerReadRequest m) => m ()

+ Game.LambdaHack.Server.LoopM: hActors :: forall m. (MonadAtomic m, MonadServerReadRequest m) => FactionId -> [(ActorId, Actor)] -> m Bool

+ Game.LambdaHack.Server.LoopM: hTrajectories :: (MonadAtomic m, MonadServer m) => (ActorId, Actor) -> m ()

+ Game.LambdaHack.Server.LoopM: handleActors :: (MonadAtomic m, MonadServerReadRequest m) => LevelId -> FactionId -> m Bool

+ Game.LambdaHack.Server.LoopM: handleFidUpd :: (MonadAtomic m, MonadServerReadRequest m) => Bool -> (FactionId -> m ()) -> FactionId -> Faction -> m Bool

+ Game.LambdaHack.Server.LoopM: handleTrajectories :: (MonadAtomic m, MonadServer m) => LevelId -> FactionId -> m ()

+ Game.LambdaHack.Server.LoopM: loopSer :: (MonadAtomic m, MonadServerReadRequest m) => DebugModeSer -> Config -> (Maybe SessionUI -> COps -> FactionId -> ChanServer -> IO ()) -> m ()

+ Game.LambdaHack.Server.LoopM: loopUpd :: forall m. (MonadAtomic m, MonadServerReadRequest m) => m () -> m ()

+ Game.LambdaHack.Server.LoopM: restartGame :: (MonadAtomic m, MonadServer m) => m () -> m () -> Maybe (GroupName ModeKind) -> m ()

+ Game.LambdaHack.Server.LoopM: setTrajectory :: (MonadAtomic m, MonadServer m) => ActorId -> m ()

+ Game.LambdaHack.Server.LoopM: writeSaveAll :: (MonadAtomic m, MonadServer m) => Bool -> m ()

+ Game.LambdaHack.Server.PeriodicM: addAnyActor :: (MonadAtomic m, MonadServer m) => Freqs ItemKind -> LevelId -> Time -> Maybe Point -> m (Maybe ActorId)

+ Game.LambdaHack.Server.PeriodicM: advanceTime :: (MonadAtomic m, MonadServer m) => ActorId -> Int -> m ()

+ Game.LambdaHack.Server.PeriodicM: leadLevelSwitch :: (MonadAtomic m, MonadServer m) => m ()

+ Game.LambdaHack.Server.PeriodicM: overheadActorTime :: (MonadAtomic m, MonadServer m) => FactionId -> m ()

+ Game.LambdaHack.Server.PeriodicM: spawnMonster :: (MonadAtomic m, MonadServer m) => m ()

+ Game.LambdaHack.Server.PeriodicM: swapTime :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m ()

+ Game.LambdaHack.Server.PeriodicM: udpateCalm :: (MonadAtomic m, MonadServer m) => ActorId -> Int64 -> m ()

+ Game.LambdaHack.Server.ProtocolM: childrenServer :: MVar [Async ()]

+ Game.LambdaHack.Server.ProtocolM: class MonadServer m => MonadServerReadRequest m

+ Game.LambdaHack.Server.ProtocolM: getsDict :: MonadServerReadRequest m => (ConnServerDict -> a) -> m a

+ Game.LambdaHack.Server.ProtocolM: killAllClients :: (MonadAtomic m, MonadServerReadRequest m) => m ()

+ Game.LambdaHack.Server.ProtocolM: liftIO :: MonadServerReadRequest m => IO a -> m a

+ Game.LambdaHack.Server.ProtocolM: modifyDict :: MonadServerReadRequest m => (ConnServerDict -> ConnServerDict) -> m ()

+ Game.LambdaHack.Server.ProtocolM: putDict :: MonadServerReadRequest m => ConnServerDict -> m ()

+ Game.LambdaHack.Server.ProtocolM: sendQueryAI :: MonadServerReadRequest m => FactionId -> ActorId -> m RequestAI

+ Game.LambdaHack.Server.ProtocolM: sendQueryUI :: (MonadAtomic m, MonadServerReadRequest m) => FactionId -> ActorId -> m RequestUI

+ Game.LambdaHack.Server.ProtocolM: sendSfx :: MonadServerReadRequest m => FactionId -> SfxAtomic -> m ()

+ Game.LambdaHack.Server.ProtocolM: sendUpdate :: MonadServerReadRequest m => FactionId -> UpdAtomic -> m ()

+ Game.LambdaHack.Server.ProtocolM: tryRestore :: MonadServerReadRequest m => COps -> DebugModeSer -> m (Maybe (State, StateServer))

+ Game.LambdaHack.Server.ProtocolM: type ConnServerDict = EnumMap FactionId ChanServer

+ Game.LambdaHack.Server.ProtocolM: updateConn :: (MonadAtomic m, MonadServerReadRequest m) => COps -> Config -> (Maybe SessionUI -> COps -> FactionId -> ChanServer -> IO ()) -> m ()

+ Game.LambdaHack.Server.StartM: applyDebug :: MonadServer m => m ()

+ Game.LambdaHack.Server.StartM: gameReset :: MonadServer m => COps -> DebugModeSer -> Maybe (GroupName ModeKind) -> Maybe StdGen -> m State

+ Game.LambdaHack.Server.StartM: initPer :: MonadServer m => m ()

+ Game.LambdaHack.Server.StartM: reinitGame :: (MonadAtomic m, MonadServer m) => m ()

+ Game.LambdaHack.Server.StartM: updatePer :: (MonadAtomic m, MonadServer m) => FactionId -> LevelId -> m ()

+ Game.LambdaHack.Server.State: [dungeonRandomGenerator] :: RNGs -> !(Maybe StdGen)

+ Game.LambdaHack.Server.State: [sacounter] :: StateServer -> !ActorId

+ Game.LambdaHack.Server.State: [sactorAspect] :: StateServer -> !ActorAspect

+ Game.LambdaHack.Server.State: [sactorTime] :: StateServer -> !ActorTime

+ Game.LambdaHack.Server.State: [sallClear] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server.State: [sarenas] :: StateServer -> ![LevelId]

+ Game.LambdaHack.Server.State: [sautomateAll] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server.State: [sboostRandomItem] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server.State: [scurChalSer] :: DebugModeSer -> !Challenge

+ Game.LambdaHack.Server.State: [sdbgMsgSer] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server.State: [sdebugCli] :: DebugModeSer -> !DebugModeCli

+ Game.LambdaHack.Server.State: [sdebugNxt] :: StateServer -> !DebugModeSer

+ Game.LambdaHack.Server.State: [sdebugSer] :: StateServer -> !DebugModeSer

+ Game.LambdaHack.Server.State: [sdiscoAspect] :: StateServer -> !DiscoveryAspect

+ Game.LambdaHack.Server.State: [sdiscoKindRev] :: StateServer -> !DiscoveryKindRev

+ Game.LambdaHack.Server.State: [sdiscoKind] :: StateServer -> !DiscoveryKind

+ Game.LambdaHack.Server.State: [sdumpInitRngs] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server.State: [sdungeonRng] :: DebugModeSer -> !(Maybe StdGen)

+ Game.LambdaHack.Server.State: [sflavour] :: StateServer -> !FlavourMap

+ Game.LambdaHack.Server.State: [sfovClearLid] :: StateServer -> !FovClearLid

+ Game.LambdaHack.Server.State: [sfovLitLid] :: StateServer -> !FovLitLid

+ Game.LambdaHack.Server.State: [sfovLucidLid] :: StateServer -> !FovLucidLid

+ Game.LambdaHack.Server.State: [sgameMode] :: DebugModeSer -> !(Maybe (GroupName ModeKind))

+ Game.LambdaHack.Server.State: [sicounter] :: StateServer -> !ItemId

+ Game.LambdaHack.Server.State: [sitemRev] :: StateServer -> !ItemRev

+ Game.LambdaHack.Server.State: [sitemSeedD] :: StateServer -> !ItemSeedDict

+ Game.LambdaHack.Server.State: [skeepAutomated] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server.State: [sknowEvents] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server.State: [sknowItems] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server.State: [sknowMap] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server.State: [smainRng] :: DebugModeSer -> !(Maybe StdGen)

+ Game.LambdaHack.Server.State: [snewGameSer] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server.State: [sniffIn] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server.State: [sniffOut] :: DebugModeSer -> !Bool

+ Game.LambdaHack.Server.State: [snumSpawned] :: StateServer -> !(EnumMap LevelId Int)

+ Game.LambdaHack.Server.State: [sperCacheFid] :: StateServer -> !PerCacheFid

+ Game.LambdaHack.Server.State: [sperFid] :: StateServer -> !PerFid

+ Game.LambdaHack.Server.State: [sperValidFid] :: StateServer -> !PerValidFid

+ Game.LambdaHack.Server.State: [squit] :: StateServer -> !Bool

+ Game.LambdaHack.Server.State: [srandom] :: StateServer -> !StdGen

+ Game.LambdaHack.Server.State: [srngs] :: StateServer -> !RNGs

+ Game.LambdaHack.Server.State: [ssavePrefixSer] :: DebugModeSer -> !String

+ Game.LambdaHack.Server.State: [startingRandomGenerator] :: RNGs -> !(Maybe StdGen)

+ Game.LambdaHack.Server.State: [sundo] :: StateServer -> ![CmdAtomic]

+ Game.LambdaHack.Server.State: [suniqueSet] :: StateServer -> !UniqueSet

+ Game.LambdaHack.Server.State: [svalidArenas] :: StateServer -> !Bool

+ Game.LambdaHack.Server.State: [swriteSave] :: StateServer -> !Bool

+ Game.LambdaHack.Server.State: ageActor :: FactionId -> LevelId -> ActorId -> Delta Time -> ActorTime -> ActorTime

+ Game.LambdaHack.Server.State: instance Data.Binary.Class.Binary Game.LambdaHack.Server.State.DebugModeSer

+ Game.LambdaHack.Server.State: instance Data.Binary.Class.Binary Game.LambdaHack.Server.State.RNGs

+ Game.LambdaHack.Server.State: instance Data.Binary.Class.Binary Game.LambdaHack.Server.State.StateServer

+ Game.LambdaHack.Server.State: instance GHC.Show.Show Game.LambdaHack.Server.State.DebugModeSer

+ Game.LambdaHack.Server.State: instance GHC.Show.Show Game.LambdaHack.Server.State.RNGs

+ Game.LambdaHack.Server.State: instance GHC.Show.Show Game.LambdaHack.Server.State.StateServer

+ Game.LambdaHack.Server.State: type ActorTime = EnumMap FactionId (EnumMap LevelId (EnumMap ActorId Time))

+ Game.LambdaHack.Server.State: updateActorTime :: FactionId -> LevelId -> ActorId -> Time -> ActorTime -> ActorTime

- Game.LambdaHack.Atomic: SfxEffect :: !FactionId -> !ActorId -> !Effect -> SfxAtomic

+ Game.LambdaHack.Atomic: SfxEffect :: !FactionId -> !ActorId -> !Effect -> !Int64 -> SfxAtomic

- Game.LambdaHack.Atomic: SfxMsgFid :: !FactionId -> !Msg -> SfxAtomic

+ Game.LambdaHack.Atomic: SfxMsgFid :: !FactionId -> !SfxMsg -> SfxAtomic

- Game.LambdaHack.Atomic: SfxRecoil :: !ActorId -> !ActorId -> !ItemId -> !CStore -> !HitAtomic -> SfxAtomic

+ Game.LambdaHack.Atomic: SfxRecoil :: !ActorId -> !ActorId -> !ItemId -> !CStore -> SfxAtomic

- Game.LambdaHack.Atomic: SfxShun :: !ActorId -> !Point -> !Feature -> SfxAtomic

+ Game.LambdaHack.Atomic: SfxShun :: !ActorId -> !Point -> SfxAtomic

- Game.LambdaHack.Atomic: SfxStrike :: !ActorId -> !ActorId -> !ItemId -> !CStore -> !HitAtomic -> SfxAtomic

+ Game.LambdaHack.Atomic: SfxStrike :: !ActorId -> !ActorId -> !ItemId -> !CStore -> SfxAtomic

- Game.LambdaHack.Atomic: SfxTrigger :: !ActorId -> !Point -> !Feature -> SfxAtomic

+ Game.LambdaHack.Atomic: SfxTrigger :: !ActorId -> !Point -> SfxAtomic

- Game.LambdaHack.Atomic: UpdAgeGame :: !(Delta Time) -> ![LevelId] -> UpdAtomic

+ Game.LambdaHack.Atomic: UpdAgeGame :: ![LevelId] -> UpdAtomic

- Game.LambdaHack.Atomic: UpdAlterSmell :: !LevelId -> !Point -> !(Maybe Time) -> !(Maybe Time) -> UpdAtomic

+ Game.LambdaHack.Atomic: UpdAlterSmell :: !LevelId -> !Point -> !Time -> !Time -> UpdAtomic

- Game.LambdaHack.Atomic: UpdCover :: !Container -> !ItemId -> !(Id ItemKind) -> !ItemSeed -> !AbsDepth -> UpdAtomic

+ Game.LambdaHack.Atomic: UpdCover :: !Container -> !ItemId -> !(Id ItemKind) -> !ItemSeed -> UpdAtomic

- Game.LambdaHack.Atomic: UpdCoverSeed :: !Container -> !ItemId -> !ItemSeed -> !AbsDepth -> UpdAtomic

+ Game.LambdaHack.Atomic: UpdCoverSeed :: !Container -> !ItemId -> !ItemSeed -> UpdAtomic

- Game.LambdaHack.Atomic: UpdDiscover :: !Container -> !ItemId -> !(Id ItemKind) -> !ItemSeed -> !AbsDepth -> UpdAtomic

+ Game.LambdaHack.Atomic: UpdDiscover :: !Container -> !ItemId -> !(Id ItemKind) -> !ItemSeed -> UpdAtomic

- Game.LambdaHack.Atomic: UpdDiscoverSeed :: !Container -> !ItemId -> !ItemSeed -> !AbsDepth -> UpdAtomic

+ Game.LambdaHack.Atomic: UpdDiscoverSeed :: !Container -> !ItemId -> !ItemSeed -> UpdAtomic

- Game.LambdaHack.Atomic: UpdLeadFaction :: !FactionId -> !(Maybe (ActorId, Maybe Target)) -> !(Maybe (ActorId, Maybe Target)) -> UpdAtomic

+ Game.LambdaHack.Atomic: UpdLeadFaction :: !FactionId -> !(Maybe ActorId) -> !(Maybe ActorId) -> UpdAtomic

- Game.LambdaHack.Atomic: UpdLoseItem :: !ItemId -> !Item -> !ItemQuant -> !Container -> UpdAtomic

+ Game.LambdaHack.Atomic: UpdLoseItem :: !Bool -> !ItemId -> !Item -> !ItemQuant -> !Container -> UpdAtomic

- Game.LambdaHack.Atomic: UpdMsgAll :: !Msg -> UpdAtomic

+ Game.LambdaHack.Atomic: UpdMsgAll :: !Text -> UpdAtomic

- Game.LambdaHack.Atomic: UpdQuitFaction :: !FactionId -> !(Maybe Actor) -> !(Maybe Status) -> !(Maybe Status) -> UpdAtomic

+ Game.LambdaHack.Atomic: UpdQuitFaction :: !FactionId -> !(Maybe Status) -> !(Maybe Status) -> UpdAtomic

- Game.LambdaHack.Atomic: UpdRestart :: !FactionId -> !DiscoveryKind -> !FactionPers -> !State -> !Int -> !DebugModeCli -> UpdAtomic

+ Game.LambdaHack.Atomic: UpdRestart :: !FactionId -> !DiscoveryKind -> !PerLid -> !State -> !Challenge -> !DebugModeCli -> UpdAtomic

- Game.LambdaHack.Atomic: UpdResume :: !FactionId -> !FactionPers -> UpdAtomic

+ Game.LambdaHack.Atomic: UpdResume :: !FactionId -> !PerLid -> UpdAtomic

- Game.LambdaHack.Atomic: UpdSearchTile :: !ActorId -> !Point -> !(Id TileKind) -> !(Id TileKind) -> UpdAtomic

+ Game.LambdaHack.Atomic: UpdSearchTile :: !ActorId -> !Point -> !(Id TileKind) -> UpdAtomic

- Game.LambdaHack.Atomic: UpdSpotItem :: !ItemId -> !Item -> !ItemQuant -> !Container -> UpdAtomic

+ Game.LambdaHack.Atomic: UpdSpotItem :: !Bool -> !ItemId -> !Item -> !ItemQuant -> !Container -> UpdAtomic

- Game.LambdaHack.Atomic: class MonadStateRead m => MonadAtomic m where execUpdAtomic = execAtomic . UpdAtomic execSfxAtomic = execAtomic . SfxAtomic

+ Game.LambdaHack.Atomic: class MonadStateRead m => MonadAtomic m

- Game.LambdaHack.Atomic: generalMoveItem :: MonadStateRead m => ItemId -> Int -> Container -> Container -> m [UpdAtomic]

+ Game.LambdaHack.Atomic: generalMoveItem :: MonadStateRead m => Bool -> ItemId -> Int -> Container -> Container -> m [UpdAtomic]

- Game.LambdaHack.Atomic.CmdAtomic: SfxEffect :: !FactionId -> !ActorId -> !Effect -> SfxAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: SfxEffect :: !FactionId -> !ActorId -> !Effect -> !Int64 -> SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: SfxMsgFid :: !FactionId -> !Msg -> SfxAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: SfxMsgFid :: !FactionId -> !SfxMsg -> SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: SfxRecoil :: !ActorId -> !ActorId -> !ItemId -> !CStore -> !HitAtomic -> SfxAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: SfxRecoil :: !ActorId -> !ActorId -> !ItemId -> !CStore -> SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: SfxShun :: !ActorId -> !Point -> !Feature -> SfxAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: SfxShun :: !ActorId -> !Point -> SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: SfxStrike :: !ActorId -> !ActorId -> !ItemId -> !CStore -> !HitAtomic -> SfxAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: SfxStrike :: !ActorId -> !ActorId -> !ItemId -> !CStore -> SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: SfxTrigger :: !ActorId -> !Point -> !Feature -> SfxAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: SfxTrigger :: !ActorId -> !Point -> SfxAtomic

- Game.LambdaHack.Atomic.CmdAtomic: UpdAgeGame :: !(Delta Time) -> ![LevelId] -> UpdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: UpdAgeGame :: ![LevelId] -> UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: UpdAlterSmell :: !LevelId -> !Point -> !(Maybe Time) -> !(Maybe Time) -> UpdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: UpdAlterSmell :: !LevelId -> !Point -> !Time -> !Time -> UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: UpdCover :: !Container -> !ItemId -> !(Id ItemKind) -> !ItemSeed -> !AbsDepth -> UpdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: UpdCover :: !Container -> !ItemId -> !(Id ItemKind) -> !ItemSeed -> UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: UpdCoverSeed :: !Container -> !ItemId -> !ItemSeed -> !AbsDepth -> UpdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: UpdCoverSeed :: !Container -> !ItemId -> !ItemSeed -> UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: UpdDiscover :: !Container -> !ItemId -> !(Id ItemKind) -> !ItemSeed -> !AbsDepth -> UpdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: UpdDiscover :: !Container -> !ItemId -> !(Id ItemKind) -> !ItemSeed -> UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: UpdDiscoverSeed :: !Container -> !ItemId -> !ItemSeed -> !AbsDepth -> UpdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: UpdDiscoverSeed :: !Container -> !ItemId -> !ItemSeed -> UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: UpdLeadFaction :: !FactionId -> !(Maybe (ActorId, Maybe Target)) -> !(Maybe (ActorId, Maybe Target)) -> UpdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: UpdLeadFaction :: !FactionId -> !(Maybe ActorId) -> !(Maybe ActorId) -> UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: UpdLoseItem :: !ItemId -> !Item -> !ItemQuant -> !Container -> UpdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: UpdLoseItem :: !Bool -> !ItemId -> !Item -> !ItemQuant -> !Container -> UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: UpdMsgAll :: !Msg -> UpdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: UpdMsgAll :: !Text -> UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: UpdQuitFaction :: !FactionId -> !(Maybe Actor) -> !(Maybe Status) -> !(Maybe Status) -> UpdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: UpdQuitFaction :: !FactionId -> !(Maybe Status) -> !(Maybe Status) -> UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: UpdRestart :: !FactionId -> !DiscoveryKind -> !FactionPers -> !State -> !Int -> !DebugModeCli -> UpdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: UpdRestart :: !FactionId -> !DiscoveryKind -> !PerLid -> !State -> !Challenge -> !DebugModeCli -> UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: UpdResume :: !FactionId -> !FactionPers -> UpdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: UpdResume :: !FactionId -> !PerLid -> UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: UpdSearchTile :: !ActorId -> !Point -> !(Id TileKind) -> !(Id TileKind) -> UpdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: UpdSearchTile :: !ActorId -> !Point -> !(Id TileKind) -> UpdAtomic

- Game.LambdaHack.Atomic.CmdAtomic: UpdSpotItem :: !ItemId -> !Item -> !ItemQuant -> !Container -> UpdAtomic

+ Game.LambdaHack.Atomic.CmdAtomic: UpdSpotItem :: !Bool -> !ItemId -> !Item -> !ItemQuant -> !Container -> UpdAtomic

- Game.LambdaHack.Atomic.MonadAtomic: class MonadStateRead m => MonadAtomic m where execUpdAtomic = execAtomic . UpdAtomic execSfxAtomic = execAtomic . SfxAtomic

+ Game.LambdaHack.Atomic.MonadAtomic: class MonadStateRead m => MonadAtomic m

- Game.LambdaHack.Atomic.PosAtomicRead: generalMoveItem :: MonadStateRead m => ItemId -> Int -> Container -> Container -> m [UpdAtomic]

+ Game.LambdaHack.Atomic.PosAtomicRead: generalMoveItem :: MonadStateRead m => Bool -> ItemId -> Int -> Container -> Container -> m [UpdAtomic]

- Game.LambdaHack.Client.AI: pickAction :: MonadClient m => (ActorId, Actor) -> m RequestAnyAbility

+ Game.LambdaHack.Client.AI: pickAction :: MonadClient m => ActorId -> Bool -> m RequestAnyAbility

- Game.LambdaHack.Client.Bfs: fillBfs :: (Point -> Point -> MoveLegal) -> (Point -> Point -> Bool) -> Point -> Array BfsDistance -> Array BfsDistance

+ Game.LambdaHack.Client.Bfs: fillBfs :: Array Word8 -> Word8 -> Point -> Array BfsDistance -> ()

- Game.LambdaHack.Client.Bfs: findPathBfs :: (Point -> Point -> MoveLegal) -> (Point -> Point -> Bool) -> Point -> Point -> Int -> Array BfsDistance -> Maybe [Point]

+ Game.LambdaHack.Client.Bfs: findPathBfs :: Array Word8 -> (Point -> Bool) -> Point -> Point -> Int -> Array BfsDistance -> AndPath

- Game.LambdaHack.Client.MonadClient: saveClient :: MonadClient m => m ()

+ Game.LambdaHack.Client.MonadClient: saveClient :: MonadClientSetup m => m ()

- Game.LambdaHack.Client.State: StateClient :: !(Maybe TgtMode) -> !Target -> !Int -> !(EnumMap ActorId (Target, Maybe PathEtc)) -> !(EnumSet LevelId) -> !(EnumMap ActorId (Bool, Array BfsDistance, Point, Int, Maybe [Point])) -> !(EnumSet ActorId) -> !(Maybe RunParams) -> !Report -> !History -> !(EnumMap LevelId Time) -> ![CmdAtomic] -> !DiscoveryKind -> !DiscoveryEffect -> !FactionPers -> !StdGen -> !KM -> !LastRecord -> ![KM] -> !(EnumSet ActorId) -> !Int -> !(Maybe ActorId) -> !FactionId -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Int -> !Int -> !ItemSlots -> !SlotChar -> !CStore -> !EscAI -> !DebugModeCli -> StateClient

+ Game.LambdaHack.Client.State: StateClient :: !Int -> !(EnumMap ActorId TgtAndPath) -> !(EnumSet LevelId) -> !(EnumMap ActorId BfsAndPath) -> ![CmdAtomic] -> !DiscoveryKind -> !DiscoveryAspect -> !DiscoveryBenefit -> !ActorAspect -> !PerLid -> !AlterLid -> !StdGen -> !(Maybe ActorId) -> !FactionId -> !Bool -> !Challenge -> !Challenge -> !Int -> !Int -> !(EnumMap LevelId (Maybe Bool)) -> !(EnumMap (Id ModeKind) (Map Challenge Int)) -> !DebugModeCli -> StateClient

- Game.LambdaHack.Client.UI: displayRespUpdAtomicUI :: MonadClientUI m => Bool -> State -> StateClient -> UpdAtomic -> m ()

+ Game.LambdaHack.Client.UI: displayRespUpdAtomicUI :: MonadClientUI m => Bool -> StateClient -> UpdAtomic -> m ()

- Game.LambdaHack.Client.UI: humanCommand :: MonadClientUI m => m RequestUI

+ Game.LambdaHack.Client.UI: humanCommand :: forall m. MonadClientUI m => m ReqUI

- Game.LambdaHack.Client.UI: msgAdd :: MonadClientUI m => Msg -> m ()

+ Game.LambdaHack.Client.UI: msgAdd :: MonadClientUI m => Text -> m ()

- Game.LambdaHack.Client.UI.Animation: actorX :: Point -> Char -> Color -> Animation

+ Game.LambdaHack.Client.UI.Animation: actorX :: Point -> Animation

- Game.LambdaHack.Client.UI.Animation: fadeout :: Bool -> Bool -> Int -> X -> Y -> Rnd Animation

+ Game.LambdaHack.Client.UI.Animation: fadeout :: Bool -> Int -> X -> Y -> Rnd Animation

- Game.LambdaHack.Client.UI.Animation: renderAnim :: X -> Y -> SingleFrame -> Animation -> Frames

+ Game.LambdaHack.Client.UI.Animation: renderAnim :: FrameForall -> Animation -> Frames

- Game.LambdaHack.Client.UI.Config: Config :: ![(KM, ([CmdCategory], HumanCmd))] -> ![(Int, (Text, Text))] -> !Bool -> !Bool -> !String -> !Bool -> !Int -> !Int -> !Bool -> !Bool -> Config

+ Game.LambdaHack.Client.UI.Config: Config :: ![(KM, CmdTriple)] -> ![(Int, (Text, Text))] -> !Bool -> !Bool -> !Text -> !Text -> !Int -> !Int -> !Int -> !Bool -> !Int -> !Int -> !Bool -> !Bool -> ![String] -> Config

- Game.LambdaHack.Client.UI.Config: applyConfigToDebug :: Config -> DebugModeCli -> COps -> DebugModeCli

+ Game.LambdaHack.Client.UI.Config: applyConfigToDebug :: COps -> Config -> DebugModeCli -> DebugModeCli

- Game.LambdaHack.Client.UI.Config: mkConfig :: COps -> IO Config

+ Game.LambdaHack.Client.UI.Config: mkConfig :: COps -> Bool -> IO Config

- Game.LambdaHack.Client.UI.Content.KeyKind: KeyKind :: ![(KM, ([CmdCategory], HumanCmd))] -> KeyKind

+ Game.LambdaHack.Client.UI.Content.KeyKind: KeyKind :: [(KM, CmdTriple)] -> KeyKind

- Game.LambdaHack.Client.UI.Frontend: ChanFrontend :: !(TQueue KM) -> !(TQueue FrontReq) -> ChanFrontend

+ Game.LambdaHack.Client.UI.Frontend: ChanFrontend :: (forall a. FrontReq a -> IO a) -> ChanFrontend

- Game.LambdaHack.Client.UI.Frontend: data FrontReq

+ Game.LambdaHack.Client.UI.Frontend: data FrontReq :: * -> *

- Game.LambdaHack.Client.UI.HumanCmd: GameRestart :: !(GroupName ModeKind) -> HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: GameRestart :: HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: Macro :: !Text -> ![String] -> HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: Macro :: ![String] -> HumanCmd

- Game.LambdaHack.Client.UI.HumanCmd: MoveItem :: ![CStore] -> !CStore -> !(Maybe Part) -> !Part -> !Bool -> HumanCmd

+ Game.LambdaHack.Client.UI.HumanCmd: MoveItem :: ![CStore] -> !CStore -> !(Maybe Part) -> !Bool -> HumanCmd

- Game.LambdaHack.Client.UI.KeyBindings: Binding :: !(Map KM (Text, [CmdCategory], HumanCmd)) -> ![(KM, (Text, [CmdCategory], HumanCmd))] -> !(Map HumanCmd KM) -> Binding

+ Game.LambdaHack.Client.UI.KeyBindings: Binding :: !(Map KM CmdTriple) -> ![(KM, CmdTriple)] -> !(Map HumanCmd [KM]) -> Binding

- Game.LambdaHack.Client.UI.KeyBindings: keyHelp :: Binding -> Slideshow

+ Game.LambdaHack.Client.UI.KeyBindings: keyHelp :: Binding -> Int -> [(Text, OKX)]

- Game.LambdaHack.Common.Actor: Actor :: !ItemId -> !Char -> !Text -> !Text -> !Color -> !Time -> !Int64 -> !ResDelta -> !Int64 -> !ResDelta -> !Point -> !(Maybe Point) -> !LevelId -> !LevelId -> !FactionId -> !FactionId -> !FactionId -> !(Maybe ([Vector], Speed)) -> !ItemBag -> !ItemBag -> !ItemBag -> !Bool -> !Bool -> Actor

+ Game.LambdaHack.Common.Actor: Actor :: !ItemId -> !Int64 -> !ResDelta -> !Int64 -> !ResDelta -> !Point -> !(Maybe Point) -> !LevelId -> !FactionId -> !(Maybe ([Vector], Speed)) -> !ItemBag -> !ItemBag -> !ItemBag -> !Int -> !Bool -> !Bool -> Actor

- Game.LambdaHack.Common.Actor: ResDelta :: !Int64 -> !Int64 -> ResDelta

+ Game.LambdaHack.Common.Actor: ResDelta :: !(Int64, Int64) -> !(Int64, Int64) -> ResDelta

- Game.LambdaHack.Common.Actor: actorTemplate :: ItemId -> Char -> Text -> Text -> Color -> Int64 -> Int64 -> Point -> LevelId -> Time -> FactionId -> Actor

+ Game.LambdaHack.Common.Actor: actorTemplate :: ItemId -> Int64 -> Int64 -> Point -> LevelId -> FactionId -> Actor

- Game.LambdaHack.Common.Actor: bspeed :: Actor -> [ItemFull] -> Speed

+ Game.LambdaHack.Common.Actor: bspeed :: Actor -> AspectRecord -> Speed

- Game.LambdaHack.Common.Actor: calmEnough :: Actor -> [ItemFull] -> Bool

+ Game.LambdaHack.Common.Actor: calmEnough :: Actor -> AspectRecord -> Bool

- Game.LambdaHack.Common.Actor: hpEnough :: Actor -> [ItemFull] -> Bool

+ Game.LambdaHack.Common.Actor: hpEnough :: Actor -> AspectRecord -> Bool

- Game.LambdaHack.Common.Actor: hpTooLow :: Actor -> [ItemFull] -> Bool

+ Game.LambdaHack.Common.Actor: hpTooLow :: Actor -> AspectRecord -> Bool

- Game.LambdaHack.Common.ActorState: actorSkills :: Maybe ActorId -> ActorId -> [ItemFull] -> State -> Skills

+ Game.LambdaHack.Common.ActorState: actorSkills :: Maybe ActorId -> ActorId -> AspectRecord -> State -> Skills

- Game.LambdaHack.Common.ActorState: calculateTotal :: Actor -> State -> (ItemBag, Int)

+ Game.LambdaHack.Common.ActorState: calculateTotal :: FactionId -> State -> (ItemBag, Int)

- Game.LambdaHack.Common.ActorState: dispEnemy :: ActorId -> ActorId -> [ItemFull] -> State -> Bool

+ Game.LambdaHack.Common.ActorState: dispEnemy :: ActorId -> ActorId -> Skills -> State -> Bool

- Game.LambdaHack.Common.ActorState: findIid :: ActorId -> FactionId -> ItemId -> State -> [(Actor, CStore)]

+ Game.LambdaHack.Common.ActorState: findIid :: ActorId -> FactionId -> ItemId -> State -> [(ActorId, (Actor, CStore))]

- Game.LambdaHack.Common.ActorState: fullAssocs :: COps -> DiscoveryKind -> DiscoveryEffect -> ActorId -> [CStore] -> State -> [(ItemId, ItemFull)]

+ Game.LambdaHack.Common.ActorState: fullAssocs :: COps -> DiscoveryKind -> DiscoveryAspect -> ActorId -> [CStore] -> State -> [(ItemId, ItemFull)]

- Game.LambdaHack.Common.ActorState: regenCalmDelta :: Actor -> [ItemFull] -> State -> Int64

+ Game.LambdaHack.Common.ActorState: regenCalmDelta :: Actor -> AspectRecord -> State -> Int64

- Game.LambdaHack.Common.ClientOptions: DebugModeCli :: !(Maybe String) -> !(Maybe Bool) -> !(Maybe Int) -> !Bool -> !Bool -> !(Maybe Bool) -> !Bool -> !Bool -> !(Maybe String) -> !Bool -> !Bool -> !Bool -> DebugModeCli

+ Game.LambdaHack.Common.ClientOptions: DebugModeCli :: !(Maybe Text) -> !(Maybe Text) -> !(Maybe Int) -> !(Maybe Int) -> !(Maybe Int) -> !(Maybe Bool) -> !(Maybe Int) -> !Bool -> !(Maybe Bool) -> !Bool -> !Bool -> !(Maybe Text) -> !String -> !Bool -> !Bool -> !Bool -> !Bool -> !(Maybe Int) -> !(Maybe Int) -> DebugModeCli

- Game.LambdaHack.Common.Color: Attr :: !Color -> !Color -> Attr

+ Game.LambdaHack.Common.Color: Attr :: !Color -> !Highlight -> Attr

- Game.LambdaHack.Common.Color: colorToRGB :: Color -> String

+ Game.LambdaHack.Common.Color: colorToRGB :: Color -> Text

- Game.LambdaHack.Common.ContentDef: ContentDef :: (a -> Char) -> (a -> Text) -> (a -> Freqs a) -> (a -> [Text]) -> ([a] -> [Text]) -> ![a] -> ContentDef a

+ Game.LambdaHack.Common.ContentDef: ContentDef :: !(a -> Char) -> !(a -> Text) -> !(a -> Freqs a) -> !(a -> [Text]) -> !([a] -> [Text]) -> !(Vector a) -> ContentDef a

- Game.LambdaHack.Common.Faction: Faction :: !Text -> !Color -> !(Player Int) -> !Dipl -> !(Maybe Status) -> !(Maybe (ActorId, Maybe Target)) -> !ItemBag -> !(EnumMap (Id ItemKind) Int) -> Faction

+ Game.LambdaHack.Common.Faction: Faction :: !Text -> !Color -> !Player -> ![(Int, Int, GroupName ItemKind)] -> !Dipl -> !(Maybe Status) -> !(Maybe ActorId) -> !ItemBag -> !(EnumMap (Id ItemKind) Int) -> !(EnumMap (Id ModeKind) (IntMap (EnumMap (Id ItemKind) Int))) -> Faction

- Game.LambdaHack.Common.Faction: TEnemyPos :: !ActorId -> !LevelId -> !Point -> !Bool -> Target

+ Game.LambdaHack.Common.Faction: TEnemyPos :: !ActorId -> !Bool -> TGoal

- Game.LambdaHack.Common.Faction: TPoint :: !LevelId -> !Point -> Target

+ Game.LambdaHack.Common.Faction: TPoint :: !TGoal -> !LevelId -> !Point -> Target

- Game.LambdaHack.Common.Faction: automatePlayer :: Bool -> Player a -> Player a

+ Game.LambdaHack.Common.Faction: automatePlayer :: Bool -> Player -> Player

- Game.LambdaHack.Common.HighScore: highSlideshow :: ScoreTable -> Int -> Text -> Slideshow

+ Game.LambdaHack.Common.HighScore: highSlideshow :: ScoreTable -> Int -> Text -> TimeZone -> (Text, [[Text]])

- Game.LambdaHack.Common.HighScore: register :: ScoreTable -> Int -> Time -> Status -> ClockTime -> Int -> Text -> EnumMap (Id ItemKind) Int -> EnumMap (Id ItemKind) Int -> HiCondPoly -> (Bool, (ScoreTable, Int))

+ Game.LambdaHack.Common.HighScore: register :: ScoreTable -> Int -> Time -> Status -> POSIXTime -> Challenge -> Text -> EnumMap (Id ItemKind) Int -> EnumMap (Id ItemKind) Int -> HiCondPoly -> (Bool, (ScoreTable, Int))

- Game.LambdaHack.Common.HighScore: showScore :: (Int, ScoreRecord) -> [Text]

+ Game.LambdaHack.Common.HighScore: showScore :: TimeZone -> (Int, ScoreRecord) -> [Text]

- Game.LambdaHack.Common.Item: Item :: !ItemKindIx -> !LevelId -> !Char -> !Text -> !Flavour -> ![Feature] -> !Int -> Item

+ Game.LambdaHack.Common.Item: Item :: !ItemKindIx -> !LevelId -> !(Maybe FactionId) -> !Char -> !Text -> !Flavour -> ![Feature] -> !Int -> !Dice -> Item

- Game.LambdaHack.Common.Item: ItemDisco :: !(Id ItemKind) -> !ItemKind -> !(Maybe ItemAspectEffect) -> ItemDisco

+ Game.LambdaHack.Common.Item: ItemDisco :: !(Id ItemKind) -> !ItemKind -> !AspectRecord -> !(Maybe AspectRecord) -> ItemDisco

- Game.LambdaHack.Common.Item: type DiscoveryKind = EnumMap ItemKindIx (Id ItemKind)

+ Game.LambdaHack.Common.Item: type DiscoveryKind = EnumMap ItemKindIx KindMean

- Game.LambdaHack.Common.ItemStrongest: strengthEqpSlot :: Item -> Maybe (EqpSlot, Text)

+ Game.LambdaHack.Common.ItemStrongest: strengthEqpSlot :: ItemFull -> Maybe EqpSlot

- Game.LambdaHack.Common.ItemStrongest: strongestSlot :: EqpSlot -> [(ItemId, ItemFull)] -> [(Int, (ItemId, ItemFull))]

+ Game.LambdaHack.Common.ItemStrongest: strongestSlot :: DiscoveryBenefit -> EqpSlot -> [(ItemId, ItemFull)] -> [(Int, (ItemId, ItemFull))]

- Game.LambdaHack.Common.Kind: COps :: !(Ops CaveKind) -> !(Ops ItemKind) -> !(Ops ModeKind) -> !(Ops PlaceKind) -> !(Ops RuleKind) -> !(Ops TileKind) -> COps

+ Game.LambdaHack.Common.Kind: COps :: !(Ops CaveKind) -> !(Ops ItemKind) -> !(Ops ModeKind) -> !(Ops PlaceKind) -> !(Ops RuleKind) -> !(Ops TileKind) -> !TileSpeedup -> COps

- Game.LambdaHack.Common.Kind: Ops :: (Id a -> a) -> (GroupName a -> Id a) -> (GroupName a -> (a -> Bool) -> Rnd (Maybe (Id a))) -> (forall b. (Id a -> a -> b -> b) -> b -> b) -> (forall b. GroupName a -> (Int -> Id a -> a -> b -> b) -> b -> b) -> !(Id a, Id a) -> !(Maybe (Speedup a)) -> Ops a

+ Game.LambdaHack.Common.Kind: Ops :: !(Id a -> a) -> !(GroupName a -> Id a) -> !(GroupName a -> (a -> Bool) -> Rnd (Maybe (Id a))) -> !(forall b. (Id a -> a -> b -> b) -> b -> b) -> !(forall b. (b -> Id a -> a -> b) -> b -> b) -> !(forall b. GroupName a -> (b -> Int -> Id a -> a -> b) -> b -> b) -> !Int -> Ops a

- Game.LambdaHack.Common.Kind: createOps :: Show a => ContentDef a -> Ops a

+ Game.LambdaHack.Common.Kind: createOps :: forall a. Show a => ContentDef a -> Ops a

- Game.LambdaHack.Common.Level: Level :: !AbsDepth -> !ActorPrio -> !ItemFloor -> !ItemFloor -> !TileMap -> !X -> !Y -> !SmellMap -> !Text -> !([Point], [Point]) -> !Int -> !Int -> !Time -> !Int -> !(Freqs ItemKind) -> !Int -> !(Freqs ItemKind) -> !Int -> !Int -> ![Point] -> Level

+ Game.LambdaHack.Common.Level: Level :: !AbsDepth -> !ItemFloor -> !ItemFloor -> !ActorMap -> !TileMap -> !X -> !Y -> !SmellMap -> !Text -> !([Point], [Point]) -> !Int -> !Int -> !Time -> !Int -> !(Freqs ItemKind) -> !Int -> !(Freqs ItemKind) -> ![Point] -> !Bool -> Level

- Game.LambdaHack.Common.Level: ascendInBranch :: Dungeon -> Int -> LevelId -> [LevelId]

+ Game.LambdaHack.Common.Level: ascendInBranch :: Dungeon -> Bool -> LevelId -> [LevelId]

- Game.LambdaHack.Common.Level: type SmellMap = EnumMap Point SmellTime

+ Game.LambdaHack.Common.Level: type SmellMap = EnumMap Point Time

- Game.LambdaHack.Common.Level: type TileMap = Array (Id TileKind)

+ Game.LambdaHack.Common.Level: type TileMap = GArray Word16 (Id TileKind)

- Game.LambdaHack.Common.MonadStateRead: class (Monad m, Functor m) => MonadStateRead m

+ Game.LambdaHack.Common.MonadStateRead: class (Monad m, Functor m, Applicative m) => MonadStateRead m

- Game.LambdaHack.Common.Perception: Perception :: !PerceptionVisible -> !PerceptionVisible -> Perception

+ Game.LambdaHack.Common.Perception: Perception :: !PerVisible -> !PerSmelled -> Perception

- Game.LambdaHack.Common.PointArray: (!) :: Enum c => Array c -> Point -> c

+ Game.LambdaHack.Common.PointArray: (!) :: (Unbox w, Enum w, Enum c) => GArray w c -> Point -> c

- Game.LambdaHack.Common.PointArray: (//) :: Enum c => Array c -> [(Point, c)] -> Array c

+ Game.LambdaHack.Common.PointArray: (//) :: (Unbox w, Enum w, Enum c) => GArray w c -> [(Point, c)] -> GArray w c

- Game.LambdaHack.Common.PointArray: forceA :: Enum c => Array c -> Array c

+ Game.LambdaHack.Common.PointArray: forceA :: Unbox w => GArray w c -> GArray w c

- Game.LambdaHack.Common.PointArray: generateA :: Enum c => X -> Y -> (Point -> c) -> Array c

+ Game.LambdaHack.Common.PointArray: generateA :: (Unbox w, Enum w, Enum c) => X -> Y -> (Point -> c) -> GArray w c

- Game.LambdaHack.Common.PointArray: generateMA :: Enum c => Monad m => X -> Y -> (Point -> m c) -> m (Array c)

+ Game.LambdaHack.Common.PointArray: generateMA :: (Unbox w, Enum w, Enum c, Monad m) => X -> Y -> (Point -> m c) -> m (GArray w c)

- Game.LambdaHack.Common.PointArray: imapA :: (Enum c, Enum d) => (Point -> c -> d) -> Array c -> Array d

+ Game.LambdaHack.Common.PointArray: imapA :: (Unbox w1, Enum w1, Unbox w2, Enum w2, Enum c, Enum d) => (Point -> c -> d) -> GArray w1 c -> GArray w2 d

- Game.LambdaHack.Common.PointArray: mapA :: (Enum c, Enum d) => (c -> d) -> Array c -> Array d

+ Game.LambdaHack.Common.PointArray: mapA :: (Unbox w1, Enum w1, Unbox w2, Enum w2, Enum c, Enum d) => (c -> d) -> GArray w1 c -> GArray w2 d

- Game.LambdaHack.Common.PointArray: maxIndexA :: Enum c => Array c -> Point

+ Game.LambdaHack.Common.PointArray: maxIndexA :: (Unbox w, Ord w) => GArray w c -> Point

- Game.LambdaHack.Common.PointArray: maxLastIndexA :: Enum c => Array c -> Point

+ Game.LambdaHack.Common.PointArray: maxLastIndexA :: (Unbox w, Ord w) => GArray w c -> Point

- Game.LambdaHack.Common.PointArray: minIndexA :: Enum c => Array c -> Point

+ Game.LambdaHack.Common.PointArray: minIndexA :: (Unbox w, Ord w) => GArray w c -> Point

- Game.LambdaHack.Common.PointArray: minIndexesA :: Enum c => Array c -> [Point]

+ Game.LambdaHack.Common.PointArray: minIndexesA :: (Unbox w, Enum w, Ord w) => GArray w c -> [Point]

- Game.LambdaHack.Common.PointArray: minLastIndexA :: Enum c => Array c -> Point

+ Game.LambdaHack.Common.PointArray: minLastIndexA :: (Unbox w, Ord w) => GArray w c -> Point

- Game.LambdaHack.Common.PointArray: replicateA :: Enum c => X -> Y -> c -> Array c

+ Game.LambdaHack.Common.PointArray: replicateA :: (Unbox w, Enum w, Enum c) => X -> Y -> c -> GArray w c

- Game.LambdaHack.Common.PointArray: replicateMA :: Enum c => Monad m => X -> Y -> m c -> m (Array c)

+ Game.LambdaHack.Common.PointArray: replicateMA :: (Unbox w, Enum w, Enum c, Monad m) => X -> Y -> m c -> m (GArray w c)

- Game.LambdaHack.Common.PointArray: safeSetA :: Enum c => c -> Array c -> Array c

+ Game.LambdaHack.Common.PointArray: safeSetA :: (Unbox w, Enum w, Enum c) => c -> GArray w c -> GArray w c

- Game.LambdaHack.Common.PointArray: sizeA :: Array c -> (X, Y)

+ Game.LambdaHack.Common.PointArray: sizeA :: GArray w c -> (X, Y)

- Game.LambdaHack.Common.PointArray: unsafeSetA :: Enum c => c -> Array c -> Array c

+ Game.LambdaHack.Common.PointArray: unsafeSetA :: (Unbox w, Enum w, Enum c) => c -> GArray w c -> GArray w c

- Game.LambdaHack.Common.PointArray: unsafeUpdateA :: Enum c => Array c -> [(Point, c)] -> Array c

+ Game.LambdaHack.Common.PointArray: unsafeUpdateA :: (Unbox w, Enum w, Enum c) => GArray w c -> [(Point, c)] -> ()

- Game.LambdaHack.Common.Random: random :: Random a => Rnd a

+ Game.LambdaHack.Common.Random: random :: (Random a) => Rnd a

- Game.LambdaHack.Common.Random: randomR :: Random a => (a, a) -> Rnd a

+ Game.LambdaHack.Common.Random: randomR :: (Random a) => (a, a) -> Rnd a

- Game.LambdaHack.Common.Request: ReqAITimed :: !(RequestTimed a) -> RequestAI

+ Game.LambdaHack.Common.Request: ReqAITimed :: RequestAnyAbility -> ReqAI

- Game.LambdaHack.Common.Request: ReqUIAutomate :: RequestUI

+ Game.LambdaHack.Common.Request: ReqUIAutomate :: ReqUI

- Game.LambdaHack.Common.Request: ReqUIGameExit :: !ActorId -> RequestUI

+ Game.LambdaHack.Common.Request: ReqUIGameExit :: ReqUI

- Game.LambdaHack.Common.Request: ReqUIGameRestart :: !ActorId -> !(GroupName ModeKind) -> !Int -> ![(Int, (Text, Text))] -> RequestUI

+ Game.LambdaHack.Common.Request: ReqUIGameRestart :: !(GroupName ModeKind) -> !Challenge -> ReqUI

- Game.LambdaHack.Common.Request: ReqUIGameSave :: RequestUI

+ Game.LambdaHack.Common.Request: ReqUIGameSave :: ReqUI

- Game.LambdaHack.Common.Request: ReqUITactic :: !Tactic -> RequestUI

+ Game.LambdaHack.Common.Request: ReqUITactic :: !Tactic -> ReqUI

- Game.LambdaHack.Common.Request: ReqUITimed :: !(RequestTimed a) -> RequestUI

+ Game.LambdaHack.Common.Request: ReqUITimed :: RequestAnyAbility -> ReqUI

- Game.LambdaHack.Common.Request: permittedApply :: [Char] -> Time -> Int -> ItemFull -> Actor -> [ItemFull] -> Either ReqFailure Bool

+ Game.LambdaHack.Common.Request: permittedApply :: Time -> Int -> Bool -> [Char] -> ItemFull -> Either ReqFailure Bool

- Game.LambdaHack.Common.Request: permittedProject :: [Char] -> Bool -> Int -> ItemFull -> Actor -> [ItemFull] -> Either ReqFailure Bool

+ Game.LambdaHack.Common.Request: permittedProject :: Bool -> Int -> Bool -> [Char] -> ItemFull -> Either ReqFailure Bool

- Game.LambdaHack.Common.Request: showReqFailure :: ReqFailure -> Msg

+ Game.LambdaHack.Common.Request: showReqFailure :: ReqFailure -> Text

- Game.LambdaHack.Common.Response: RespQueryAI :: !ActorId -> ResponseAI

+ Game.LambdaHack.Common.Response: RespQueryAI :: !ActorId -> Response

- Game.LambdaHack.Common.Response: RespQueryUI :: ResponseUI

+ Game.LambdaHack.Common.Response: RespQueryUI :: Response

- Game.LambdaHack.Common.Save: restoreGame :: Binary a => String -> [(FilePath, FilePath)] -> (FilePath -> IO FilePath) -> IO (Maybe a)

+ Game.LambdaHack.Common.Save: restoreGame :: Binary a => COps -> FilePath -> IO (Maybe a)

- Game.LambdaHack.Common.Save: wrapInSaves :: Binary a => (a -> FilePath) -> (ChanSave a -> IO ()) -> IO ()

+ Game.LambdaHack.Common.Save: wrapInSaves :: Binary a => COps -> (a -> FilePath) -> (ChanSave a -> IO ()) -> IO ()

- Game.LambdaHack.Common.State: emptyState :: State

+ Game.LambdaHack.Common.State: emptyState :: COps -> State

- Game.LambdaHack.Common.Tile: accessTab :: Tab -> Id TileKind -> Bool

+ Game.LambdaHack.Common.Tile: accessTab :: Unbox a => Tab a -> Id TileKind -> a

- Game.LambdaHack.Common.Tile: createTab :: Ops TileKind -> (TileKind -> Bool) -> Tab

+ Game.LambdaHack.Common.Tile: createTab :: Unbox a => Ops TileKind -> (TileKind -> a) -> Tab a

- Game.LambdaHack.Common.Tile: isClear :: Ops TileKind -> Id TileKind -> Bool

+ Game.LambdaHack.Common.Tile: isClear :: TileSpeedup -> Id TileKind -> Bool

- Game.LambdaHack.Common.Tile: isDoor :: Ops TileKind -> Id TileKind -> Bool

+ Game.LambdaHack.Common.Tile: isDoor :: TileSpeedup -> Id TileKind -> Bool

- Game.LambdaHack.Common.Tile: isExplorable :: Ops TileKind -> Id TileKind -> Bool

+ Game.LambdaHack.Common.Tile: isExplorable :: TileSpeedup -> Id TileKind -> Bool

- Game.LambdaHack.Common.Tile: isLit :: Ops TileKind -> Id TileKind -> Bool

+ Game.LambdaHack.Common.Tile: isLit :: TileSpeedup -> Id TileKind -> Bool

- Game.LambdaHack.Common.Tile: isSuspect :: Ops TileKind -> Id TileKind -> Bool

+ Game.LambdaHack.Common.Tile: isSuspect :: TileSpeedup -> Id TileKind -> Bool

- Game.LambdaHack.Common.Tile: isWalkable :: Ops TileKind -> Id TileKind -> Bool

+ Game.LambdaHack.Common.Tile: isWalkable :: TileSpeedup -> Id TileKind -> Bool

- Game.LambdaHack.Content.CaveKind: CaveKind :: !Char -> !Text -> !(Freqs CaveKind) -> !X -> !Y -> !DiceXY -> !DiceXY -> !DiceXY -> !Dice -> !Dice -> !Rational -> !Rational -> !Int -> !Chance -> !Chance -> !Int -> !Int -> !(Freqs ItemKind) -> !Dice -> !(Freqs ItemKind) -> !(Freqs PlaceKind) -> !Bool -> !(GroupName TileKind) -> !(GroupName TileKind) -> !(GroupName TileKind) -> !(GroupName TileKind) -> !(GroupName TileKind) -> !(GroupName TileKind) -> !(GroupName TileKind) -> CaveKind

+ Game.LambdaHack.Content.CaveKind: CaveKind :: !Char -> !Text -> !(Freqs CaveKind) -> !X -> !Y -> !DiceXY -> !DiceXY -> !DiceXY -> !Dice -> !Dice -> !Rational -> !Rational -> !Int -> !Dice -> !Chance -> !Chance -> !Int -> !Int -> !(Freqs ItemKind) -> !Dice -> !(Freqs ItemKind) -> !(Freqs PlaceKind) -> !Bool -> !(GroupName TileKind) -> !(GroupName TileKind) -> !(GroupName TileKind) -> !(GroupName TileKind) -> !(GroupName TileKind) -> !(GroupName TileKind) -> !(GroupName TileKind) -> !(Maybe (GroupName PlaceKind)) -> !(Freqs PlaceKind) -> CaveKind

- Game.LambdaHack.Content.ItemKind: AddArmorMelee :: !a -> Aspect a

+ Game.LambdaHack.Content.ItemKind: AddArmorMelee :: !Dice -> Aspect

- Game.LambdaHack.Content.ItemKind: AddArmorRanged :: !a -> Aspect a

+ Game.LambdaHack.Content.ItemKind: AddArmorRanged :: !Dice -> Aspect

- Game.LambdaHack.Content.ItemKind: AddHurtMelee :: !a -> Aspect a

+ Game.LambdaHack.Content.ItemKind: AddHurtMelee :: !Dice -> Aspect

- Game.LambdaHack.Content.ItemKind: AddMaxCalm :: !a -> Aspect a

+ Game.LambdaHack.Content.ItemKind: AddMaxCalm :: !Dice -> Aspect

- Game.LambdaHack.Content.ItemKind: AddMaxHP :: !a -> Aspect a

+ Game.LambdaHack.Content.ItemKind: AddMaxHP :: !Dice -> Aspect

- Game.LambdaHack.Content.ItemKind: AddSight :: !a -> Aspect a

+ Game.LambdaHack.Content.ItemKind: AddSight :: !Dice -> Aspect

- Game.LambdaHack.Content.ItemKind: AddSmell :: !a -> Aspect a

+ Game.LambdaHack.Content.ItemKind: AddSmell :: !Dice -> Aspect

- Game.LambdaHack.Content.ItemKind: AddSpeed :: !a -> Aspect a

+ Game.LambdaHack.Content.ItemKind: AddSpeed :: !Dice -> Aspect

- Game.LambdaHack.Content.ItemKind: Ascend :: !Int -> Effect

+ Game.LambdaHack.Content.ItemKind: Ascend :: !Bool -> Effect

- Game.LambdaHack.Content.ItemKind: DropItem :: !CStore -> !(GroupName ItemKind) -> !Bool -> Effect

+ Game.LambdaHack.Content.ItemKind: DropItem :: !Int -> !Int -> !CStore -> !(GroupName ItemKind) -> Effect

- Game.LambdaHack.Content.ItemKind: EqpSlot :: !EqpSlot -> !Text -> Feature

+ Game.LambdaHack.Content.ItemKind: EqpSlot :: !EqpSlot -> Effect

- Game.LambdaHack.Content.ItemKind: Escape :: !Int -> Effect

+ Game.LambdaHack.Content.ItemKind: Escape :: Effect

- Game.LambdaHack.Content.ItemKind: ItemKind :: !Char -> !Text -> !(Freqs ItemKind) -> ![Flavour] -> !Dice -> !Rarity -> !Part -> !Int -> ![Aspect Dice] -> ![Effect] -> ![Feature] -> !Text -> ![(GroupName ItemKind, CStore)] -> ItemKind

+ Game.LambdaHack.Content.ItemKind: ItemKind :: !Char -> !Text -> !(Freqs ItemKind) -> ![Flavour] -> !Dice -> !Rarity -> !Part -> !Int -> ![(Int, Dice)] -> ![Aspect] -> ![Effect] -> ![Feature] -> !Text -> ![(GroupName ItemKind, CStore)] -> ItemKind

- Game.LambdaHack.Content.ItemKind: Periodic :: Aspect a

+ Game.LambdaHack.Content.ItemKind: Periodic :: Effect

- Game.LambdaHack.Content.ItemKind: Summon :: !(Freqs ItemKind) -> !Dice -> Effect

+ Game.LambdaHack.Content.ItemKind: Summon :: !(GroupName ItemKind) -> !Dice -> Effect

- Game.LambdaHack.Content.ItemKind: Timeout :: !a -> Aspect a

+ Game.LambdaHack.Content.ItemKind: Timeout :: !Dice -> Aspect

- Game.LambdaHack.Content.ItemKind: Unique :: Aspect a

+ Game.LambdaHack.Content.ItemKind: Unique :: Effect

- Game.LambdaHack.Content.ItemKind: data Aspect a

+ Game.LambdaHack.Content.ItemKind: data Aspect

- Game.LambdaHack.Content.ModeKind: Player :: !Text -> !(GroupName ItemKind) -> !Skills -> !Bool -> !Bool -> !HiCondPoly -> !Bool -> !Bool -> !Tactic -> !a -> !a -> !LeaderMode -> !Bool -> Player a

+ Game.LambdaHack.Content.ModeKind: Player :: !Text -> ![GroupName ItemKind] -> !Skills -> !Bool -> !Bool -> !HiCondPoly -> !Bool -> !Tactic -> !LeaderMode -> !Bool -> Player

- Game.LambdaHack.Content.ModeKind: Roster :: ![Player Dice] -> ![(Text, Text)] -> ![(Text, Text)] -> Roster

+ Game.LambdaHack.Content.ModeKind: Roster :: ![(Player, [(Int, Dice, GroupName ItemKind)])] -> ![(Text, Text)] -> ![(Text, Text)] -> Roster

- Game.LambdaHack.Content.ModeKind: data Player a

+ Game.LambdaHack.Content.ModeKind: data Player

- Game.LambdaHack.Content.ModeKind: type Caves = IntMap (GroupName CaveKind, Maybe Bool)

+ Game.LambdaHack.Content.ModeKind: type Caves = IntMap (GroupName CaveKind)

- Game.LambdaHack.Content.RuleKind: RuleKind :: !Char -> !Text -> !(Freqs RuleKind) -> !(Maybe (Point -> Point -> Bool)) -> !(Maybe (Point -> Point -> Bool)) -> !Text -> (FilePath -> IO FilePath) -> !Version -> !FilePath -> !String -> !Text -> !Bool -> !FovMode -> !Int -> !Int -> !FilePath -> !String -> !Int -> RuleKind

+ Game.LambdaHack.Content.RuleKind: RuleKind :: !Char -> !Text -> !(Freqs RuleKind) -> !Text -> !Version -> !FilePath -> !String -> !Text -> !Bool -> !Int -> !Int -> !FilePath -> !Int -> RuleKind

- Game.LambdaHack.Content.TileKind: TileKind :: !Char -> !Text -> !(Freqs TileKind) -> !Color -> !Color -> ![Feature] -> TileKind

+ Game.LambdaHack.Content.TileKind: TileKind :: !Char -> !Text -> !(Freqs TileKind) -> !Color -> !Color -> !Word8 -> ![Feature] -> TileKind

- Game.LambdaHack.SampleImplementation.SampleMonadClient: executorCli :: CliImplementation resp req () -> SessionUI -> State -> StateClient -> ChanServer resp req -> IO ()

+ Game.LambdaHack.SampleImplementation.SampleMonadClient: executorCli :: CliImplementation () -> Maybe SessionUI -> COps -> FactionId -> ChanServer -> IO ()

- Game.LambdaHack.SampleImplementation.SampleMonadServer: executorSer :: SerImplementation () -> IO ()

+ Game.LambdaHack.SampleImplementation.SampleMonadServer: executorSer :: COps -> KeyKind -> DebugModeSer -> IO ()

- Game.LambdaHack.Server: debugArgs :: [String] -> IO DebugModeSer

+ Game.LambdaHack.Server: debugArgs :: [String] -> DebugModeSer

- Game.LambdaHack.Server: loopSer :: (MonadAtomic m, MonadServerReadRequest m) => COps -> DebugModeSer -> (FactionId -> ChanServer ResponseUI RequestUI -> IO ()) -> (FactionId -> ChanServer ResponseAI RequestAI -> IO ()) -> m ()

+ Game.LambdaHack.Server: loopSer :: (MonadAtomic m, MonadServerReadRequest m) => DebugModeSer -> Config -> (Maybe SessionUI -> COps -> FactionId -> ChanServer -> IO ()) -> m ()

- Game.LambdaHack.Server.Commandline: debugArgs :: [String] -> IO DebugModeSer

+ Game.LambdaHack.Server.Commandline: debugArgs :: [String] -> DebugModeSer

- Game.LambdaHack.Server.DungeonGen: buildLevel :: COps -> Cave -> AbsDepth -> LevelId -> LevelId -> LevelId -> AbsDepth -> Int -> Maybe Bool -> Rnd Level

+ Game.LambdaHack.Server.DungeonGen: buildLevel :: COps -> Int -> GroupName CaveKind -> Int -> AbsDepth -> [Point] -> Rnd (Level, [Point])

- Game.LambdaHack.Server.DungeonGen: convertTileMaps :: COps -> Rnd (Id TileKind) -> Maybe (Rnd (Id TileKind)) -> Int -> Int -> TileMapEM -> Rnd TileMap

+ Game.LambdaHack.Server.DungeonGen: convertTileMaps :: COps -> Bool -> Rnd (Id TileKind) -> Maybe (Rnd (Id TileKind)) -> Int -> Int -> TileMapEM -> Rnd TileMap

- Game.LambdaHack.Server.DungeonGen: levelFromCaveKind :: COps -> CaveKind -> AbsDepth -> TileMap -> ([Point], [Point]) -> Int -> Freqs ItemKind -> Int -> Freqs ItemKind -> Int -> [Point] -> Level

+ Game.LambdaHack.Server.DungeonGen: levelFromCaveKind :: COps -> CaveKind -> AbsDepth -> TileMap -> ([Point], [Point]) -> Int -> [Point] -> Bool -> Level

- Game.LambdaHack.Server.DungeonGen.Area: grid :: (X, Y) -> Area -> [(Point, Area)]

+ Game.LambdaHack.Server.DungeonGen.Area: grid :: EnumMap Point (GroupName PlaceKind) -> [Point] -> (X, Y) -> Area -> ((X, Y), EnumMap Point SpecialArea)

- Game.LambdaHack.Server.DungeonGen.AreaRnd: connectGrid :: (X, Y) -> Rnd [(Point, Point)]

+ Game.LambdaHack.Server.DungeonGen.AreaRnd: connectGrid :: EnumSet Point -> (X, Y) -> Rnd [(Point, Point)]

- Game.LambdaHack.Server.DungeonGen.AreaRnd: connectPlaces :: (Area, Area) -> (Area, Area) -> Rnd Corridor

+ Game.LambdaHack.Server.DungeonGen.AreaRnd: connectPlaces :: (Area, Fence, Area) -> (Area, Fence, Area) -> Rnd (Maybe Corridor)

- Game.LambdaHack.Server.DungeonGen.Cave: Cave :: !(Id CaveKind) -> !TileMapEM -> ![Place] -> !Bool -> Cave

+ Game.LambdaHack.Server.DungeonGen.Cave: Cave :: !(Id CaveKind) -> !Int -> !TileMapEM -> ![Place] -> !Bool -> Cave

- Game.LambdaHack.Server.DungeonGen.Cave: buildCave :: COps -> AbsDepth -> AbsDepth -> Id CaveKind -> Rnd Cave

+ Game.LambdaHack.Server.DungeonGen.Cave: buildCave :: COps -> AbsDepth -> AbsDepth -> Int -> Id CaveKind -> EnumMap Point (GroupName PlaceKind) -> Rnd Cave

- Game.LambdaHack.Server.DungeonGen.Place: buildPlace :: COps -> CaveKind -> Bool -> Id TileKind -> Id TileKind -> AbsDepth -> AbsDepth -> Area -> Rnd (TileMapEM, Place)

+ Game.LambdaHack.Server.DungeonGen.Place: buildPlace :: COps -> CaveKind -> Bool -> Id TileKind -> Id TileKind -> AbsDepth -> AbsDepth -> Int -> Area -> Maybe (GroupName PlaceKind) -> Rnd (TileMapEM, Place)

- Game.LambdaHack.Server.Fov: litInDungeon :: FovMode -> State -> StateServer -> PersLit

+ Game.LambdaHack.Server.Fov: litInDungeon :: State -> FovLitLid

- Game.LambdaHack.Server.ItemRev: buildItem :: FlavourMap -> DiscoveryKindRev -> Id ItemKind -> ItemKind -> LevelId -> Item

+ Game.LambdaHack.Server.ItemRev: buildItem :: FlavourMap -> DiscoveryKindRev -> Id ItemKind -> ItemKind -> LevelId -> Dice -> Item

- Game.LambdaHack.Server.ItemRev: newItem :: COps -> FlavourMap -> DiscoveryKindRev -> UniqueSet -> Freqs ItemKind -> Int -> LevelId -> AbsDepth -> AbsDepth -> Rnd (Maybe (ItemKnown, ItemFull, ItemDisco, ItemSeed, GroupName ItemKind))

+ Game.LambdaHack.Server.ItemRev: newItem :: COps -> FlavourMap -> DiscoveryKind -> DiscoveryKindRev -> UniqueSet -> Freqs ItemKind -> Int -> LevelId -> AbsDepth -> AbsDepth -> Rnd (Maybe (ItemKnown, ItemFull, ItemDisco, ItemSeed, GroupName ItemKind))

- Game.LambdaHack.Server.MonadServer: dumpRngs :: MonadServer m => m ()

+ Game.LambdaHack.Server.MonadServer: dumpRngs :: MonadServer m => RNGs -> m ()

- Game.LambdaHack.Server.MonadServer: registerScore :: MonadServer m => Status -> Maybe Actor -> FactionId -> m ()

+ Game.LambdaHack.Server.MonadServer: registerScore :: MonadServer m => Status -> FactionId -> m ()

- Game.LambdaHack.Server.MonadServer: restoreScore :: MonadServer m => COps -> m ScoreDict

+ Game.LambdaHack.Server.MonadServer: restoreScore :: forall m. MonadServer m => COps -> m ScoreDict

- Game.LambdaHack.Server.State: DebugModeSer :: !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !(Maybe (GroupName ModeKind)) -> !Bool -> !Bool -> !(Maybe Int) -> !(Maybe StdGen) -> !(Maybe StdGen) -> !(Maybe FovMode) -> !Bool -> !Int -> !Bool -> !(Maybe String) -> !Bool -> !DebugModeCli -> DebugModeSer

+ Game.LambdaHack.Server.State: DebugModeSer :: !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !(Maybe (GroupName ModeKind)) -> !Bool -> !Bool -> !(Maybe StdGen) -> !(Maybe StdGen) -> !Bool -> !Challenge -> !Bool -> !String -> !Bool -> !DebugModeCli -> DebugModeSer

- Game.LambdaHack.Server.State: StateServer :: !DiscoveryKind -> !DiscoveryKindRev -> !UniqueSet -> !DiscoveryEffect -> !ItemSeedDict -> !ItemRev -> !(EnumMap ItemId FovCache3) -> !FlavourMap -> !ActorId -> !ItemId -> !(EnumMap LevelId Int) -> !(EnumMap LevelId Time) -> ![CmdAtomic] -> !Pers -> !StdGen -> !RNGs -> !Bool -> !Bool -> !ClockTime -> !ClockTime -> !Time -> !(EnumMap FactionId [(Int, (Text, Text))]) -> !DebugModeSer -> !DebugModeSer -> StateServer

+ Game.LambdaHack.Server.State: StateServer :: !ActorTime -> !DiscoveryKind -> !DiscoveryKindRev -> !UniqueSet -> !DiscoveryAspect -> !ItemSeedDict -> !ItemRev -> !FlavourMap -> !ActorId -> !ItemId -> !(EnumMap LevelId Int) -> ![CmdAtomic] -> !PerFid -> !PerValidFid -> !PerCacheFid -> !ActorAspect -> !FovLucidLid -> !FovClearLid -> !FovLitLid -> ![LevelId] -> !Bool -> !StdGen -> !RNGs -> !Bool -> !Bool -> !DebugModeSer -> !DebugModeSer -> StateServer

Files

CHANGELOG.md +54/−0
CREDITS +25/−0
Game/LambdaHack/Atomic.hs +11/−3
Game/LambdaHack/Atomic/BroadcastAtomicWrite.hs +0/−186
Game/LambdaHack/Atomic/CmdAtomic.hs +69/−62
Game/LambdaHack/Atomic/HandleAtomicWrite.hs +120/−135
Game/LambdaHack/Atomic/MonadAtomic.hs +5/−22
Game/LambdaHack/Atomic/MonadStateWrite.hs +67/−22
Game/LambdaHack/Atomic/PosAtomicRead.hs +78/−168
Game/LambdaHack/Client.hs +4/−6
Game/LambdaHack/Client/AI.hs +89/−65
Game/LambdaHack/Client/AI/ConditionClient.hs +0/−386
Game/LambdaHack/Client/AI/ConditionM.hs +339/−0
Game/LambdaHack/Client/AI/HandleAbilityClient.hs +0/−962
Game/LambdaHack/Client/AI/HandleAbilityM.hs +971/−0
Game/LambdaHack/Client/AI/PickActorClient.hs +0/−268
Game/LambdaHack/Client/AI/PickActorM.hs +318/−0
Game/LambdaHack/Client/AI/PickTargetClient.hs +0/−371
Game/LambdaHack/Client/AI/PickTargetM.hs +426/−0
Game/LambdaHack/Client/AI/Preferences.hs +0/−176
Game/LambdaHack/Client/AI/Strategy.hs +5/−9
Game/LambdaHack/Client/Bfs.hs +194/−116
Game/LambdaHack/Client/BfsClient.hs +0/−368
Game/LambdaHack/Client/BfsM.hs +453/−0
Game/LambdaHack/Client/CommonClient.hs +0/−277
Game/LambdaHack/Client/CommonM.hs +221/−0
Game/LambdaHack/Client/HandleAtomicClient.hs +0/−382
Game/LambdaHack/Client/HandleAtomicM.hs +581/−0
Game/LambdaHack/Client/HandleResponseClient.hs +0/−61
Game/LambdaHack/Client/HandleResponseM.hs +50/−0
Game/LambdaHack/Client/ItemSlot.hs +0/−107
Game/LambdaHack/Client/Key.hs +0/−295
Game/LambdaHack/Client/LoopClient.hs +0/−124
Game/LambdaHack/Client/LoopM.hs +98/−0
Game/LambdaHack/Client/MonadClient.hs +41/−74
Game/LambdaHack/Client/Preferences.hs +406/−0
Game/LambdaHack/Client/ProtocolClient.hs +0/−14
Game/LambdaHack/Client/State.hs +100/−185
Game/LambdaHack/Client/UI.hs +122/−115
Game/LambdaHack/Client/UI/ActorUI.hs +103/−0
Game/LambdaHack/Client/UI/Animation.hs +114/−163
Game/LambdaHack/Client/UI/Config.hs +50/−32
Game/LambdaHack/Client/UI/Content/KeyKind.hs +169/−18
Game/LambdaHack/Client/UI/DisplayAtomicClient.hs +0/−926
Game/LambdaHack/Client/UI/DisplayAtomicM.hs +1185/−0
Game/LambdaHack/Client/UI/DrawClient.hs +0/−391
Game/LambdaHack/Client/UI/DrawM.hs +603/−0
Game/LambdaHack/Client/UI/EffectDescription.hs +317/−0
Game/LambdaHack/Client/UI/Frame.hs +82/−0
Game/LambdaHack/Client/UI/FrameM.hs +119/−0
Game/LambdaHack/Client/UI/Frontend.hs +170/−118
Game/LambdaHack/Client/UI/Frontend/Chosen.hs +13/−60
Game/LambdaHack/Client/UI/Frontend/Common.hs +71/−0
Game/LambdaHack/Client/UI/Frontend/Curses.hs +67/−58
Game/LambdaHack/Client/UI/Frontend/Dom.hs +274/−0
Game/LambdaHack/Client/UI/Frontend/Gtk.hs +174/−451
Game/LambdaHack/Client/UI/Frontend/Sdl.hs +406/−0
Game/LambdaHack/Client/UI/Frontend/Std.hs +0/−83
Game/LambdaHack/Client/UI/Frontend/Teletype.hs +84/−0
Game/LambdaHack/Client/UI/Frontend/Vty.hs +66/−104
Game/LambdaHack/Client/UI/HandleHelperM.hs +320/−0
Game/LambdaHack/Client/UI/HandleHumanClient.hs +0/−95
Game/LambdaHack/Client/UI/HandleHumanGlobalClient.hs +0/−872
Game/LambdaHack/Client/UI/HandleHumanGlobalM.hs +1375/−0
Game/LambdaHack/Client/UI/HandleHumanLocalClient.hs +0/−517
Game/LambdaHack/Client/UI/HandleHumanLocalM.hs +1065/−0
Game/LambdaHack/Client/UI/HandleHumanM.hs +124/−0
Game/LambdaHack/Client/UI/HumanCmd.hs +132/−141
Game/LambdaHack/Client/UI/InventoryClient.hs +0/−1031
Game/LambdaHack/Client/UI/InventoryM.hs +513/−0
Game/LambdaHack/Client/UI/ItemDescription.hs +243/−0
Game/LambdaHack/Client/UI/ItemSlot.hs +93/−0
Game/LambdaHack/Client/UI/Key.hs +507/−0
Game/LambdaHack/Client/UI/KeyBindings.hs +205/−99
Game/LambdaHack/Client/UI/MonadClientUI.hs +322/−317
Game/LambdaHack/Client/UI/Msg.hs +170/−0
Game/LambdaHack/Client/UI/MsgClient.hs +0/−149
Game/LambdaHack/Client/UI/MsgM.hs +40/−0
Game/LambdaHack/Client/UI/Overlay.hs +228/−0
Game/LambdaHack/Client/UI/OverlayM.hs +85/−0
Game/LambdaHack/Client/UI/RunClient.hs +0/−238
Game/LambdaHack/Client/UI/RunM.hs +244/−0
Game/LambdaHack/Client/UI/SessionUI.hs +210/−0
Game/LambdaHack/Client/UI/Slideshow.hs +120/−0
Game/LambdaHack/Client/UI/SlideshowM.hs +198/−0
Game/LambdaHack/Client/UI/StartupFrontendClient.hs +0/−67
Game/LambdaHack/Client/UI/WidgetClient.hs +0/−217
Game/LambdaHack/Common/Ability.hs +29/−7
Game/LambdaHack/Common/Actor.hs +85/−198
Game/LambdaHack/Common/ActorState.hs +215/−308
Game/LambdaHack/Common/ClientOptions.hs +43/−22
Game/LambdaHack/Common/Color.hs +115/−31
Game/LambdaHack/Common/ContentDef.hs +17/−8
Game/LambdaHack/Common/Dice.hs +36/−28
Game/LambdaHack/Common/EffectDescription.hs +0/−187
Game/LambdaHack/Common/Faction.hs +77/−75
Game/LambdaHack/Common/File.hs +8/−97
Game/LambdaHack/Common/Flavour.hs +4/−2
Game/LambdaHack/Common/Frequency.hs +14/−20
Game/LambdaHack/Common/HSFile.hs +69/−0
Game/LambdaHack/Common/HighScore.hs +35/−43
Game/LambdaHack/Common/Item.hs +290/−44
Game/LambdaHack/Common/ItemDescription.hs +0/−208
Game/LambdaHack/Common/ItemStrongest.hs +97/−182
Game/LambdaHack/Common/JSFile.hs +85/−0
Game/LambdaHack/Common/Kind.hs +41/−65
Game/LambdaHack/Common/KindOps.hs +37/−0
Game/LambdaHack/Common/LQueue.hs +0/−59
Game/LambdaHack/Common/Level.hs +108/−129
Game/LambdaHack/Common/Misc.hs +87/−55
Game/LambdaHack/Common/MonadStateRead.hs +42/−20
Game/LambdaHack/Common/Msg.hs +0/−275
Game/LambdaHack/Common/Perception.hs +41/−24
Game/LambdaHack/Common/Point.hs +23/−22
Game/LambdaHack/Common/PointArray.hs +133/−51
Game/LambdaHack/Common/Prelude.hs +52/−0
Game/LambdaHack/Common/Random.hs +26/−10
Game/LambdaHack/Common/Request.hs +100/−90
Game/LambdaHack/Common/Response.hs +21/−12
Game/LambdaHack/Common/RingBuffer.hs +26/−17
Game/LambdaHack/Common/Save.hs +65/−31
Game/LambdaHack/Common/State.hs +20/−28
Game/LambdaHack/Common/Thread.hs +4/−0
Game/LambdaHack/Common/Tile.hs +176/−156
Game/LambdaHack/Common/Time.hs +77/−29
Game/LambdaHack/Common/Vector.hs +45/−34
Game/LambdaHack/Content/CaveKind.hs +24/−16
Game/LambdaHack/Content/ItemKind.hs +181/−106
Game/LambdaHack/Content/ModeKind.hs +64/−49
Game/LambdaHack/Content/PlaceKind.hs +8/−9
Game/LambdaHack/Content/RuleKind.hs +8/−46
Game/LambdaHack/Content/TileKind.hs +207/−56
Game/LambdaHack/SampleImplementation/SampleMonadClient.hs +105/−60
Game/LambdaHack/SampleImplementation/SampleMonadServer.hs +87/−55
Game/LambdaHack/Server.hs +7/−8
Game/LambdaHack/Server/BroadcastAtomic.hs +206/−0
Game/LambdaHack/Server/Commandline.hs +89/−43
Game/LambdaHack/Server/CommonM.hs +488/−0
Game/LambdaHack/Server/CommonServer.hs +0/−491
Game/LambdaHack/Server/DebugM.hs +94/−0
Game/LambdaHack/Server/DebugServer.hs +0/−96
Game/LambdaHack/Server/DungeonGen.hs +168/−193
Game/LambdaHack/Server/DungeonGen/Area.hs +79/−12
Game/LambdaHack/Server/DungeonGen/AreaRnd.hs +151/−90
Game/LambdaHack/Server/DungeonGen/Cave.hs +232/−108
Game/LambdaHack/Server/DungeonGen/Place.hs +144/−85
Game/LambdaHack/Server/EndM.hs +86/−0
Game/LambdaHack/Server/EndServer.hs +0/−90
Game/LambdaHack/Server/Fov.hs +316/−195
Game/LambdaHack/Server/Fov/Common.hs +0/−73
Game/LambdaHack/Server/Fov/Digital.hs +0/−174
Game/LambdaHack/Server/Fov/Permissive.hs +0/−156
Game/LambdaHack/Server/Fov/Shadow.hs +0/−111
Game/LambdaHack/Server/FovDigital.hs +254/−0
Game/LambdaHack/Server/HandleAtomicM.hs +300/−0
Game/LambdaHack/Server/HandleEffectM.hs +1331/−0
Game/LambdaHack/Server/HandleEffectServer.hs +0/−1115
Game/LambdaHack/Server/HandleRequestM.hs +611/−0
Game/LambdaHack/Server/HandleRequestServer.hs +0/−540
Game/LambdaHack/Server/ItemM.hs +182/−0
Game/LambdaHack/Server/ItemRev.hs +59/−37
Game/LambdaHack/Server/ItemServer.hs +0/−213
Game/LambdaHack/Server/LoopM.hs +513/−0
Game/LambdaHack/Server/LoopServer.hs +0/−440
Game/LambdaHack/Server/MonadServer.hs +74/−155
Game/LambdaHack/Server/PeriodicM.hs +269/−0
Game/LambdaHack/Server/PeriodicServer.hs +0/−345
Game/LambdaHack/Server/ProtocolM.hs +201/−0
Game/LambdaHack/Server/ProtocolServer.hs +0/−225
Game/LambdaHack/Server/StartM.hs +351/−0
Game/LambdaHack/Server/StartServer.hs +0/−370
Game/LambdaHack/Server/State.hs +94/−88
GameDefinition/Client/UI/Content/KeyKind.hs +248/−180
GameDefinition/Content/CaveKind.hs +291/−142
GameDefinition/Content/ItemKind.hs +1233/−989
GameDefinition/Content/ItemKindActor.hs +185/−111
GameDefinition/Content/ItemKindBlast.hs +313/−176
GameDefinition/Content/ItemKindEmbed.hs +275/−0
GameDefinition/Content/ItemKindOrgan.hs +168/−147
GameDefinition/Content/ItemKindTemporary.hs +44/−26
GameDefinition/Content/ModeKind.hs +347/−255
GameDefinition/Content/ModeKindPlayer.hs +53/−62
GameDefinition/Content/PlaceKind.hs +498/−101
GameDefinition/Content/RuleKind.hs +25/−36
GameDefinition/Content/TileKind.hs +496/−165
GameDefinition/InGameHelp.txt +178/−0
GameDefinition/Main.hs +11/−2
GameDefinition/MainMenu.ascii +24/−26
GameDefinition/PLAYING.md +191/−145
GameDefinition/TieKnot.hs +66/−28
GameDefinition/config.ui.default +9/−6
GameDefinition/fonts/16x16x.fon binary
GameDefinition/fonts/8x8x.fon binary
GameDefinition/fonts/8x8xb.fon binary
GameDefinition/fonts/Fix15Mono-Bold.woff binary
GameDefinition/fonts/LICENSE.16x16x +339/−0
GameDefinition/fonts/LICENSE.Fix15Mono-Bold +94/−0
GameDefinition/scores binary
LICENSE +17/−2
LambdaHack.cabal +300/−256
Makefile +125/−192
README.md +154/−100
test/test.hs +2/−2

CHANGELOG.md view

@@ -1,3 +1,57 @@+## [v0.6.0.0, aka 'Too much to tell'](https://github.com/LambdaHack/LambdaHack/compare/v0.5.0.0...v0.6.0.0)++- add and modify a lot of content: items, tiles, embedded items, scenarios+- improve AI: targeting, stealth, moving in groups, item use, fleeing, etc.+- make monsters more aggressive than animals+- tie scenarios into a loose, optional storyline+- add more level generators and more variety to room placement+- make stairs not walkable and use them by bumping+- align stair position on the levels they pass through+- introduce noctovision+- increase human vision to 12 so that normal speed missiles can be sidestepped+- tweak and document weapon damage calculation+- derive projectile damage mostly from their speed+- make heavy projectiles better vs armor but easier to sidestep+- improve hearing of unseen actions, actors and missiles impacts+- let some missiles lit up on impact+- make torches reusable flares and add blankets for dousing dynamic light+- add detection effects and use them in items and tiles+- make it possible to catch missiles, if not using weapons+- make it possible to wait 0.1 of a turn, at the cost of no bracing+- improve pathfinding, prefer less unknown, alterable and dark tiles on paths+- slow down actors when acting at the same time, for speed with large factions+- don't halve Calm at serious damage any more+- eliminate alternative FOV modes, for speed+- stop actors blocking FOV, for speed+- let actor move diagonally to and from doors, for speed+- improve blast (explosion) shapes visually and gameplay-wise+- add SDL2 frontend and deprecate GTK frontend+- add specialized square bitmap fonts and hack a scalable font+- use middle dot instead of period on the map (except in teletype frontend)+- add a browser frontend based on DOM, using ghcjs+- improve targeting UI, e.g., cycle among items on the map+- show an animation when actor teleports+- add character stats menu and stat description texts+- add item lore and organ lore menus+- add a command to sort item slots and perform the sort at startup+- add a single item manipulation menu and let it mark an item for later+- make history display a menu and improve display of individual messages+- display highscore dates according to the local timezone+- make the help screen a menu, execute actions directly from it+- rework the Main Menu+- rework special positions highlight in all frontends+- mark leader's target on the map (grey highlight)+- visually mark currently chosen menu item and grey out impossible items+- define mouse commands based on UI mode and screen area+- let the game be fully playable only with mouse, use mouse wheel+- pick menu items with mouse and with arrow keys+- add more sanity checks for content+- reorganize content in files to make rebasing on changed content easier+- rework keybinding definition machinery+- let clients, not the server, start frontends+- version savefiles and move them aside if versions don't match+- lots of bug fixes internal improvements and minor visual and text tweaks+ ## [v0.5.0.0, aka 'Halfway through space'](https://github.com/LambdaHack/LambdaHack/compare/v0.4.101.0...v0.5.0.0)  - let AI put excess items in shared stash and use them out of shared stash

CREDITS view

@@ -4,3 +4,28 @@ Andres Loeh Mikolaj Konarski Tuukka Turto+++Fonts 16x16x.fon, 8x8x.fon and 8x8xb.fon are are taken from+https://github.com/angband/angband, copyrighted by Leon Marrick,+Sheldon Simms III and Nick McConnell and released by them under+GNU GPL version 2. Any further modifications by authors of LambdaHack+are also released under GNU GPL version 2. The licence file is at+GameDefinition/fonts/LICENSE.16x16x++Font Fix15Mono-Bold.woff is a modified version of+https://github.com/mozilla/Fira/blob/master/ttf/FiraMono-Bold.ttf+that is copyright 2012-2015, The Mozilla Foundation and Telefonica S.A.+The modified font is released under the SIL Open Font License, as seen in+GameDefinition/fonts/LICENSE.Fix15Mono-Bold+Modifications were performed with font editor FontForge and are as follows:+* straighten and enlarge #, enlarge %, &, ', +, \,, -, :, ;, O, _, `+* centre a few other glyphs+* create a small 0x22c5+* shrink 0xb7 a bit+* extend all fonts by 150% and 150%+    (the extension resulted in an artifact in letter 'n',+     which was gleefully kept, and many other artifacts and distortions+     that should be fixed at some point)+* set width of space, nbsp and # glyphs to 1170+    (this is a hack to make DOM create square table cells)

Game/LambdaHack/Atomic.hs view

@@ -5,14 +5,22 @@ module Game.LambdaHack.Atomic   ( -- * Re-exported from "Game.LambdaHack.Atomic.MonadAtomic"     MonadAtomic(..)-  , broadcastUpdAtomic, broadcastSfxAtomic     -- * Re-exported from "Game.LambdaHack.Atomic.CmdAtomic"-  , CmdAtomic(..), UpdAtomic(..), SfxAtomic(..), HitAtomic(..)+  , CmdAtomic(..), UpdAtomic(..), SfxAtomic(..), SfxMsg(..)     -- * Re-exported from "Game.LambdaHack.Atomic.PosAtomicRead"-  , PosAtomic(..), posUpdAtomic, posSfxAtomic, seenAtomicCli, generalMoveItem+  , PosAtomic(..), posUpdAtomic, posSfxAtomic, breakUpdAtomic+  , seenAtomicCli, seenAtomicSer, generalMoveItem   , posProjBody+    -- * Re-exported from "Game.LambdaHack.Atomic.MonadStateWrite"+  , MonadStateWrite(..)+    -- * Re-exported from "Game.LambdaHack.Atomic.HandleAtomicWrite"+  , handleUpdAtomic   ) where +import Prelude ()+ import Game.LambdaHack.Atomic.CmdAtomic+import Game.LambdaHack.Atomic.HandleAtomicWrite import Game.LambdaHack.Atomic.MonadAtomic+import Game.LambdaHack.Atomic.MonadStateWrite import Game.LambdaHack.Atomic.PosAtomicRead

− Game/LambdaHack/Atomic/BroadcastAtomicWrite.hs

@@ -1,186 +0,0 @@--- | Sending atomic commands to clients and executing them on the server.--- See--- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.-module Game.LambdaHack.Atomic.BroadcastAtomicWrite-  ( handleAndBroadcast-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Key (mapWithKeyM_)-import Data.Maybe--import Game.LambdaHack.Atomic.CmdAtomic-import Game.LambdaHack.Atomic.HandleAtomicWrite-import Game.LambdaHack.Atomic.MonadStateWrite-import Game.LambdaHack.Atomic.PosAtomicRead-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Response-import Game.LambdaHack.Common.State-import Game.LambdaHack.Content.ModeKind---- TODO: split into simpler pieces----storeUndo :: MonadServer m => CmdAtomic -> m ()---storeUndo _atomic =---  maybe skip (\a -> modifyServer $ \ser -> ser {sundo = a : sundo ser})---    $ Nothing   -- TODO: undoCmdAtomic atomic--handleCmdAtomicServer :: forall m. MonadStateWrite m-                      => PosAtomic -> CmdAtomic -> m ()-handleCmdAtomicServer posAtomic atomic =-  when (seenAtomicSer posAtomic) $---    storeUndo atomic-    handleCmdAtomic atomic---- | Send an atomic action to all clients that can see it.-handleAndBroadcast :: forall m a. MonadStateWrite m-                   => Bool -> Pers-                   -> (a -> FactionId -> LevelId -> m Perception)-                   -> m a-                   -> (FactionId -> ResponseAI -> m ())-                   -> (FactionId -> ResponseUI -> m ())-                   -> CmdAtomic-                   -> m ()-handleAndBroadcast knowEvents persOld doResetFidPerception doResetLitInDungeon-                   doSendUpdateAI doSendUpdateUI atomic = do-  -- Gather data from the old state.-  sOld <- getState-  factionD <- getsState sfactionD-  (ps, resets, atomicBroken, psBroken) <--    case atomic of-      UpdAtomic cmd -> do-        ps <- posUpdAtomic cmd-        let resets = resetsFovCmdAtomic cmd-        atomicBroken <- breakUpdAtomic cmd-        psBroken <- mapM posUpdAtomic atomicBroken-        return (ps, resets, map UpdAtomic atomicBroken, psBroken)-      SfxAtomic sfx -> do-        ps <- posSfxAtomic sfx-        atomicBroken <- breakSfxAtomic sfx-        psBroken <- mapM posSfxAtomic atomicBroken-        return (ps, False, map SfxAtomic atomicBroken, psBroken)-  let atomicPsBroken = zip atomicBroken psBroken-  -- TODO: assert also that the sum of psBroken is equal to ps;-  -- with deep equality these assertions can be expensive; optimize.-  let !_A = assert (case ps of-                      PosSight{} -> True-                      PosFidAndSight{} -> True-                      PosFidAndSer (Just _) _ -> True-                      _ -> not resets-                   `blame` (ps, resets)) ()-  -- Perform the action on the server.-  handleCmdAtomicServer ps atomic-  -- Update lights in the dungeon. This is lazy, may not be needed or partially.-  persLit <- doResetLitInDungeon-  -- Send some actions to the clients, one faction at a time.-  let sendUI fid cmdUI =-        when (fhasUI $ gplayer $ factionD EM.! fid) $ doSendUpdateUI fid cmdUI-      sendAI = doSendUpdateAI-      sendA fid cmd = do-        sendUI fid $ RespUpdAtomicUI cmd-        sendAI fid $ RespUpdAtomicAI cmd-      sendUpdate fid (UpdAtomic cmd) = sendA fid cmd-      sendUpdate fid (SfxAtomic sfx) = sendUI fid $ RespSfxAtomicUI sfx-      breakSend lid fid perNew = do-        let send2 (atomic2, ps2) =-              if seenAtomicCli knowEvents fid perNew ps2-                then sendUpdate fid atomic2-                else do-                  mleader <- getsState $ gleader . (EM.! fid) . sfactionD-                  case (atomic2, mleader) of-                    (UpdAtomic cmd, Just (leader, _)) -> do-                      body <- getsState $ getActorBody leader-                      loud <- loudUpdAtomic (blid body == lid) fid cmd-                      case loud of-                        Nothing -> return ()-                        Just msg -> sendUpdate fid $ SfxAtomic $ SfxMsgAll msg-                    _ -> return ()-        mapM_ send2 atomicPsBroken-      anySend lid fid perOld perNew = do-        let startSeen = seenAtomicCli knowEvents fid perOld ps-            endSeen = seenAtomicCli knowEvents fid perNew ps-        if startSeen && endSeen-          then sendUpdate fid atomic-          else breakSend lid fid perNew-      posLevel fid lid = do-        let perOld = persOld EM.! fid EM.! lid-        if resets then do-          perNew <- doResetFidPerception persLit fid lid-          let inPer = diffPer perNew perOld-              outPer = diffPer perOld perNew-          if nullPer outPer && nullPer inPer-            then anySend lid fid perOld perOld-            else do-              unless knowEvents $ do  -- inconsistencies would quickly manifest-                sendA fid $ UpdPerception lid outPer inPer-                let remember = atomicRemember lid inPer sOld-                    seenNew = seenAtomicCli False fid perNew-                    seenOld = seenAtomicCli False fid perOld-                psRem <- mapM posUpdAtomic remember-                -- Verify that we remember only currently seen things.-                let !_A = assert (allB seenNew psRem) ()-                -- Verify that we remember only new things.-                let !_A = assert (allB (not . seenOld) psRem) ()-                mapM_ (sendA fid) remember-              anySend lid fid perOld perNew-        else anySend lid fid perOld perOld-      send fid = case ps of-        PosSight lid _ -> posLevel fid lid-        PosFidAndSight _ lid _ -> posLevel fid lid-        -- In the following cases, from the assertion above,-        -- @resets@ is false here and broken atomic has the same ps.-        PosSmell lid _ -> do-          let perOld = persOld EM.! fid EM.! lid-          anySend lid fid perOld perOld-        PosFid fid2 -> when (fid == fid2) $ sendUpdate fid atomic-        PosFidAndSer Nothing fid2 -> when (fid == fid2) $ sendUpdate fid atomic-        PosFidAndSer (Just lid) _ -> posLevel fid lid-        PosSer -> return ()-        PosAll -> sendUpdate fid atomic-        PosNone -> return ()-  mapWithKeyM_ (\fid _ -> send fid) factionD--atomicRemember :: LevelId -> Perception -> State -> [UpdAtomic]-atomicRemember lid inPer s =-  -- No @UpdLoseItem@ is sent for items that became out of sight.-  -- The client will create these atomic actions based on @outPer@,-  -- if required. Any client that remembers out of sight items, OTOH,-  -- will create atomic actions that forget remembered items-  -- that are revealed not to be there any more (no @UpdSpotItem@ for them).-  -- Similarly no @UpdLoseActor@, @UpdLoseTile@ nor @UpdLoseSmell@.-  let inFov = ES.elems $ totalVisible inPer-      lvl = sdungeon s EM.! lid-      -- Actors.-      carriedAssocs b = getCarriedAssocs b s-      inPrio = concatMap (\p -> posToActors p lid s) inFov-      fActor (aid, b) =-        let ais = carriedAssocs b-        in UpdSpotActor aid b ais-      inActor = map fActor inPrio-      -- Items.-      pMaybe p = maybe Nothing (\x -> Just (p, x))-      inContainer fc itemFloor =-        let inItem = mapMaybe (\p -> pMaybe p $ EM.lookup p itemFloor) inFov-            fItem p (iid, kit) =-              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]-      -- Smells.-      inSmellFov = ES.elems $ smellVisible inPer-      inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p (lsmell lvl)) inSmellFov-      atomicSmell = if null inSm then [] else [UpdSpotSmell lid inSm]-  in inFloor ++ inEmbed ++ inActor ++ atomicTile ++ atomicSmell

Game/LambdaHack/Atomic/CmdAtomic.hs view

@@ -13,33 +13,34 @@ -- See -- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>. module Game.LambdaHack.Atomic.CmdAtomic-  ( CmdAtomic(..), UpdAtomic(..), SfxAtomic(..), HitAtomic(..)+  ( CmdAtomic(..), UpdAtomic(..), SfxAtomic(..), SfxMsg(..)   , undoUpdAtomic, undoSfxAtomic, undoCmdAtomic   ) where -import Control.Applicative+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Data.Binary import Data.Int (Int64) import GHC.Generics (Generic)  import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ClientOptions-import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Request import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.TileKind (TileKind)-import qualified Game.LambdaHack.Content.TileKind as TK  -- | Abstract syntax of atomic commands, that is, atomic game state -- transformations.@@ -62,24 +63,20 @@   | UpdDestroyItem !ItemId !Item !ItemQuant !Container   | UpdSpotActor !ActorId !Actor ![(ItemId, Item)]   | UpdLoseActor !ActorId !Actor ![(ItemId, Item)]-  | UpdSpotItem !ItemId !Item !ItemQuant !Container-  | UpdLoseItem !ItemId !Item !ItemQuant !Container+  | UpdSpotItem !Bool !ItemId !Item !ItemQuant !Container+  | UpdLoseItem !Bool !ItemId !Item !ItemQuant !Container   -- Move actors and items.   | UpdMoveActor !ActorId !Point !Point   | UpdWaitActor !ActorId !Bool   | UpdDisplaceActor !ActorId !ActorId   | UpdMoveItem !ItemId !Int !ActorId !CStore !CStore   -- Change actor attributes.-  | UpdAgeActor !ActorId !(Delta Time)   | UpdRefillHP !ActorId !Int64   | UpdRefillCalm !ActorId !Int64-  | UpdFidImpressedActor !ActorId !FactionId !FactionId   | UpdTrajectory !ActorId !(Maybe ([Vector], Speed)) !(Maybe ([Vector], Speed))-  | UpdColorActor !ActorId !Color.Color !Color.Color   -- Change faction attributes.-  | UpdQuitFaction !FactionId !(Maybe Actor) !(Maybe Status) !(Maybe Status)-  | UpdLeadFaction !FactionId !(Maybe (ActorId, Maybe Target))-                              !(Maybe (ActorId, Maybe Target))+  | UpdQuitFaction !FactionId !(Maybe Status) !(Maybe Status)+  | UpdLeadFaction !FactionId !(Maybe ActorId) !(Maybe ActorId)   | UpdDiplFaction !FactionId !FactionId !Diplomacy !Diplomacy   | UpdTacticFaction !FactionId !Tactic !Tactic   | UpdAutoFaction !FactionId !Bool@@ -87,31 +84,31 @@   -- Alter map.   | UpdAlterTile !LevelId !Point !(Kind.Id TileKind) !(Kind.Id TileKind)   | UpdAlterClear !LevelId !Int-  | UpdSearchTile !ActorId !Point !(Kind.Id TileKind) !(Kind.Id TileKind)-  | UpdLearnSecrets !ActorId !Int !Int+  | UpdSearchTile !ActorId !Point !(Kind.Id TileKind)+  | UpdHideTile !ActorId !Point !(Kind.Id TileKind)   | UpdSpotTile !LevelId ![(Point, Kind.Id TileKind)]   | UpdLoseTile !LevelId ![(Point, Kind.Id TileKind)]-  | UpdAlterSmell !LevelId !Point !(Maybe Time) !(Maybe Time)+  | UpdAlterSmell !LevelId !Point !Time !Time   | UpdSpotSmell !LevelId ![(Point, Time)]   | UpdLoseSmell !LevelId ![(Point, Time)]   -- Assorted.   | UpdTimeItem !ItemId !Container !ItemTimer !ItemTimer-  | UpdAgeGame !(Delta Time) ![LevelId]-  | UpdDiscover !Container !ItemId !(Kind.Id ItemKind) !ItemSeed !AbsDepth-  | UpdCover !Container !ItemId !(Kind.Id ItemKind) !ItemSeed !AbsDepth+  | UpdAgeGame ![LevelId]+  | UpdUnAgeGame ![LevelId]+  | UpdDiscover !Container !ItemId !(Kind.Id ItemKind) !ItemSeed+  | UpdCover !Container !ItemId !(Kind.Id ItemKind) !ItemSeed   | UpdDiscoverKind !Container !ItemId !(Kind.Id ItemKind)   | UpdCoverKind !Container !ItemId !(Kind.Id ItemKind)-  | UpdDiscoverSeed !Container !ItemId !ItemSeed !AbsDepth-  | UpdCoverSeed !Container !ItemId !ItemSeed !AbsDepth+  | UpdDiscoverSeed !Container !ItemId !ItemSeed+  | UpdCoverSeed !Container !ItemId !ItemSeed   | UpdPerception !LevelId !Perception !Perception-  | UpdRestart !FactionId !DiscoveryKind !FactionPers !State !Int !DebugModeCli+  | UpdRestart !FactionId !DiscoveryKind !PerLid !State !Challenge !DebugModeCli   | UpdRestartServer !State-  | UpdResume !FactionId !FactionPers+  | UpdResume !FactionId !PerLid   | UpdResumeServer !State   | UpdKillExit !FactionId   | UpdWriteSave-  | UpdMsgAll !Msg-  | UpdRecordHistory !FactionId+  | UpdMsgAll !Text   deriving (Show, Eq, Generic)  instance Binary UpdAtomic@@ -119,27 +116,42 @@ -- | Abstract syntax of atomic special effects, that is, atomic commands -- that only display special effects and don't change the state. data SfxAtomic =-    SfxStrike !ActorId !ActorId !ItemId !CStore !HitAtomic-  | SfxRecoil !ActorId !ActorId !ItemId !CStore !HitAtomic+    SfxStrike !ActorId !ActorId !ItemId !CStore+  | SfxRecoil !ActorId !ActorId !ItemId !CStore+  | SfxSteal !ActorId !ActorId !ItemId !CStore+  | SfxRelease !ActorId !ActorId !ItemId !CStore   | SfxProject !ActorId !ItemId !CStore-  | SfxCatch !ActorId !ItemId !CStore+  | SfxReceive !ActorId !ItemId !CStore   | SfxApply !ActorId !ItemId !CStore   | SfxCheck !ActorId !ItemId !CStore-  | SfxTrigger !ActorId !Point !TK.Feature-  | SfxShun !ActorId !Point !TK.Feature-  | SfxEffect !FactionId !ActorId !IK.Effect-  | SfxMsgFid !FactionId !Msg-  | SfxMsgAll !Msg-  | SfxActorStart !ActorId+  | SfxTrigger !ActorId !Point+  | SfxShun !ActorId !Point+  | SfxEffect !FactionId !ActorId !IK.Effect !Int64+  | SfxMsgFid !FactionId !SfxMsg   deriving (Show, Eq, Generic)  instance Binary SfxAtomic --- | Determine if a strike special effect should depict a block of an attack.-data HitAtomic = HitClear | HitBlock !Int+data SfxMsg =+    SfxUnexpected !ReqFailure+  | SfxLoudUpd !Bool !UpdAtomic+  | SfxLoudStrike !Bool !(Kind.Id ItemKind) !Int+  | SfxFizzles+  | SfxVoidDetection+  | SfxSummonLackCalm !ActorId+  | SfxLevelNoMore+  | SfxLevelPushed+  | SfxBracedImmune !ActorId+  | SfxEscapeImpossible+  | SfxTransImpossible+  | SfxIdentifyNothing !CStore+  | SfxPurposeNothing !CStore+  | SfxPurposeTooFew !Int !Int+  | SfxPurposeUnique+  | SfxColdFish   deriving (Show, Eq, Generic) -instance Binary HitAtomic+instance Binary SfxMsg  undoUpdAtomic :: UpdAtomic -> Maybe UpdAtomic undoUpdAtomic cmd = case cmd of@@ -149,20 +161,16 @@   UpdDestroyItem iid item k c -> Just $ UpdCreateItem iid item k c   UpdSpotActor aid body ais -> Just $ UpdLoseActor aid body ais   UpdLoseActor aid body ais -> Just $ UpdSpotActor aid body ais-  UpdSpotItem iid item k c -> Just $ UpdLoseItem iid item k c-  UpdLoseItem iid item k c -> Just $ UpdSpotItem iid item k c+  UpdSpotItem verbose iid item k c -> Just $ UpdLoseItem verbose iid item k c+  UpdLoseItem verbose iid item k c -> Just $ UpdSpotItem verbose iid item k c   UpdMoveActor aid fromP toP -> Just $ UpdMoveActor aid toP fromP   UpdWaitActor aid toWait -> Just $ UpdWaitActor aid (not toWait)   UpdDisplaceActor source target -> Just $ UpdDisplaceActor target source   UpdMoveItem iid k aid c1 c2 -> Just $ UpdMoveItem iid k aid c2 c1-  UpdAgeActor aid delta -> Just $ UpdAgeActor aid (timeDeltaReverse delta)   UpdRefillHP aid n -> Just $ UpdRefillHP aid (-n)   UpdRefillCalm aid n -> Just $ UpdRefillCalm aid (-n)-  UpdFidImpressedActor aid fromFid toFid ->-    Just $ UpdFidImpressedActor aid toFid fromFid   UpdTrajectory aid fromT toT -> Just $ UpdTrajectory aid toT fromT-  UpdColorActor aid fromCol toCol -> Just $ UpdColorActor aid toCol fromCol-  UpdQuitFaction fid mb fromSt toSt -> Just $ UpdQuitFaction fid mb toSt fromSt+  UpdQuitFaction fid fromSt toSt -> Just $ UpdQuitFaction fid toSt fromSt   UpdLeadFaction fid source target -> Just $ UpdLeadFaction fid target source   UpdDiplFaction fid1 fid2 fromDipl toDipl ->     Just $ UpdDiplFaction fid1 fid2 toDipl fromDipl@@ -172,22 +180,22 @@   UpdAlterTile lid p fromTile toTile ->     Just $ UpdAlterTile lid p toTile fromTile   UpdAlterClear lid delta -> Just $ UpdAlterClear lid (-delta)-  UpdSearchTile aid p fromTile toTile ->-    Just $ UpdSearchTile aid p toTile fromTile-  UpdLearnSecrets aid fromS toS -> Just $ UpdLearnSecrets aid toS fromS+  UpdSearchTile aid p toTile -> Just $ UpdHideTile aid p toTile+  UpdHideTile aid p toTile -> Just $ UpdSearchTile aid p toTile   UpdSpotTile lid ts -> Just $ UpdLoseTile lid ts   UpdLoseTile lid ts -> Just $ UpdSpotTile lid ts   UpdAlterSmell lid p fromSm toSm -> Just $ UpdAlterSmell lid p toSm fromSm   UpdSpotSmell lid sms -> Just $ UpdLoseSmell lid sms   UpdLoseSmell lid sms -> Just $ UpdSpotSmell lid sms   UpdTimeItem iid c fromIt toIt -> Just $ UpdTimeItem iid c toIt fromIt-  UpdAgeGame delta lids -> Just $ UpdAgeGame (timeDeltaReverse delta) lids-  UpdDiscover c iid ik seed ldepth -> Just $ UpdCover c iid ik seed ldepth-  UpdCover c iid ik seed ldepth -> Just $ UpdDiscover c iid ik seed ldepth+  UpdAgeGame lids -> Just $ UpdUnAgeGame lids+  UpdUnAgeGame lids -> Just $ UpdAgeGame lids+  UpdDiscover c iid ik seed -> Just $ UpdCover c iid ik seed+  UpdCover c iid ik seed -> Just $ UpdDiscover c iid ik seed   UpdDiscoverKind c iid ik -> Just $ UpdCoverKind c iid ik   UpdCoverKind c iid ik -> Just $ UpdDiscoverKind c iid ik-  UpdDiscoverSeed c iid seed ldepth -> Just $ UpdCoverSeed c iid seed ldepth-  UpdCoverSeed c iid seed ldepth -> Just $ UpdDiscoverSeed c iid seed ldepth+  UpdDiscoverSeed c iid seed -> Just $ UpdCoverSeed c iid seed+  UpdCoverSeed c iid seed -> Just $ UpdDiscoverSeed c iid seed   UpdPerception lid outPer inPer -> Just $ UpdPerception lid inPer outPer   UpdRestart{} -> Just cmd  -- here history ends; change direction   UpdRestartServer{} -> Just cmd  -- here history ends; change direction@@ -195,23 +203,22 @@   UpdResumeServer{} -> Nothing   UpdKillExit{} -> Nothing   UpdWriteSave -> Nothing-  UpdMsgAll{} -> Nothing  -- only generated by @cmdAtomicFilterCli@-  UpdRecordHistory{} -> Just cmd+  UpdMsgAll{} -> Nothing  -- only generated by @cmdAtomicFilterCli@ or as a hack  undoSfxAtomic :: SfxAtomic -> SfxAtomic undoSfxAtomic cmd = case cmd of-  SfxStrike source target iid cstore b -> SfxRecoil source target iid cstore b-  SfxRecoil source target iid cstore b -> SfxStrike source target iid cstore b-  SfxProject aid iid cstore -> SfxCatch aid iid cstore-  SfxCatch aid iid cstore -> SfxProject aid iid cstore+  SfxStrike source target iid cstore -> SfxRecoil source target iid cstore+  SfxRecoil source target iid cstore -> SfxStrike source target iid cstore+  SfxSteal source target iid cstore -> SfxRelease source target iid cstore+  SfxRelease source target iid cstore -> SfxSteal source target iid cstore+  SfxProject aid iid cstore -> SfxReceive aid iid cstore+  SfxReceive aid iid cstore -> SfxProject aid iid cstore   SfxApply aid iid cstore -> SfxCheck aid iid cstore   SfxCheck aid iid cstore -> SfxApply aid iid cstore-  SfxTrigger aid p feat -> SfxShun aid p feat-  SfxShun aid p feat -> SfxTrigger aid p feat+  SfxTrigger aid p -> SfxShun aid p+  SfxShun aid p -> SfxTrigger aid p   SfxEffect{} -> cmd  -- not ideal?   SfxMsgFid{} -> cmd-  SfxMsgAll{} -> cmd-  SfxActorStart{} -> cmd  undoCmdAtomic :: CmdAtomic -> Maybe CmdAtomic undoCmdAtomic (UpdAtomic cmd) = UpdAtomic <$> undoUpdAtomic cmd

Game/LambdaHack/Atomic/HandleAtomicWrite.hs view

@@ -2,23 +2,31 @@ -- See -- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>. module Game.LambdaHack.Atomic.HandleAtomicWrite-  ( handleCmdAtomic+  ( handleUpdAtomic+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , updCreateActor, updDestroyActor, updCreateItem, updDestroyItem+  , updMoveActor, updWaitActor, updDisplaceActor, updMoveItem+  , updRefillHP, updRefillCalm+  , updTrajectory, updQuitFaction, updLeadFaction+  , updDiplFaction, updTacticFaction, updAutoFaction, updRecordKill+  , updAlterTile, updAlterClear, updSpotTile, updLoseTile+  , updAlterSmell, updSpotSmell, updLoseSmell, updTimeItem+  , updAgeGame, updUnAgeGame, updRestart, updRestartServer, updResumeServer+#endif   ) where -import Control.Applicative-import Control.Arrow (second)-import Control.Exception.Assert.Sugar-import Control.Monad+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import qualified Data.EnumMap.Strict as EM import Data.Int (Int64)-import Data.List-import Data.Maybe  import Game.LambdaHack.Atomic.CmdAtomic import Game.LambdaHack.Atomic.MonadStateWrite import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind@@ -34,15 +42,10 @@ import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ItemKind (ItemKind) import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.TileKind (TileKind)+import Game.LambdaHack.Content.TileKind (TileKind, unknownId)  -- | The game-state semantics of atomic game commands. -- Special effects (@SfxAtomic@) don't modify state.-handleCmdAtomic :: MonadStateWrite m => CmdAtomic -> m ()-handleCmdAtomic cmd = case cmd of-  UpdAtomic upd -> handleUpdAtomic upd-  SfxAtomic _ -> return ()- handleUpdAtomic :: MonadStateWrite m => UpdAtomic -> m () handleUpdAtomic cmd = case cmd of   UpdCreateActor aid body ais -> updCreateActor aid body ais@@ -51,20 +54,16 @@   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 kit c -> updCreateItem iid item kit c-  UpdLoseItem iid item kit c -> updDestroyItem iid item kit 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   UpdMoveItem iid k aid c1 c2 -> updMoveItem iid k aid c1 c2-  UpdAgeActor aid t -> updAgeActor aid t   UpdRefillHP aid n -> updRefillHP aid n   UpdRefillCalm aid n -> updRefillCalm aid n-  UpdFidImpressedActor aid fromFid toFid ->-    updFidImpressedActor aid fromFid toFid   UpdTrajectory aid fromT toT -> updTrajectory aid fromT toT-  UpdColorActor aid fromCol toCol -> updColorActor aid fromCol toCol-  UpdQuitFaction fid mbody fromSt toSt -> updQuitFaction fid mbody fromSt toSt+  UpdQuitFaction fid fromSt toSt -> updQuitFaction fid fromSt toSt   UpdLeadFaction fid source target -> updLeadFaction fid source target   UpdDiplFaction fid1 fid2 fromDipl toDipl ->     updDiplFaction fid1 fid2 fromDipl toDipl@@ -73,16 +72,16 @@   UpdRecordKill aid ikind k -> updRecordKill aid ikind k   UpdAlterTile lid p fromTile toTile -> updAlterTile lid p fromTile toTile   UpdAlterClear lid delta -> updAlterClear lid delta-  UpdSearchTile _ _ fromTile toTile ->-    assert (fromTile /= toTile) $ return ()  -- only for clients-  UpdLearnSecrets aid fromS toS -> updLearnSecrets aid fromS toS+  UpdSearchTile{} -> return ()  -- only for clients+  UpdHideTile{} -> return ()  -- only for clients   UpdSpotTile lid ts -> updSpotTile lid ts   UpdLoseTile lid ts -> updLoseTile lid ts   UpdAlterSmell lid p fromSm toSm -> updAlterSmell lid p fromSm toSm   UpdSpotSmell lid sms -> updSpotSmell lid sms   UpdLoseSmell lid sms -> updLoseSmell lid sms   UpdTimeItem iid c fromIt toIt -> updTimeItem iid c fromIt toIt-  UpdAgeGame t lids -> updAgeGame t lids+  UpdAgeGame lids -> updAgeGame lids+  UpdUnAgeGame lids -> updUnAgeGame lids   UpdDiscover{} -> return ()      -- We can't keep dicovered data in State,   UpdCover{} -> return ()         -- because server saves all atomic commands   UpdDiscoverKind{} -> return ()  -- to apply their inverses for undo,@@ -98,7 +97,6 @@   UpdKillExit{} -> return ()   UpdWriteSave -> return ()   UpdMsgAll{} -> return ()-  UpdRecordHistory{} -> return ()  -- | Creates an actor. Note: after this command, usually a new leader -- for the party should be elected (in case this actor is the only one alive).@@ -112,10 +110,13 @@   modifyState $ updateActorD $ EM.alter f aid   -- Add actor to @sprio@.   let g Nothing = Just [aid]-      g (Just l) = assert (aid `notElem` l `blame` "actor already added"-                                           `twith` (aid, body, l))-                   $ Just $ aid : l-  updateLevel (blid body) $ updatePrio $ EM.alter g (btime body)+      g (Just l) =+#ifdef WITH_EXPENSIVE_ASSERTIONS+        assert (aid `notElem` l `blame` "actor already added"+                                `twith` (aid, body, l))+#endif+        (Just $ aid : l)+  updateLevel (blid body) $ updateActorMap (EM.alter g (bpos body))   -- Actor's items may or may not be already present in @sitemD@,   -- regardless if they are already present otherwise in the dungeon.   -- We re-add them all to save time determining which really need it.@@ -139,14 +140,11 @@                 => ActorId -> Actor -> [(ItemId, Item)] -> m () updDestroyActor aid body ais = do   -- If a leader dies, a new leader should be elected on the server-  -- before this command is executed.-  -- TODO: check this only on the server (e.g., not in LoseActor):-  -- fact <- getsState $ (EM.! bfid body) . sfactionD-  -- assert (Just aid /= gleader fact `blame` (aid, body, fact)) skip-  -- Assert that actor's items belong to @sitemD@. Do not remove those-  -- that do not appear anywhere else, for simplicity and speed.+  -- before this command is executed (not checked).   itemD <- getsState sitemD   let match (iid, item) = itemsMatch (itemD EM.! iid) item+  -- Assert that actor's items belong to @sitemD@. Do not remove those+  -- that do not appear anywhere else, for simplicity and speed.   let !_A = assert (allB match ais `blame` "destroyed actor items not found"                     `twith` (aid, body, ais, itemD)) ()   -- Remove actor from @sactorD@.@@ -154,13 +152,16 @@       f (Just b) = assert (b == body `blame` "inconsistent destroyed actor body"                                      `twith` (aid, body, b)) Nothing   modifyState $ updateActorD $ EM.alter f aid-  -- Remove actor from @sprio@.+  -- Remove actor from @lactor@.   let g Nothing = assert `failure` "actor already removed" `twith` (aid, body)-      g (Just l) = assert (aid `elem` l `blame` "actor already removed"-                                        `twith` (aid, body, l))-                   $ let l2 = delete aid l-                     in if null l2 then Nothing else Just l2-  updateLevel (blid body) $ updatePrio $ EM.alter g (btime body)+      g (Just l) =+#ifdef WITH_EXPENSIVE_ASSERTIONS+        assert (aid `elem` l `blame` "actor already removed"+                             `twith` (aid, body, l))+#endif+        (let l2 = delete aid l+         in if null l2 then Nothing else Just l2)+  updateLevel (blid body) $ updateActorMap (EM.alter g (bpos body))  -- | Create a few copies of an item that is already registered for the dungeon -- (in @sitemRev@ field of @StateServer@).@@ -193,11 +194,13 @@  updMoveActor :: MonadStateWrite m => ActorId -> Point -> Point -> m () updMoveActor aid fromP toP = assert (fromP /= toP) $ do-  b <- getsState $ getActorBody aid-  let !_A = assert (fromP == bpos b+  body <- getsState $ getActorBody aid+  let !_A = assert (fromP == bpos body                     `blame` "unexpected moved actor position"-                    `twith` (aid, fromP, toP, bpos b, b)) ()-  updateActor aid $ \body -> body {bpos = toP, boldpos = Just fromP}+                    `twith` (aid, fromP, toP, bpos body, body)) ()+      newBody = body {bpos = toP, boldpos = Just fromP}+  updateActor aid $ const newBody+  moveActorMap aid body newBody  updWaitActor :: MonadStateWrite m => ActorId -> Bool -> m () updWaitActor aid toWait = do@@ -209,54 +212,43 @@  updDisplaceActor :: MonadStateWrite m => ActorId -> ActorId -> m () updDisplaceActor source target = assert (source /= target) $ do-  spos <- getsState $ bpos . getActorBody source-  tpos <- getsState $ bpos . getActorBody target-  updateActor source $ \b -> b {bpos = tpos, boldpos = Just spos}-  updateActor target $ \b -> b {bpos = spos, boldpos = Just tpos}+  sbody <- getsState $ getActorBody source+  tbody <- getsState $ getActorBody target+  let spos = bpos sbody+      tpos = bpos tbody+      snewBody = sbody {bpos = tpos, boldpos = Just spos}+      tnewBody = tbody {bpos = spos, boldpos = Just tpos}+  updateActor source $ const snewBody+  updateActor target $ const tnewBody+  moveActorMap source sbody snewBody+  moveActorMap target tbody tnewBody  updMoveItem :: MonadStateWrite m             => ItemId -> Int -> ActorId -> CStore -> CStore             -> m () updMoveItem iid k aid c1 c2 = assert (k > 0 && c1 /= c2) $ do-  bag <- getsState $ getActorBag aid c1+  b <- getsState $ getActorBody aid+  bag <- getsState $ getBodyStoreBag b c1   case iid `EM.lookup` bag of     Nothing -> assert `failure` (iid, k, aid, c1, c2)     Just (_, it) -> do       deleteItemActor iid (k, take k it) aid c1       insertItemActor iid (k, take k it) aid c2 --- This is equaivalent to (but much cheaper than) updDestroyActor--- followed by updCreateActor.-updAgeActor :: MonadStateWrite m => ActorId -> Delta Time -> m ()-updAgeActor aid delta = assert (delta /= Delta timeZero) $ do-  body <- getsState $ getActorBody aid-  let newBody = body {btime = timeShift (btime body) delta}-      -- Remove actor from @sprio@ at old time.-      rmPrio Nothing = assert `failure` "actor already removed"-                              `twith` (aid, body)-      rmPrio (Just l) = assert (aid `elem` l `blame` "actor already removed"-                                             `twith` (aid, body, l))-                        $ let l2 = delete aid l-                          in if null l2 then Nothing else Just l2-      -- Add actor to @sprio@ at new time.-      addPrio Nothing = Just [aid]-      addPrio (Just l) = assert (aid `notElem` l `blame` "actor already added"-                                                 `twith` (aid, body, l))-                         $ Just $ aid : l-      updPrio = EM.alter addPrio (btime newBody) . EM.alter rmPrio (btime body)-  updateLevel (blid body) $ updatePrio updPrio-  -- Modify actor body in @sactorD@.-  modifyState $ updateActorD $ EM.adjust (const newBody) aid- updRefillHP :: MonadStateWrite m => ActorId -> Int64 -> m () updRefillHP aid n =   updateActor aid $ \b ->     b { bhp = bhp b + n       , bhpDelta = let oldD = bhpDelta b-                   in if n == 0-                      then ResDelta { resCurrentTurn = 0+                   in case compare n 0 of+                     EQ -> ResDelta { resCurrentTurn = (0, 0)                                     , resPreviousTurn = resCurrentTurn oldD }-                      else oldD {resCurrentTurn = resCurrentTurn oldD + n}+                     LT -> oldD {resCurrentTurn =+                                   ( fst (resCurrentTurn oldD) + n+                                   , snd (resCurrentTurn oldD) )}+                     GT -> oldD {resCurrentTurn =+                                   ( fst (resCurrentTurn oldD)+                                   , snd (resCurrentTurn oldD) + n )}       }  updRefillCalm :: MonadStateWrite m => ActorId -> Int64 -> m ()@@ -264,18 +256,17 @@   updateActor aid $ \b ->     b { bcalm = max 0 $ bcalm b + n       , bcalmDelta = let oldD = bcalmDelta b-                     in if n == 0-                        then ResDelta { resCurrentTurn = 0+                     in case compare n 0 of+                       EQ -> ResDelta { resCurrentTurn = (0, 0)                                       , resPreviousTurn = resCurrentTurn oldD }-                        else oldD {resCurrentTurn = resCurrentTurn oldD + n}+                       LT -> oldD {resCurrentTurn =+                                     ( fst (resCurrentTurn oldD) + n+                                     , snd (resCurrentTurn oldD) )}+                       GT -> oldD {resCurrentTurn =+                                     ( fst (resCurrentTurn oldD)+                                     , snd (resCurrentTurn oldD) + n )}       } -updFidImpressedActor :: MonadStateWrite m => ActorId -> FactionId -> FactionId -> m ()-updFidImpressedActor aid fromFid toFid = assert (fromFid /= toFid) $-  updateActor aid $ \b ->-    assert (bfidImpressed b == fromFid `blame` (aid, fromFid, toFid, b))-    $ b {bfidImpressed = toFid}- updTrajectory :: MonadStateWrite m               => ActorId               -> Maybe ([Vector], Speed)@@ -288,21 +279,10 @@                     `twith` (aid, fromT, toT, body)) ()   updateActor aid $ \b -> b {btrajectory = toT} -updColorActor :: MonadStateWrite m-              => ActorId -> Color.Color -> Color.Color -> m ()-updColorActor aid fromCol toCol = assert (fromCol /= toCol) $ do-  body <- getsState $ getActorBody aid-  let !_A = assert (fromCol == bcolor body-                    `blame` "unexpected actor color"-                    `twith` (aid, fromCol, toCol, body)) ()-  updateActor aid $ \b -> b {bcolor = toCol}- updQuitFaction :: MonadStateWrite m-               => FactionId -> Maybe Actor -> Maybe Status -> Maybe Status-               -> m ()-updQuitFaction fid mbody fromSt toSt = do-  let !_A = assert (fromSt /= toSt `blame` (fid, mbody, fromSt, toSt)) ()-  let !_A = assert (maybe True ((fid ==) . bfid) mbody) ()+               => FactionId -> Maybe Status -> Maybe Status -> m ()+updQuitFaction fid fromSt toSt = do+  let !_A = assert (fromSt /= toSt `blame` (fid, fromSt, toSt)) ()   fact <- getsState $ (EM.! fid) . sfactionD   let !_A = assert (fromSt == gquit fact                     `blame` "unexpected actor quit status"@@ -313,20 +293,20 @@ -- The previous leader is assumed to be alive. updLeadFaction :: MonadStateWrite m                => FactionId-               -> Maybe (ActorId, Maybe Target)-               -> Maybe (ActorId, Maybe Target)+               -> Maybe ActorId+               -> Maybe ActorId                -> m () updLeadFaction fid source target = assert (source /= target) $ do   fact <- getsState $ (EM.! fid) . sfactionD   let !_A = assert (fleaderMode (gplayer fact) /= LeaderNull) ()     -- @PosNone@ ensures this-  mtb <- getsState $ \s -> flip getActorBody s . fst <$> target+  mtb <- getsState $ \s -> flip getActorBody s <$> target   let !_A = assert (maybe True (not . bproj) mtb                     `blame` (fid, source, target, mtb, fact)) ()-  let !_A = assert (source == gleader fact+  let !_A = assert (source == _gleader fact                     `blame` "unexpected actor leader"                     `twith` (fid, source, target, mtb, fact)) ()-  let adj fa = fa {gleader = target}+  let adj fa = fa {_gleader = target}   updateFaction fid adj  updDiplFaction :: MonadStateWrite m@@ -367,15 +347,26 @@                      in if n == 0 then Nothing else Just n       adjFact fact = fact {gvictims = EM.alter alterKind ikind                                       $ gvictims fact}-  updateFaction (bfidOriginal b) adjFact+  updateFaction (bfid b) adjFact+    -- The death of a dominated actor counts as the dominating faction's loss+    -- for score purposes, so human nor AI can't treat such actor as disposable,+    -- which means domination will not be as cruel, as frustrating,+    -- as it could be and there is a higher chance of getting back alive+    -- the actor, the human player has grown attached to.  -- | Alter an attribute (actually, the only, the defining attribute) -- of a visible tile. This is similar to e.g., @UpdTrajectory@.+--+-- For now, we don't remove embedded items when altering a tile+-- and neither do we create fresh ones. It works fine, e.g., for tiles on fire+-- that change into burnt out tile and then the fire item can no longer+-- be triggered due to @alterMinSkillKind@ excluding items without @Embed@,+-- even if the burnt tile has low enough @talter@. updAlterTile :: MonadStateWrite m              => LevelId -> Point -> Kind.Id TileKind -> Kind.Id TileKind              -> m () updAlterTile lid p fromTile toTile = assert (fromTile /= toTile) $ do-  Kind.COps{cotile} <- getsState scops+  Kind.COps{cotile, coTileSpeedup} <- getsState scops   lvl <- getLevel lid   -- The second alternative below can happen if, e.g., a client remembers,   -- but does not see the tile (so does not notice the SearchTile action),@@ -387,7 +378,8 @@                        `twith` (lid, p, fromTile, toTile, ts PointArray.! p))                $ ts PointArray.// [(p, toTile)]   updateLevel lid $ updateTile adj-  case (Tile.isExplorable cotile fromTile, Tile.isExplorable cotile toTile) of+  case ( Tile.isExplorable coTileSpeedup fromTile+       , Tile.isExplorable coTileSpeedup toTile ) of     (False, True) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl + 1}     (True, False) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl - 1}     _ -> return ()@@ -396,14 +388,6 @@ updAlterClear lid delta = assert (delta /= 0) $   updateLevel lid $ \lvl -> lvl {lclear = lclear lvl + delta} --- TODO: use instead of revealing all secret positions initially, at once--- in Common/State.hs.-updLearnSecrets :: MonadStateWrite m => ActorId -> Int -> Int -> m ()-updLearnSecrets aid fromS toS = assert (fromS /= toS) $ do-  b <- getsState $ getActorBody aid-  updateLevel (blid b) $ \lvl -> assert (lsecret lvl == fromS)-                                 $ lvl {lsecret = toS}- -- Notice previously invisible tiles. This is similar to @UpdSpotActor@, -- but done in bulk, because it often involves dozens of tiles pers move. -- We don't check that the tiles at the positions in question are unknown@@ -413,13 +397,13 @@ updSpotTile :: MonadStateWrite m             => LevelId -> [(Point, Kind.Id TileKind)] -> m () updSpotTile lid ts = assert (not $ null ts) $ do-  Kind.COps{cotile} <- getsState scops+  Kind.COps{coTileSpeedup} <- getsState scops   Level{ltile} <- getLevel lid   let adj tileMap = tileMap PointArray.// ts   updateLevel lid $ updateTile adj   let f (p, t2) = do         let t1 = ltile PointArray.! p-        case (Tile.isExplorable cotile t1, Tile.isExplorable cotile t2) of+        case (Tile.isExplorable coTileSpeedup t1, Tile.isExplorable coTileSpeedup t2) of           (False, True) -> updateLevel lid $ \lvl -> lvl {lseen = lseen lvl+1}           (True, False) -> updateLevel lid $ \lvl -> lvl {lseen = lseen lvl-1}           _ -> return ()@@ -430,23 +414,23 @@ updLoseTile :: MonadStateWrite m             => LevelId -> [(Point, Kind.Id TileKind)] -> m () updLoseTile lid ts = assert (not $ null ts) $ do-  Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} <- getsState scops-  let unknownId = ouniqGroup "unknown space"-      matches _ [] = True+  Kind.COps{coTileSpeedup} <- getsState scops+  let matches _ [] = True       matches tileMap ((p, ov) : rest) =         tileMap PointArray.! p == ov && matches tileMap rest       tu = map (second (const unknownId)) ts       adj tileMap = assert (matches tileMap ts) $ tileMap PointArray.// tu   updateLevel lid $ updateTile adj   let f (_, t1) =-        when (Tile.isExplorable cotile t1) $+        when (Tile.isExplorable coTileSpeedup t1) $           updateLevel lid $ \lvl -> lvl {lseen = lseen lvl - 1}   mapM_ f ts -updAlterSmell :: MonadStateWrite m-            => LevelId -> Point -> Maybe Time -> Maybe Time -> m ()-updAlterSmell lid p fromSm toSm = do-  let alt sm = assert (sm == fromSm `blame` "unexpected tile smell"+updAlterSmell :: MonadStateWrite m => LevelId -> Point -> Time -> Time -> m ()+updAlterSmell lid p fromSm' toSm' = do+  let fromSm = if fromSm' == timeZero then Nothing else Just fromSm'+      toSm = if toSm' == timeZero then Nothing else Just toSm'+      alt sm = assert (sm == fromSm `blame` "unexpected tile smell"                                     `twith` (lid, p, fromSm, toSm, sm)) toSm   updateLevel lid $ updateSmell $ EM.alter alt p @@ -474,7 +458,7 @@             => ItemId -> Container -> ItemTimer -> ItemTimer             -> m () updTimeItem iid c fromIt toIt = assert (fromIt /= toIt) $ do-  bag <- getsState $ getCBag c+  bag <- getsState $ getContainerBag c   case iid `EM.lookup` bag of     Just (k, it) -> do       let !_A = assert (fromIt == it `blame` (k, it, iid, c, fromIt, toIt)) ()@@ -483,14 +467,15 @@     Nothing -> assert `failure` (bag, iid, c, fromIt, toIt)  -- | Age the game.------ TODO: It leaks information that there is activity on various level,--- even if the faction has no actors there, so show this on UI somewhere,--- e.g., in the @~@ menu of seen level indicate recent activity.-updAgeGame :: MonadStateWrite m => Delta Time -> [LevelId] -> m ()-updAgeGame delta lids = assert (delta /= Delta timeZero) $ do-  modifyState $ updateTime $ flip timeShift delta-  mapM_ (ageLevel delta) lids+updAgeGame :: MonadStateWrite m => [LevelId] -> m ()+updAgeGame lids = do+  modifyState $ updateTime $ flip timeShift (Delta timeClip)+  mapM_ (ageLevel (Delta timeClip)) lids++updUnAgeGame :: MonadStateWrite m => [LevelId] -> m ()+updUnAgeGame lids = do+  modifyState $ updateTime $ flip timeShift (timeDeltaReverse $ Delta timeClip)+  mapM_ (ageLevel (timeDeltaReverse $ Delta timeClip)) lids  ageLevel :: MonadStateWrite m => Delta Time -> LevelId -> m () ageLevel delta lid =

Game/LambdaHack/Atomic/MonadAtomic.hs view

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

Game/LambdaHack/Atomic/MonadStateWrite.hs view

@@ -1,12 +1,16 @@ -- | The monad for writing to the game state and related operations. module Game.LambdaHack.Atomic.MonadStateWrite   ( MonadStateWrite(..)-  , updateLevel, updateActor, updateFaction+  , putState, updateLevel, updateActor, updateFaction   , insertItemContainer, insertItemActor, deleteItemContainer, deleteItemActor-  , updatePrio, updateFloor, updateTile, updateSmell+  , updateFloor, updateActorMap, moveActorMap+  , updateTile, updateSmell   ) where -import Control.Exception.Assert.Sugar+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import qualified Data.EnumMap.Strict as EM  import Game.LambdaHack.Common.Actor@@ -21,11 +25,9 @@  class MonadStateRead m => MonadStateWrite m where   modifyState :: (State -> State) -> m ()-  putState    :: State -> m () --- | Update the actor time priority queue.-updatePrio :: (ActorPrio -> ActorPrio) -> Level -> Level-updatePrio f lvl = lvl {lprio = f (lprio lvl)}+putState :: MonadStateWrite m => State -> m ()+putState s = modifyState (const s)  -- | Update the items on the ground map. updateFloor :: (ItemFloor -> ItemFloor) -> Level -> Level@@ -35,6 +37,32 @@ updateEmbed :: (ItemFloor -> ItemFloor) -> Level -> Level updateEmbed f lvl = lvl {lembed = f (lembed lvl)} +-- | Update the actors on the ground map.+updateActorMap :: (ActorMap -> ActorMap) -> Level -> Level+updateActorMap f lvl = lvl {lactor = f (lactor lvl)}++moveActorMap :: MonadStateWrite m => ActorId -> Actor -> Actor -> m ()+moveActorMap aid body newBody = do+  let rmActor Nothing = assert `failure` "actor already removed"+                               `twith` (aid, body)+      rmActor (Just l) =+#ifdef WITH_EXPENSIVE_ASSERTIONS+        assert (aid `elem` l `blame` "actor already removed"+                             `twith` (aid, body, l))+#endif+        (let l2 = delete aid l+         in if null l2 then Nothing else Just l2)+      addActor Nothing = Just [aid]+      addActor (Just l) =+#ifdef WITH_EXPENSIVE_ASSERTIONS+        assert (aid `notElem` l `blame` "actor already added"+                                `twith` (aid, body, l))+#endif+        (Just $ aid : l)+      updActor = EM.alter addActor (bpos newBody)+                 . EM.alter rmActor (bpos body)+  updateLevel (blid body) $ updateActorMap updActor+ -- | Update the tile map. updateTile :: (TileMap -> TileMap) -> Level -> Level updateTile f lvl = lvl {ltile = f (ltile lvl)}@@ -43,10 +71,15 @@ updateSmell :: (SmellMap -> SmellMap) -> Level -> Level updateSmell f lvl = lvl {lsmell = f (lsmell lvl)} +-- INLIning offers no speedup, increases alloc and binary size.+-- EM.alter not necessary, because levels not removed, so little risk+-- of adjusting at absent index. -- | Update a given level data within state. updateLevel :: MonadStateWrite m => LevelId -> (Level -> Level) -> m () updateLevel lid f = modifyState $ updateDungeon $ EM.adjust f lid +-- INLIning doesn't help despite probably canceling the alt indirection.+-- perhaps it's applied automatically due to INLINABLE. updateActor :: MonadStateWrite m => ActorId -> (Actor -> Actor) -> m () updateActor aid f = do   let alt Nothing = assert `failure` "no body to update" `twith` aid@@ -88,26 +121,32 @@   CGround -> do     b <- getsState $ getActorBody aid     insertItemFloor iid kit (blid b) (bpos b)-  COrgan -> insertItemBody iid kit aid+  COrgan -> insertItemOrgan iid kit aid   CEqp -> insertItemEqp iid kit aid   CInv -> insertItemInv iid kit aid   CSha -> do     b <- getsState $ getActorBody aid     insertItemSha iid kit (bfid b) -insertItemBody :: MonadStateWrite m-               => ItemId -> ItemQuant -> ActorId -> m ()-insertItemBody iid kit aid = do+insertItemOrgan :: MonadStateWrite m+                => ItemId -> ItemQuant -> ActorId -> m ()+insertItemOrgan iid kit aid = do   let bag = EM.singleton iid kit       upd = EM.unionWith mergeItemQuant bag-  updateActor aid $ \b -> b {borgan = upd (borgan b)}+  item <- getsState $ getItemBody iid+  updateActor aid $ \b ->+    b { borgan = upd (borgan b)+      , bweapon = if isMelee item then bweapon b + 1 else bweapon b }  insertItemEqp :: MonadStateWrite m               => 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)}+  item <- getsState $ getItemBody iid+  updateActor aid $ \b ->+    b { beqp = upd (beqp b)+      , bweapon = if isMelee item then bweapon b + 1 else bweapon b }  insertItemInv :: MonadStateWrite m               => ItemId -> ItemQuant -> ActorId -> m ()@@ -157,20 +196,26 @@   CGround -> do     b <- getsState $ getActorBody aid     deleteItemFloor iid kit (blid b) (bpos b)-  COrgan -> deleteItemBody iid kit aid+  COrgan -> deleteItemOrgan iid kit aid   CEqp -> deleteItemEqp iid kit aid   CInv -> deleteItemInv iid kit aid   CSha -> do     b <- getsState $ getActorBody aid     deleteItemSha iid kit (bfid b) -deleteItemBody :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()-deleteItemBody iid kit aid =-  updateActor aid $ \b -> b {borgan = rmFromBag kit iid (borgan b) }+deleteItemOrgan :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()+deleteItemOrgan iid kit aid = do+  item <- getsState $ getItemBody iid+  updateActor aid $ \b ->+    b { borgan = rmFromBag kit iid (borgan b)+      , bweapon = if isMelee item then bweapon b - 1 else bweapon b }  deleteItemEqp :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()-deleteItemEqp iid kit aid =-  updateActor aid $ \b -> b {beqp = rmFromBag kit iid (beqp b)}+deleteItemEqp iid kit aid = do+  item <- getsState $ getItemBody iid+  updateActor aid $ \b ->+    b { beqp = rmFromBag kit iid (beqp b)+      , bweapon = if isMelee item then bweapon b - 1 else bweapon b }  deleteItemInv :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m () deleteItemInv iid kit aid =@@ -180,7 +225,7 @@ deleteItemSha iid kit fid =   updateFaction fid $ \fact -> fact {gsha = rmFromBag kit iid (gsha fact)} --- Removing the part of the kit from the front of the list,+-- Removing the part of the kit from the back of the list, -- so that @DestroyItem kit (CreateItem kit x) == x@. rmFromBag :: ItemQuant -> ItemId -> ItemBag -> ItemBag rmFromBag kit@(k, rmIt) iid bag =@@ -189,8 +234,8 @@         case compare n k of           LT -> assert `failure` "rm more than there is"                        `twith` (n, kit, iid, bag)-          EQ -> Nothing  -- TODO: assert as below+          EQ -> assert (rmIt == it `blame` (rmIt, it, n, kit, iid, bag)) Nothing           GT -> assert (rmIt == take k it                         `blame` (rmIt, take k it, n, kit, iid, bag))-                $ Just (n - k, drop k it)+                $ Just (n - k, take (n - k) it)   in EM.alter rfb iid bag

Game/LambdaHack/Atomic/PosAtomicRead.hs view

@@ -3,32 +3,26 @@ -- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>. module Game.LambdaHack.Atomic.PosAtomicRead   ( PosAtomic(..), posUpdAtomic, posSfxAtomic-  , resetsFovCmdAtomic, breakUpdAtomic, breakSfxAtomic, loudUpdAtomic-  , seenAtomicCli, seenAtomicSer, generalMoveItem, posProjBody+  , breakUpdAtomic, seenAtomicCli, seenAtomicSer, generalMoveItem, posProjBody   ) where -import Control.Applicative-import Control.Exception.Assert.Sugar+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES-import qualified NLP.Miniutter.English as MU  import Game.LambdaHack.Atomic.CmdAtomic import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.ModeKind  -- All functions here that take an atomic action are executed -- in the state just before the action is executed.@@ -63,7 +57,7 @@ -- distinguishable by looking at the state (or the screen) from @UpdMoveActor@ -- of the illuminated actor, hence such @UpdDisplaceActor@ should not be -- observable, but @UpdMoveActor@ should be (or the former should be perceived--- as the latter). However, to simplify, we assing as strict visibility+-- as the latter). However, to simplify, we assign as strict visibility -- requirements to @UpdMoveActor@ as to @UpdDisplaceActor@ and fall back -- to @UpdSpotActor@ (which provides minimal information that does not -- contradict state) if the visibility is lower.@@ -75,8 +69,8 @@   UpdDestroyItem _ _ _ c -> singleContainer c   UpdSpotActor _ body _ -> return $! posProjBody body   UpdLoseActor _ body _ -> return $! posProjBody body-  UpdSpotItem _ _ _ c -> singleContainer c-  UpdLoseItem _ _ _ c -> singleContainer c+  UpdSpotItem _ _ _ _ c -> singleContainer c+  UpdLoseItem _ _ _ _ c -> singleContainer c   UpdMoveActor aid fromP toP -> do     b <- getsState $ getActorBody aid     -- Non-projectile actors are never totally isolated from envirnoment;@@ -85,47 +79,29 @@               then PosSight (blid b) [fromP, toP]               else PosFidAndSight [bfid b] (blid b) [fromP, toP]   UpdWaitActor aid _ -> singleAid aid-  UpdDisplaceActor source target -> do-    sb <- getsState $ getActorBody source-    tb <- getsState $ getActorBody target-    let ps = [bpos sb, bpos tb]-        lid = assert (blid sb == blid tb) $ blid sb-    return $! if bproj sb && bproj tb-              then PosSight lid ps-              else if bproj sb-              then PosFidAndSight [bfid tb] lid ps-              else if bproj tb-              then PosFidAndSight [bfid sb] lid ps-              else PosFidAndSight [bfid sb, bfid tb] lid ps-  UpdMoveItem _ _ aid _ CSha -> do  -- shared stash is private-    b <- getsState $ getActorBody aid-    return $! PosFidAndSer (Just $ blid b) (bfid b)-  UpdMoveItem _ _ aid CSha _ -> do  -- shared stash is private-    b <- getsState $ getActorBody aid-    return $! PosFidAndSer (Just $ blid b) (bfid b)+  UpdDisplaceActor source target -> doubleAid source target+  UpdMoveItem _ _ _ _ CSha -> assert `failure` cmd  -- shared stash is private+  UpdMoveItem _ _ _ CSha _ ->  assert `failure` cmd   UpdMoveItem _ _ aid _ _ -> singleAid aid-  UpdAgeActor aid _ -> singleAid aid   UpdRefillHP aid _ -> singleAid aid   UpdRefillCalm aid _ -> singleAid aid-  UpdFidImpressedActor aid _ _ -> singleAid aid   UpdTrajectory aid _ _ -> singleAid aid-  UpdColorActor aid _ _ -> singleAid aid   UpdQuitFaction{} -> return PosAll-  UpdLeadFaction fid _ _ -> do-    fact <- getsState $ (EM.! fid) . sfactionD-    return $! if fleaderMode (gplayer fact) /= LeaderNull-              then PosFidAndSer Nothing fid-              else PosNone+  UpdLeadFaction fid _ _ -> return $ PosFidAndSer Nothing fid   UpdDiplFaction{} -> return PosAll   UpdTacticFaction fid _ _ -> return $! PosFidAndSer Nothing fid   UpdAutoFaction{} -> return PosAll-  UpdRecordKill aid _ _ -> singleFidAndAid aid+  UpdRecordKill aid _ _ -> singleAid aid   UpdAlterTile lid p _ _ -> return $! PosSight lid [p]   UpdAlterClear{} -> return PosAll-  UpdSearchTile aid p _ _ -> do-    (lid, pos) <- posOfAid aid-    return $! PosSight lid [pos, p]-  UpdLearnSecrets aid _ _ -> singleAid aid+    -- Can't have @PosSight@, because we'd end up with many accessible+    -- unknown tiles, but the game reporting 'all seen'.+  UpdSearchTile aid p _ -> do+    b <- getsState $ getActorBody aid+    return $! PosFidAndSight [bfid b] (blid b) [bpos b, p]+  UpdHideTile aid p _ -> do+    b <- getsState $ getActorBody aid+    return $! PosFidAndSight [bfid b] (blid b) [bpos b, p]   UpdSpotTile lid ts -> do     let ps = map fst ts     return $! PosSight lid ps@@ -140,46 +116,50 @@     let ps = map fst sms     return $! PosSmell lid ps   UpdTimeItem _ c _ _ -> singleContainer c-  UpdAgeGame _ _ -> return PosAll-  UpdDiscover c _ _ _ _ -> singleContainer c-  UpdCover c _ _ _ _ -> singleContainer c+  UpdAgeGame _ -> return PosAll+  UpdUnAgeGame _ -> return PosAll+  UpdDiscover c _ _ _ -> singleContainer c+  UpdCover c _ _ _ -> singleContainer c   UpdDiscoverKind c _ _ -> singleContainer c   UpdCoverKind c _ _ -> singleContainer c-  UpdDiscoverSeed c _ _ _ -> singleContainer c-  UpdCoverSeed c _ _ _ -> singleContainer c+  UpdDiscoverSeed c _ _ -> singleContainer c+  UpdCoverSeed c _ _ -> singleContainer c   UpdPerception{} -> return PosNone   UpdRestart fid _ _ _ _ _ -> return $! PosFid fid   UpdRestartServer _ -> return PosSer-  UpdResume fid _ -> return $! PosFid fid+  UpdResume _ _ -> return PosNone   UpdResumeServer _ -> return PosSer   UpdKillExit fid -> return $! PosFid fid   UpdWriteSave -> return PosAll   UpdMsgAll{} -> return PosAll-  UpdRecordHistory fid -> return $! PosFid fid  -- | Produce the positions where the atomic special effect takes place. posSfxAtomic :: MonadStateRead m => SfxAtomic -> m PosAtomic posSfxAtomic cmd = case cmd of-  SfxStrike _ _ _ CSha _ ->  -- shared stash is private-    return PosNone  -- TODO: PosSerAndFidIfSight; but probably never used-  SfxStrike source target _ _ _ -> doubleAid source target-  SfxRecoil _ _ _ CSha _ ->  -- shared stash is private-    return PosNone  -- TODO: PosSerAndFidIfSight; but probably never used-  SfxRecoil source target _ _ _ -> doubleAid source target+  SfxStrike _ _ _ CSha -> return PosNone  -- shared stash is private+  SfxStrike _ target _ _ -> singleAid target+  SfxRecoil _ _ _ CSha -> return PosNone  -- shared stash is private+  SfxRecoil _ target _ _ -> singleAid target+  SfxSteal _ _ _ CSha -> return PosNone  -- shared stash is private+  SfxSteal _ target _ _ -> singleAid target+  SfxRelease _ _ _ CSha -> return PosNone  -- shared stash is private+  SfxRelease _ target _ _ -> singleAid target   SfxProject aid _ cstore -> singleContainer $ CActor aid cstore-  SfxCatch aid _ cstore -> singleContainer $ CActor aid cstore+  SfxReceive aid _ cstore -> singleContainer $ CActor aid cstore   SfxApply aid _ cstore -> singleContainer $ CActor aid cstore   SfxCheck aid _ cstore -> singleContainer $ CActor aid cstore-  SfxTrigger aid p _ -> do-    (lid, pa) <- posOfAid aid-    return $! PosSight lid [pa, p]-  SfxShun aid p _ -> do-    (lid, pa) <- posOfAid aid-    return $! PosSight lid [pa, p]-  SfxEffect _ aid _ -> singleAid aid  -- sometimes we don't see source, OK+  SfxTrigger aid p -> do+    body <- getsState $ getActorBody aid+    if bproj body+    then return $! PosSight (blid body) [bpos body, p]+    else return $! PosFidAndSight [bfid body] (blid body) [bpos body, p]+  SfxShun aid p -> do+    body <- getsState $ getActorBody aid+    if bproj body+    then return $! PosSight (blid body) [bpos body, p]+    else return $! PosFidAndSight [bfid body] (blid body) [bpos body, p]+  SfxEffect _ aid _ _ -> singleAid aid  -- sometimes we don't see source, OK   SfxMsgFid fid _ -> return $! PosFid fid-  SfxMsgAll _ -> return PosAll-  SfxActorStart aid -> singleAid aid  posProjBody :: Actor -> PosAtomic posProjBody body =@@ -187,21 +167,18 @@   then PosSight (blid body) [bpos body]   else PosFidAndSight [bfid body] (blid body) [bpos body] -singleFidAndAid :: MonadStateRead m => ActorId -> m PosAtomic-singleFidAndAid aid = do-  body <- getsState $ getActorBody aid-  return $! PosFidAndSight [bfid body] (blid body) [bpos body]- singleAid :: MonadStateRead m => ActorId -> m PosAtomic singleAid aid = do-  (lid, p) <- posOfAid aid-  return $! PosSight lid [p]+  body <- getsState $ getActorBody aid+  return $! posProjBody body  doubleAid :: MonadStateRead m => ActorId -> ActorId -> m PosAtomic doubleAid source target = do-  (slid, sp) <- posOfAid source-  (tlid, tp) <- posOfAid target-  return $! assert (slid == tlid) $ PosSight slid [sp, tp]+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  -- No @PosFidAndSight@ instead of @PosSight@, because both positions+  -- need to be seen to have the enemy actor in client's state.+  return $! assert (blid sb == blid tb) $ PosSight (blid sb) [bpos sb, bpos tb]  singleContainer :: MonadStateRead m => Container -> m PosAtomic singleContainer (CFloor lid p) = return $! PosSight lid [p]@@ -209,43 +186,11 @@ singleContainer (CActor aid CSha) = do  -- shared stash is private   b <- getsState $ getActorBody aid   return $! PosFidAndSer (Just $ blid b) (bfid b)-singleContainer (CActor aid _) = do-  (lid, p) <- posOfAid aid-  return $! PosSight lid [p]-singleContainer (CTrunk fid lid p) = return $! PosFidAndSight [fid] lid [p]---- | Determines if a command resets FOV.------ Invariant: if @resetsFovCmdAtomic@ determines we do not need--- to reset Fov, perception (@ptotal@ to be precise, @psmell@ is irrelevant)--- of any faction does not change upon recomputation. Otherwise,--- save/restore would change game state.-resetsFovCmdAtomic :: UpdAtomic -> Bool-resetsFovCmdAtomic cmd = case cmd of-  -- Create/destroy actors and items.-  UpdCreateActor{} -> True  -- may have a light source-  UpdDestroyActor{} -> True-  UpdCreateItem{} -> True  -- may be a light source-  UpdDestroyItem{} -> True-  UpdSpotActor{} -> True-  UpdLoseActor{} -> True-  UpdSpotItem{} -> True-  UpdLoseItem{} -> True-  -- Move actors and items.-  UpdMoveActor{} -> True-  UpdDisplaceActor{} -> True-  UpdMoveItem{} -> True  -- light sources, sight radius bonuses-  UpdRefillCalm{} -> True  -- Calm caps sight radius-  -- Alter map.-  UpdAlterTile{} -> True  -- even if pos not visible initially-  UpdSpotTile{} -> True-  UpdLoseTile{} -> True-  _ -> False+singleContainer (CActor aid _) = singleAid aid+singleContainer (CTrunk fid lid p) =+  return $! PosFidAndSight [fid] lid [p] --- | Decompose an atomic action. The original action is visible--- if it's positions are visible both before and after the action--- (in between the FOV might have changed). The decomposed actions--- are only tested vs the FOV after the action and they give reduced+-- | Decompose an atomic action. The decomposed actions give reduced -- information that still modifies client's state to match the server state -- wrt the current FOV and the subset of @posUpdAtomic@ that is visible. -- The original actions give more information not only due to spanning@@ -268,51 +213,13 @@     tb <- getsState $ getActorBody target     tais <- getsState $ getCarriedAssocs tb     return [ UpdLoseActor source sb sais-           , UpdSpotActor source sb {bpos = bpos tb, boldpos = Just $ bpos sb} sais+           , UpdSpotActor source sb { bpos = bpos tb+                                    , boldpos = Just $ bpos sb } sais            , UpdLoseActor target tb tais-           , UpdSpotActor target tb {bpos = bpos sb, boldpos = Just $ bpos tb} tais+           , UpdSpotActor target tb { bpos = bpos sb+                                    , boldpos = Just $ bpos tb } tais            ]-  UpdMoveItem iid k aid cstore1 cstore2 | cstore1 == CSha  -- CSha is private-                                          || 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-  -- (because the commands doesn't change @State@ and the client-side-  -- processing of the command is lenient).-  _ -> return [cmd]---- | Decompose an atomic special effect.-breakSfxAtomic :: MonadStateRead m => SfxAtomic -> m [SfxAtomic]-breakSfxAtomic cmd = case cmd of-  SfxStrike source target _ _ _ -> do-    -- Hack: make a fight detectable even if one of combatants not visible.-    sb <- getsState $ getActorBody source-    return $! [ SfxEffect (bfid sb) source (IK.RefillCalm (-1))-              | not $ bproj sb ]-              ++ [SfxEffect (bfid sb) target (IK.RefillHP (-1))]-  _ -> return [cmd]---- | Messages for some unseen game object creation/destruction/alteration.-loudUpdAtomic :: MonadStateRead m-              => Bool -> FactionId -> UpdAtomic -> m (Maybe Msg)-loudUpdAtomic local fid cmd = do-  msound <- case cmd of-    UpdDestroyActor _ body _-      -- Death of a party member does not need to be heard,-      -- because it's seen.-      | not $ fid == bfid body || bproj body -> return $ Just "shriek"-    UpdCreateItem _ _ _ (CActor _ CGround) -> return $ Just "clatter"-    UpdAlterTile _ _ fromTile _ -> do-      Kind.COps{cotile} <- getsState scops-      if Tile.isDoor cotile fromTile-        then return $ Just "creaking sound"-        else return $ Just "rumble"-    _ -> return Nothing-  let distant = if local then [] else ["distant"]-      hear sound = makeSentence [ "you hear"-                                , MU.AW $ MU.Phrase $ distant ++ [sound] ]-  return $! hear <$> msound+  _ -> return []  -- | Given the client, it's perception and an atomic command, determine -- if the client notices the command.@@ -322,38 +229,41 @@     PosSight _ ps -> all (`ES.member` totalVisible per) ps || knowEvents     PosFidAndSight fids _ ps ->       fid `elem` fids || all (`ES.member` totalVisible per) ps || knowEvents-    PosSmell _ ps -> all (`ES.member` smellVisible per) ps || knowEvents+    PosSmell _ ps -> all (`ES.member` totalSmelled per) ps || knowEvents     PosFid fid2 -> fid == fid2     PosFidAndSer _ fid2 -> fid == fid2     PosSer -> False     PosAll -> True     PosNone -> assert `failure` "no position possible" `twith` fid +-- Not needed ATM, but may be a coincidence. seenAtomicSer :: PosAtomic -> Bool seenAtomicSer posAtomic =   case posAtomic of     PosFid _ -> False-    PosNone -> False+    PosNone -> assert `failure` "no position possible" `twith` posAtomic     _ -> True  -- | Generate the atomic updates that jointly perform a given item move. generalMoveItem :: MonadStateRead m-                => ItemId -> Int -> Container -> Container+                => Bool -> ItemId -> Int -> Container -> Container                 -> m [UpdAtomic]-generalMoveItem iid k c1 c2 =+generalMoveItem verbose iid k c1 c2 =   case (c1, c2) of-    (CActor aid1 cstore1, CActor aid2 cstore2) | aid1 == aid2 ->+    (CActor aid1 cstore1, CActor aid2 cstore2) | aid1 == aid2+                                                 && cstore1 /= CSha+                                                 && cstore2 /= CSha ->       return [UpdMoveItem iid k aid1 cstore1 cstore2]-    _ -> containerMoveItem iid k c1 c2+    _ -> containerMoveItem verbose iid k c1 c2  containerMoveItem :: MonadStateRead m-                  => ItemId -> Int -> Container -> Container+                  => Bool -> ItemId -> Int -> Container -> Container                   -> m [UpdAtomic]-containerMoveItem iid k c1 c2 = do-  bag <- getsState $ getCBag c1+containerMoveItem verbose iid k c1 c2 = do+  bag <- getsState $ getContainerBag 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, take k it) c1-             , UpdSpotItem iid item (k, take k it) c2 ]+      return [ UpdLoseItem verbose iid item (k, take k it) c1+             , UpdSpotItem verbose iid item (k, take k it) c2 ]

Game/LambdaHack/Client.hs view

@@ -1,14 +1,12 @@-{-# LANGUAGE FlexibleContexts #-} -- | Semantics of responses that are sent to clients. -- -- See -- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>. module Game.LambdaHack.Client   ( -- * Re-exported from "Game.LambdaHack.Client.LoopClient"-    loopAI, loopUI-    -- * Re-exported from "Game.LambdaHack.Client.UI"-  , srtFrontend+    loopCli   ) where -import Game.LambdaHack.Client.LoopClient-import Game.LambdaHack.Client.UI+import Prelude ()++import Game.LambdaHack.Client.LoopM

Game/LambdaHack/Client/AI.hs view

@@ -1,103 +1,127 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-} -- | Ways for the client to use AI to produce server requests, based on -- the client's view of the game state. module Game.LambdaHack.Client.AI-  ( queryAI, pongAI+  ( queryAI #ifdef EXPOSE_INTERNAL     -- * Internal operations-  , refreshTarget, pickAction+  , pickAI, pickAction, udpdateCondInMelee, condInMeleeM #endif   ) where -import Control.Exception.Assert.Sugar+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import qualified Data.EnumMap.Strict as EM-import qualified Data.Text as T -import Game.LambdaHack.Client.AI.HandleAbilityClient-import Game.LambdaHack.Client.AI.PickActorClient-import Game.LambdaHack.Client.AI.PickTargetClient+import Game.LambdaHack.Client.AI.HandleAbilityM+import Game.LambdaHack.Client.AI.PickActorM import Game.LambdaHack.Client.AI.Strategy import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Frequency import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.Request import Game.LambdaHack.Common.State --- | Handle the move of an AI player.+-- | Handle the move of an actor under AI control (of UI or AI player). queryAI :: MonadClient m => ActorId -> m RequestAI-queryAI oldAid = do+queryAI aid = do+  -- @_sleader@ may be different from @_gleader@ due to @stopPlayBack@,+  -- but only leaders may change faction leader, so we fix that:   side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  let mleader = gleader fact-      wasLeader = fmap fst mleader == Just oldAid-  (aidToMove, bToMove) <- pickActorToMove refreshTarget oldAid-  RequestAnyAbility reqAny <- pickAction (aidToMove, bToMove)-  let req = ReqAITimed reqAny-  mtgt2 <- getsClient $ fmap fst . EM.lookup aidToMove . stargetD-  if wasLeader && mleader /= Just (aidToMove, mtgt2)-    then return $! ReqAILeader aidToMove mtgt2 req-    else return $! req---- | Client signals to the server that it's still online.-pongAI :: MonadClient m => m RequestAI-pongAI = return ReqAIPong+  mleader <- getsState $ _gleader . (EM.! side) . sfactionD+  mleaderCli <- getsClient _sleader+  unless (Just aid == mleader || mleader == mleaderCli) $+    -- @aid@ is not the leader, so he can't change leader+    modifyClient $ \cli -> cli {_sleader = mleader}+  -- @condInMelee@ will most proably be needed in this functions,+  -- but even if not, it's OK, it's not forced, because wrapped in @Maybe@:+  udpdateCondInMelee aid+  (aidToMove, treq) <- pickAI Nothing aid+  (aidToMove2, treq2) <-+    case treq of+      RequestAnyAbility ReqWait | mleader == Just aid -> do+        -- leader waits; a waste; try once to pick a yet different leader+        modifyClient $ \cli -> cli {_sleader = mleader}  -- undo previous choice+        pickAI (Just (aidToMove, treq)) aid+      _ -> return (aidToMove, treq)+  return ( ReqAITimed treq2+         , if aidToMove2 /= aid then Just aidToMove2 else Nothing ) --- | Verify and possibly change the target of an actor. This function both--- updates the target in the client state and returns the new target explicitly.-refreshTarget :: MonadClient m-              => (ActorId, Actor)  -- ^ the actor to refresh-              -> m (Maybe (Target, PathEtc))-refreshTarget (aid, body) = do-  side <- getsClient sside-  let !_A = assert (bfid body == side-                    `blame` "AI tries to move an enemy actor"-                    `twith` (aid, body, side)) ()-  let !_A = assert (not (bproj body)-                    `blame` "AI gets to manually move its projectiles"-                    `twith` (aid, body, side)) ()-  stratTarget <- targetStrategy aid-  tgtMPath <--    if nullStrategy stratTarget then  -- equiv to nullFreq-      -- No sensible target; wipe out the old one.-      return Nothing+pickAI :: MonadClient m+       => Maybe (ActorId, RequestAnyAbility) -> ActorId+       -> m (ActorId, RequestAnyAbility)+-- This inline speeds up execution by 10% and increases allocation by 15%,+-- despite probably bloating executable:+{-# INLINE pickAI #-}+pickAI maid aid = do+  mleader <- getsClient _sleader+  aidToMove <-+    if mleader == Just aid+    then pickActorToMove (fst <$> maid)     else do-      -- Choose a target from those proposed by AI for the actor.-      tmp <- rndToAction $ frequency $ bestVariant stratTarget-      return $ Just tmp-  oldTgt <- getsClient $ EM.lookup aid . stargetD-  let _debug = T.unpack-          $ "\nHandleAI symbol:"    <+> tshow (bsymbol body)-          <> ", aid:"               <+> tshow aid-          <> ", pos:"               <+> tshow (bpos body)-          <> "\nHandleAI oldTgt:"   <+> tshow oldTgt-          <> "\nHandleAI strTgt:"   <+> tshow stratTarget-          <> "\nHandleAI target:"   <+> tshow tgtMPath---  trace _debug skip-  modifyClient $ \cli ->-    cli {stargetD = EM.alter (const tgtMPath) aid (stargetD cli)}-  return $! case tgtMPath of-    Just (tgt, Just pathEtc) -> Just (tgt, pathEtc)-    _ -> Nothing+      useTactics aid+      return aid+  treq <- case maid of+    Just (aidOld, treqOld) | aidToMove == aidOld ->+      return treqOld  -- no better leader found+    _ -> pickAction aidToMove (isJust maid)+  return (aidToMove, treq) --- | Pick an action the actor will perfrom this turn.-pickAction :: MonadClient m => (ActorId, Actor) -> m RequestAnyAbility-pickAction (aid, body) = do+-- | Pick an action the actor will perform this turn.+pickAction :: MonadClient m => ActorId -> Bool -> m RequestAnyAbility+{-# INLINE pickAction #-}+pickAction aid retry = do   side <- getsClient sside+  body <- getsState $ getActorBody aid   let !_A = assert (bfid body == side                     `blame` "AI tries to move enemy actor"                     `twith` (aid, bfid body, side)) ()-  let !_A = assert (not (bproj body)+  let !_A = assert (isNothing (btrajectory body)                     `blame` "AI gets to manually move its projectiles"                     `twith` (aid, bfid body, side)) ()-  stratAction <- actionStrategy aid+  stratAction <- actionStrategy aid retry   let bestAction = bestVariant stratAction       !_A = assert (not (nullFreq bestAction)  -- equiv to nullStrategy                     `blame` "no AI action for actor"                     `twith` (stratAction, aid, body)) ()   -- Run the AI: chose an action from those given by the AI strategy.   rndToAction $ frequency bestAction++udpdateCondInMelee :: MonadClient m => ActorId -> m ()+udpdateCondInMelee aid = do+  b <- getsState $ getActorBody aid+  condInMelee <- getsClient $ (EM.! blid b) . scondInMelee+  case condInMelee of+    Just{} -> return ()  -- still up to date+    Nothing -> do+      newCond <- condInMeleeM b  -- lazy and kept that way due to @Maybe@+      modifyClient $ \cli ->+        cli {scondInMelee =+               EM.adjust (const $ Just newCond) (blid b) (scondInMelee cli)}++-- | Check if any non-dying foe (projectile or not) is adjacent+-- to any of our normal actors (whether they can melee or just need to flee,+-- in which case alert is needed so that they are not slowed down by others).+condInMeleeM :: MonadClient m => Actor -> m Bool+condInMeleeM bodyOur = do+  fact <- getsState $ (EM.! bfid bodyOur) . sfactionD+  let f !b = blid b == blid bodyOur && isAtWar fact (bfid b) && bhp b > 0+  -- We assume foes are less numerous, because usually they are heroes,+  -- and so we compute them once and use many times.+  -- For the same reason @anyFoeAdj@ would not speed up this computation+  -- in normal gameplay (as opposed to AI vs AI benchmarks).+  allFoes <- getsState $ filter f . EM.elems . sactorD+  getsState $ any (\body ->+    bfid bodyOur == bfid body+    && blid bodyOur == blid body+    && not (bproj body)+    && bhp body > 0+    && any (\b -> adjacent (bpos b) (bpos body)) allFoes) . sactorD

− Game/LambdaHack/Client/AI/ConditionClient.hs

@@ -1,386 +0,0 @@--- | Semantics of abilities in terms of actions and the AI procedure--- for picking the best action for an actor.-module Game.LambdaHack.Client.AI.ConditionClient-  ( condTgtEnemyPresentM-  , condTgtEnemyRememberedM-  , condTgtEnemyAdjFriendM-  , condTgtNonmovingM-  , condAnyFoeAdjM-  , condHpTooLowM-  , condOnTriggerableM-  , condBlocksFriendsM-  , condFloorWeaponM-  , condNoEqpWeaponM-  , condEnoughGearM-  , condCanProjectM-  , condNotCalmEnoughM-  , condDesirableFloorItemM-  , condMeleeBadM-  , condLightBetraysM-  , benAvailableItems-  , hinders-  , benGroundItems-  , desirableItem-  , threatDistList-  , fleeList-  ) where--import Control.Applicative-import Control.Arrow ((&&&))-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.List-import Data.Maybe-import Data.Ord--import Game.LambdaHack.Client.AI.Preferences-import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import qualified Game.LambdaHack.Common.Ability as Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.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.Request-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import qualified Game.LambdaHack.Content.ItemKind as IK---- | Require that the target enemy is visible by the party.-condTgtEnemyPresentM :: MonadClient m => ActorId -> m Bool-condTgtEnemyPresentM aid = do-  btarget <- getsClient $ getTarget aid-  return $! case btarget of-    Just (TEnemy _ permit) -> not permit-    _ -> False---- | Require that the target enemy is remembered on the actor's level.-condTgtEnemyRememberedM :: MonadClient m => ActorId -> m Bool-condTgtEnemyRememberedM aid = do-  b <- getsState $ getActorBody aid-  btarget <- getsClient $ getTarget aid-  return $! case btarget of-    Just (TEnemyPos _ lid _ permit) | lid == blid b -> not permit-    _ -> False---- | Require that the target enemy is adjacent to at least one friend.-condTgtEnemyAdjFriendM :: MonadClient m => ActorId -> m Bool-condTgtEnemyAdjFriendM aid = do-  btarget <- getsClient $ getTarget aid-  case btarget of-    Just (TEnemy enemy _) -> do-      be <- getsState $ getActorBody enemy-      b <- getsState $ getActorBody aid-      fact <- getsState $ (EM.! bfid b) . sfactionD-      let friendlyFid fid = fid == bfid b || isAllied fact fid-      friends <- getsState $ actorRegularList friendlyFid (blid b)-      return $ any (adjacent (bpos be) . bpos) friends  -- keep it lazy-    _ -> return False---- | Check if the target is nonmoving.-condTgtNonmovingM :: MonadClient m => ActorId -> m Bool-condTgtNonmovingM aid = do-  btarget <- getsClient $ getTarget aid-  case btarget of-    Just (TEnemy enemy _) -> do-      activeItems <- activeItemsClient enemy-      let actorMaxSkE = sumSkills activeItems-      return $! EM.findWithDefault 0 Ability.AbMove actorMaxSkE <= 0-    _ -> return False---- | Require that any non-dying foe is adjacent.-condAnyFoeAdjM :: MonadStateRead m => ActorId -> m Bool-condAnyFoeAdjM aid = do-  b <- getsState $ getActorBody aid-  fact <- getsState $ (EM.! bfid b) . sfactionD-  allFoes <- getsState $ actorRegularList (isAtWar fact) (blid b)-  return $ any (adjacent (bpos b) . bpos) allFoes  -- keep it lazy---- | Require the actor's HP is low enough.-condHpTooLowM :: MonadClient m => ActorId -> m Bool-condHpTooLowM aid = do-  b <- getsState $ getActorBody aid-  activeItems <- activeItemsClient aid-  return $! hpTooLow b activeItems---- | Require the actor stands over a triggerable tile.-condOnTriggerableM :: MonadStateRead m => ActorId -> m Bool-condOnTriggerableM aid = do-  Kind.COps{cotile} <- getsState scops-  b <- getsState $ getActorBody aid-  lvl <- getLevel $ blid b-  let t = lvl `at` bpos b-  return $! not $ null $ Tile.causeEffects cotile t---- | Produce the chess-distance-sorted list of non-low-HP foes on the level.--- We don't consider path-distance, because we are interested in how soon--- the foe can hit us, which can diverge greately from path distance--- for short distances.-threatDistList :: MonadClient m => ActorId -> m [(Int, (ActorId, Actor))]-threatDistList aid = do-  b <- getsState $ getActorBody aid-  fact <- getsState $ (EM.! bfid b) . sfactionD-  allAtWar <- getsState $ actorRegularAssocs (isAtWar fact) (blid b)-  let strongActor (aid2, b2) = do-        activeItems <- activeItemsClient aid2-        let actorMaxSkE = sumSkills activeItems-            nonmoving = EM.findWithDefault 0 Ability.AbMove actorMaxSkE <= 0-        return $! not (hpTooLow b2 activeItems || nonmoving)-  allThreats <- filterM strongActor allAtWar-  let addDist (aid2, b2) = (chessDist (bpos b) (bpos b2), (aid2, b2))-  return $ sortBy (comparing fst) $ map addDist allThreats---- | Require the actor blocks the paths of any of his party members.-condBlocksFriendsM :: MonadClient m => ActorId -> m Bool-condBlocksFriendsM aid = do-  b <- getsState $ getActorBody aid-  ours <- getsState $ actorRegularAssocs (== bfid b) (blid b)-  targetD <- getsClient stargetD-  let blocked (aid2, _) = aid2 /= aid &&-        case EM.lookup aid2 targetD of-          Just (_, Just (_ : q : _, _)) | q == bpos b -> True-          _ -> False-  return $ any blocked ours  -- keep it lazy---- | Require the actor stands over a weapon that would be auto-equipped.-condFloorWeaponM :: MonadClient m => ActorId -> m Bool-condFloorWeaponM aid = do-  floorAssocs <- fullAssocsClient aid [CGround]-  let lootIsWeapon = any (isMeleeEqp . snd) floorAssocs-  return lootIsWeapon  -- keep it lazy---- | Check whether the actor has no weapon in equipment.-condNoEqpWeaponM :: MonadClient m => ActorId -> m Bool-condNoEqpWeaponM aid = do-  allAssocs <- fullAssocsClient aid [CEqp]-  return $ all (not . isMelee . snd) allAssocs  -- keep it lazy---- | Check whether the actor has enough gear to go look for enemies.-condEnoughGearM :: MonadClient m => ActorId -> m Bool-condEnoughGearM aid = do-  eqpAssocs <- fullAssocsClient aid [CEqp]-  invAssocs <- fullAssocsClient aid [CInv]-  return $ any (isMelee . snd) eqpAssocs-           || length (eqpAssocs ++ invAssocs) >= 5-    -- keep it lazy---- | Require that the actor can project any items.-condCanProjectM :: MonadClient m => Bool -> ActorId -> m Bool-condCanProjectM maxSkills aid = do-  actorSk <- if maxSkills-             then do-               activeItems <- activeItemsClient aid-               return $! sumSkills activeItems-             else-               actorSkillsClient aid-  let skill = EM.findWithDefault 0 Ability.AbProject actorSk-      q _ itemFull b activeItems =-        either (const False) id-        $ 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-                  -> (Maybe Int -> ItemFull -> Actor -> [ItemFull] -> Bool)-                  -> [CStore]-                  -> m [( (Maybe (Int, Int), (Int, CStore))-                        , (ItemId, ItemFull) )]-benAvailableItems aid permitted cstores = do-  cops <- getsState scops-  itemToF <- itemToFullClient-  b <- getsState $ getActorBody aid-  activeItems <- activeItemsClient aid-  fact <- getsState $ (EM.! bfid b) . sfactionD-  condAnyFoeAdj <- condAnyFoeAdjM aid-  condLightBetrays <- condLightBetraysM aid-  condTgtEnemyPresent <- condTgtEnemyPresentM aid-  condNotCalmEnough <- condNotCalmEnoughM aid-  let ben cstore bag =-        [ ((benefit, (k, cstore)), (iid, itemFull))-        | (iid, kit@(k, _)) <- EM.assocs bag-        , let itemFull = itemToF iid kit-              benefit = totalUsefulness cops b activeItems fact itemFull-              hind = hinders condAnyFoeAdj condLightBetrays-                             condTgtEnemyPresent condNotCalmEnough-                             b activeItems itemFull-        , permitted (fst <$> benefit) itemFull b activeItems-          && (cstore /= CEqp || hind) ]-      benCStore cs = do-        bag <- getsState $ getActorBag aid cs-        return $! ben cs bag-  perBag <- mapM benCStore cstores-  return $ concat perBag-    -- keep it lazy---- TODO: also take into account dynamic lights *not* wielded by the actor-hinders :: Bool -> Bool -> Bool -> Bool -> Actor -> [ItemFull] -> ItemFull-        -> Bool-hinders condAnyFoeAdj condLightBetrays condTgtEnemyPresent-        condNotCalmEnough  -- perhaps enemies don't have projectiles-        body activeItems itemFull =-  let itemLit = isJust $ strengthFromEqpSlot IK.EqpSlotAddLight itemFull-      itemLitBad = itemLit && condNotCalmEnough && not condAnyFoeAdj-  in -- Fast actors want to hide in darkness to ambush opponents and want-     -- to hit hard for the short span they get to survive melee.-     bspeed body activeItems > speedNormal-     && (itemLitBad-         || 0 > fromMaybe 0 (strengthFromEqpSlot IK.EqpSlotAddHurtMelee-                                                 itemFull))-     -- In the presence of enemies (seen, or unseen but distressing)-     -- actors want to hide in the dark.-     || let heavilyDistressed =  -- actor hit by a proj or similarly distressed-              deltaSerious (bcalmDelta body)-        in itemLitBad && condLightBetrays-           && (heavilyDistressed || condTgtEnemyPresent)-  -- TODO:-  -- teach AI to turn shields OFF (or stash) when ganging up on an enemy-  -- (friends close, only one enemy close)-  -- and turning on afterwards (AI plays for time, especially spawners-  -- so shields are preferable by default;-  -- also, turning on when no friends and enemies close is too late,-  -- AI should flee or fire at such times, not muck around with eqp)---- | Require the actor is not calm enough.-condNotCalmEnoughM :: MonadClient m => ActorId -> m Bool-condNotCalmEnoughM aid = do-  b <- getsState $ getActorBody aid-  activeItems <- activeItemsClient aid-  return $! not (calmEnough b activeItems)---- | Require that the actor stands over a desirable item.-condDesirableFloorItemM :: MonadClient m => ActorId -> m Bool-condDesirableFloorItemM aid = do-  benItemL <- benGroundItems aid-  return $ not $ null benItemL  -- keep it lazy---- | Produce the list of items on the ground beneath the actor--- that are worth picking up.-benGroundItems :: MonadClient m-               => ActorId-               -> m [( (Maybe (Int, Int)-                     , (Int, CStore)), (ItemId, ItemFull) )]-benGroundItems aid = do-  b <- getsState $ getActorBody aid-  canEscape <- factionCanEscape (bfid b)-  benAvailableItems aid (\use itemFull _ _ ->-                           desirableItem canEscape use itemFull) [CGround]--desirableItem :: Bool -> Maybe Int -> ItemFull -> Bool-desirableItem canEsc use itemFull =-  let item = itemBase itemFull-      freq = case itemDisco itemFull of-        Nothing -> []-        Just ItemDisco{itemKind} -> IK.ifreq itemKind-  in if canEsc-     then use /= Just 0-          || IK.Precious `elem` jfeature item-     else-       -- A hack to prevent monsters from picking up unidentified treasure.-       let preciousWithoutSlot =-             IK.Precious `elem` jfeature item  -- risk from treasure hunters-             && isNothing (strengthEqpSlot item)  -- unlikely to be useful-       in use /= Just 0-          && not (isNothing use  -- needs resources to id-                  && preciousWithoutSlot)-          -- TODO: terrible hack for the identified healing gems and normal-          -- gems identified with a scroll-          && maybe True (<= 0) (lookup "gem" freq)---- | Require the actor is in a bad position to melee or can't melee at all.-condMeleeBadM :: MonadClient m => ActorId -> m Bool-condMeleeBadM aid = do-  b <- getsState $ getActorBody aid-  btarget <- getsClient $ getTarget aid-  mtgtPos <- aidTgtToPos aid (blid b) btarget-  condTgtEnemyPresent <- condTgtEnemyPresentM aid-  condTgtEnemyRemembered <- condTgtEnemyRememberedM aid-  fact <- getsState $ (EM.! bfid b) . sfactionD-  activeItems <- activeItemsClient aid-  let condNoUsableWeapon = all (not . isMelee) activeItems-      friendlyFid fid = fid == bfid b || isAllied fact fid-  friends <- getsState $ actorRegularAssocs friendlyFid (blid b)-  let closeEnough b2 = let dist = chessDist (bpos b) (bpos b2)-                       in dist > 0 && (dist <= 2 || approaching b2)-      -- 3 is the condThreatAtHand distance that AI keeps when alone.-      approaching = case mtgtPos of-        Just tgtPos | condTgtEnemyPresent || condTgtEnemyRemembered ->-          \b1 -> chessDist (bpos b1) tgtPos <= 3-        _ -> const False-      closeFriends = filter (closeEnough . snd) friends-      strongActor (aid2, b2) = do-        activeItems2 <- activeItemsClient aid2-        let condUsableWeapon2 = any isMelee activeItems2-            actorMaxSk2 = sumSkills activeItems2-            canMelee2 = EM.findWithDefault 0 Ability.AbMelee actorMaxSk2 > 0-            hpGood = not $ hpTooLow b2 activeItems2-        return $! hpGood && condUsableWeapon2 && canMelee2-  strongCloseFriends <- filterM strongActor closeFriends-  let noFriendlyHelp = length closeFriends < 3-                       && null strongCloseFriends-                       && length friends > 1  -- solo fighters aggresive-                       && not (hpHuge b)  -- uniques, etc., aggresive-  let actorMaxSk = sumSkills activeItems-  return $ condNoUsableWeapon-           || EM.findWithDefault 0 Ability.AbMelee actorMaxSk <= 0-           || noFriendlyHelp  -- still not getting friends' help-    -- no $!; keep it lazy---- | Require that the actor stands in the dark, but is betrayed--- by his own equipped light,-condLightBetraysM :: MonadClient m => ActorId -> m Bool-condLightBetraysM aid = do-  b <- getsState $ getActorBody aid-  eqpItems <- map snd <$> fullAssocsClient aid [CEqp]-  let actorEqpShines = sumSlotNoFilter 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---- | Produce a list of acceptable adjacent points to flee to.-fleeList :: MonadClient m => ActorId -> m ([(Int, Point)], [(Int, Point)])-fleeList aid = do-  cops <- getsState scops-  mtgtMPath <- getsClient $ EM.lookup aid . stargetD-  let tgtPath = case mtgtMPath of  -- prefer fleeing along the path to target-        Just (TEnemy{}, _) -> []  -- don't flee towards an enemy-        Just (TEnemyPos{}, _) -> []-        Just (_, Just (_ : path, _)) -> path-        _ -> []-  b <- getsState $ getActorBody aid-  fact <- getsState $ \s -> sfactionD s EM.! bfid b-  allFoes <- getsState $ actorRegularList (isAtWar fact) (blid b)-  lvl@Level{lxsize, lysize} <- getLevel $ blid b-  let posFoes = map bpos allFoes-      accessibleHere = accessible cops lvl $ bpos b-      myVic = vicinity lxsize lysize $ bpos b-      dist p | null posFoes = assert `failure` b-             | otherwise = minimum $ map (chessDist p) posFoes-      dVic = map (dist &&& id) myVic-      -- Flee, if possible. Access required.-      accVic = filter (accessibleHere . snd) dVic-      gtVic = filter ((> dist (bpos b)) . fst) accVic-      eqVic = filter ((== dist (bpos b)) . fst) accVic-      ltVic = filter ((< dist (bpos b)) . fst) accVic-      rewardPath mult (d, p)-        | p `elem` tgtPath = (100 * mult * d, p)-        | any (\q -> chessDist p q == 1) tgtPath = (10 * mult * d, p)-        | otherwise = (mult * d, p)-      goodVic = map (rewardPath 10000) gtVic-                ++ map (rewardPath 100) eqVic-      badVic = map (rewardPath 1) ltVic-  return (goodVic, badVic)  -- keep it lazy

+ Game/LambdaHack/Client/AI/ConditionM.hs view

@@ -0,0 +1,339 @@+-- | Semantics of abilities in terms of actions and the AI procedure+-- for picking the best action for an actor.+module Game.LambdaHack.Client.AI.ConditionM+  ( condAimEnemyPresentM+  , condAimEnemyRememberedM+  , condTgtNonmovingM+  , condAnyFoeAdjM+  , condAdjTriggerableM+  , condBlocksFriendsM+  , condFloorWeaponM+  , condNoEqpWeaponM+  , condCanProjectM+  , condProjectListM+  , condDesirableFloorItemM+  , condSupport+  , benAvailableItems+  , hinders+  , benGroundItems+  , desirableItem+  , meleeThreatDistList+  , condShineWouldBetrayM+  , fleeList+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.EnumMap.Strict as EM+import Data.Ord++import Game.LambdaHack.Client.Bfs+import Game.LambdaHack.Client.CommonM+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import qualified Game.LambdaHack.Common.Ability as Ability+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Vector+import qualified Game.LambdaHack.Content.ItemKind as IK+import Game.LambdaHack.Content.ModeKind++-- All conditions are (partially) lazy, because they are not always+-- used in the strict monadic computations they are in.++-- | Require that the target enemy is visible by the party.+condAimEnemyPresentM :: MonadClient m => ActorId -> m Bool+condAimEnemyPresentM aid = do+  btarget <- getsClient $ getTarget aid+  return $ case btarget of+    Just (TEnemy _ permit) -> not permit+    _ -> False++-- | Require that the target enemy is remembered on the actor's level.+condAimEnemyRememberedM :: MonadClient m => ActorId -> m Bool+condAimEnemyRememberedM aid = do+  b <- getsState $ getActorBody aid+  btarget <- getsClient $ getTarget aid+  return $ case btarget of+    Just (TPoint (TEnemyPos _ permit) lid _) | lid == blid b -> not permit+    _ -> False++-- | Check if the target is nonmoving.+condTgtNonmovingM :: MonadClient m => ActorId -> m Bool+condTgtNonmovingM aid = do+  btarget <- getsClient $ getTarget aid+  case btarget of+    Just (TEnemy enemy _) -> do+      actorMaxSk <- maxActorSkillsClient enemy+      return $ EM.findWithDefault 0 Ability.AbMove actorMaxSk <= 0+    _ -> return False++-- | Require that any non-dying foe is adjacent, except projectiles+-- that (possibly) explode upon contact.+condAnyFoeAdjM :: MonadStateRead m => ActorId -> m Bool+condAnyFoeAdjM aid = getsState $ anyFoeAdj aid++-- | Require the actor stands adjacent to a triggerable tile (e.g., stairs).+condAdjTriggerableM :: MonadStateRead m => ActorId -> m Bool+condAdjTriggerableM aid = do+  b <- getsState $ getActorBody aid+  lvl <- getLevel $ blid b+  let hasTriggerable p = p `EM.member` lembed lvl+  return $ any hasTriggerable $ vicinityUnsafe $ bpos b++-- | Produce the chess-distance-sorted list of non-low-HP,+-- melee-cabable foes on the level. We don't consider path-distance,+-- because we are interested in how soon the foe can close in to hit us,+-- which can diverge greately from path distance for short distances,+-- e.g., when terrain gets revealed. We don't consider non-moving actors,+-- because they can't chase us and also because they can't be aggresive+-- so to resolve the stalemate, the opposing AI has to be aggresive+-- by ignoring them and then when melee is started, it's usually too late+-- to retreat.+meleeThreatDistList :: MonadClient m => ActorId -> m [(Int, (ActorId, Actor))]+meleeThreatDistList aid = do+  actorAspect <- getsClient sactorAspect+  b <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  allAtWar <- getsState $ actorRegularAssocs (isAtWar fact) (blid b)+  let strongActor (aid2, b2) =+        let ar = actorAspect EM.! aid2+            actorMaxSkE = aSkills ar+            nonmoving = EM.findWithDefault 0 Ability.AbMove actorMaxSkE <= 0+        in not (hpTooLow b2 ar || nonmoving)+           && actorCanMelee actorAspect aid2 b2+      allThreats = filter strongActor allAtWar+      addDist (aid2, b2) = (chessDist (bpos b) (bpos b2), (aid2, b2))+  return $ sortBy (comparing fst) $ map addDist allThreats++-- | Require the actor blocks the paths of any of his party members.+condBlocksFriendsM :: MonadClient m => ActorId -> m Bool+condBlocksFriendsM aid = do+  b <- getsState $ getActorBody aid+  ours <- getsState $ fidActorRegularIds (bfid b) (blid b)+  targetD <- getsClient stargetD+  let blocked aid2 = aid2 /= aid &&+        case EM.lookup aid2 targetD of+          Just TgtAndPath{tapPath=AndPath{pathList=q : _}} | q == bpos b -> True+          _ -> False+  return $ any blocked ours++-- | Require the actor stands over a weapon that would be auto-equipped.+condFloorWeaponM :: MonadClient m => ActorId -> m Bool+condFloorWeaponM aid = do+  floorAssocs <- getsState $ getActorAssocs aid CGround+  let lootIsWeapon = any (isMelee . snd) floorAssocs+  return lootIsWeapon++-- | Check whether the actor has no weapon in equipment.+condNoEqpWeaponM :: MonadClient m => ActorId -> m Bool+condNoEqpWeaponM aid = do+  eqpAssocs <- getsState $ getActorAssocs aid CEqp+  return $ all (not . isMelee . snd) eqpAssocs++-- | Require that the actor can project any items.+condCanProjectM :: MonadClient m => Int -> ActorId -> m Bool+condCanProjectM skill aid = do+  -- Compared to conditions in @projectItem@, range and charge are ignored,+  -- because they may change by the time the position for the fling is reached.+  benList <- condProjectListM skill aid+  return $ not $ null benList++condProjectListM :: MonadClient m+                 => Int -> ActorId+                 -> m [(Maybe Benefit, CStore, ItemId, ItemFull)]+condProjectListM skill aid = do+  b <- getsState $ getActorBody aid+  condShineWouldBetray <- condShineWouldBetrayM aid+  condAimEnemyPresent <- condAimEnemyPresentM aid+  actorAspect <- getsClient sactorAspect+  let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect)+      calmE = calmEnough b ar+      condNotCalmEnough = not calmE+      heavilyDistressed =  -- Actor hit by a projectile or similarly distressed.+        deltaSerious (bcalmDelta b)+      -- This detects if the value of keeping the item in eqp is in fact < 0.+      hind = hinders condShineWouldBetray condAimEnemyPresent+                     heavilyDistressed condNotCalmEnough b ar+      q (mben, _, _, itemFull) =+        let (bInEqp, bFling) = case mben of+              Just Benefit{benInEqp, benFling} -> (benInEqp, benFling)+              Nothing -> (goesIntoEqp $ itemBase itemFull, -10)+        in bFling < 0+           && (not bInEqp  -- can't wear, so OK to risk losing or breaking+               || not (isMelee $ itemBase itemFull)  -- anything else expendable+                  && hind itemFull)  -- hinders now, so possibly often, so away!+           && permittedProjectAI skill calmE itemFull+  benList <- benAvailableItems aid $ [CEqp, CInv, CGround] ++ [CSha | calmE]+  return $ filter q benList++-- | Produce the list of items with a given property available to the actor+-- and the items' values.+benAvailableItems :: MonadClient m+                  => ActorId -> [CStore]+                  -> m [(Maybe Benefit, CStore, ItemId, ItemFull)]+benAvailableItems aid cstores = do+  itemToF <- itemToFullClient+  b <- getsState $ getActorBody aid+  discoBenefit <- getsClient sdiscoBenefit+  s <- getState+  let ben cstore bag =+        [ (mben, cstore, iid, itemFull)+        | (iid, kit) <- EM.assocs bag+        , let itemFull = itemToF iid kit+              mben = EM.lookup iid discoBenefit ]+      benCStore cs = ben cs $ getBodyStoreBag b cs s+  return $ concatMap benCStore cstores++hinders :: Bool -> Bool -> Bool -> Bool -> Actor -> AspectRecord -> ItemFull+        -> Bool+hinders condShineWouldBetray condAimEnemyPresent+        heavilyDistressed condNotCalmEnough+          -- guess that enemies have projectiles and used them now or recently+        body ar itemFull =+  let itemShine = 0 < aShine (aspectRecordFull itemFull)+      -- @condAnyFoeAdj@ is not checked, because it's transient and also item+      -- management is unlikely to happen during melee, anyway+      itemShineBad = condShineWouldBetray && itemShine+  in -- In the presence of enemies (seen, or unseen but distressing)+     -- actors want to hide in the dark.+     (condAimEnemyPresent || condNotCalmEnough || heavilyDistressed)+     && itemShineBad  -- even if it's a weapon, take it off+     -- Fast actors want to hit hard, because they hit much more often+     -- than receive hits.+     || bspeed body ar > speedWalk+        && not (isMelee $ itemBase itemFull)  -- in case it's the only weapon+        && 0 > aHurtMelee (aspectRecordFull itemFull)++-- | Require that the actor stands over a desirable item.+condDesirableFloorItemM :: MonadClient m => ActorId -> m Bool+condDesirableFloorItemM aid = do+  benItemL <- benGroundItems aid+  return $ not $ null benItemL++-- | Produce the list of items on the ground beneath the actor+-- that are worth picking up.+benGroundItems :: MonadClient m+               => ActorId+               -> m [(Maybe Benefit, CStore, ItemId, ItemFull)]+benGroundItems aid = do+  b <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  let canEsc = fcanEscape (gplayer fact)+      isDesirable (mben, _, _, itemFull) =+        desirableItem canEsc (benPickup <$> mben) (itemBase itemFull)+  benList <- benAvailableItems aid [CGround]+  return $ filter isDesirable benList++desirableItem :: Bool -> Maybe Int -> Item -> Bool+desirableItem canEsc mpickupSum item =+  if canEsc+  then fromMaybe 10 mpickupSum > 0+       || IK.Precious `elem` jfeature item+  else+    -- A hack to prevent monsters from picking up treasure meant for heroes.+    let preciousNotUseful =  -- suspect and probably useless jewelry+          IK.Precious `elem` jfeature item  -- risk from treasure hunters+          && IK.Equipable `notElem` jfeature item  -- can't wear+    in fromMaybe 10 mpickupSum > 0+       && not preciousNotUseful  -- hack for elixir: even if @use@ positive++condSupport :: MonadClient m => Int -> ActorId -> m Bool+condSupport param aid = do+  actorAspect <- getsClient sactorAspect+  b <- getsState $ getActorBody aid+  btarget <- getsClient $ getTarget aid+  mtgtPos <- case btarget of+    Nothing -> return Nothing+    Just target -> aidTgtToPos aid (blid b) target+  condAimEnemyPresent <- condAimEnemyPresentM aid+  condAimEnemyRemembered <- condAimEnemyRememberedM aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  let friendlyFid fid = fid == bfid b || isAllied fact fid+      ar = actorAspect EM.! aid+  friends <- getsState $ actorRegularAssocs friendlyFid (blid b)+  let approaching = case mtgtPos of+        Just tgtPos | condAimEnemyPresent || condAimEnemyRemembered ->+          \b2 -> chessDist (bpos b2) tgtPos <= 1 + param+        _ -> const False+      closeEnough b2 = let dist = chessDist (bpos b) (bpos b2)+                       in dist > 0 && (dist <= param || approaching b2)+      closeAndStrong (aid2, b2) = closeEnough b2+                                  && actorCanMelee actorAspect aid2 b2+      closeAndStrongFriends = filter closeAndStrong friends+      -- The smaller area scanned for friends, the lower number required.+      suport = length closeAndStrongFriends >= param - aAggression ar+               || length friends <= 1  -- solo fighters aggresive+  return suport++-- | Require that the actor stands in the dark and so would be betrayed+-- by his own equipped light,+condShineWouldBetrayM :: MonadClient m => ActorId -> m Bool+condShineWouldBetrayM aid = do+  b <- getsState $ getActorBody aid+  aInAmbient <- getsState $ actorInAmbient b+  return $ not aInAmbient  -- tile is dark, so actor could hide++-- | Produce a list of acceptable adjacent points to flee to.+fleeList :: MonadClient m => ActorId -> m ([(Int, Point)], [(Int, Point)])+fleeList aid = do+  Kind.COps{coTileSpeedup} <- getsState scops+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  -- Prefer fleeing along the path to target, unless the target is a foe,+  -- in which case flee in the opposite direction.+  let etgtPath = case mtgtMPath of+        Just TgtAndPath{ tapPath=tapPath@AndPath{pathList}+                       , tapTgt } -> case tapTgt of+          TEnemy{} -> Left tapPath+          TPoint TEnemyPos{} _ _ -> Left tapPath+          _ -> Right pathList+        _ -> Right []+  b <- getsState $ getActorBody aid+  allFoes <- getsState $ warActorRegularList (bfid b) (blid b)+  lvl@Level{lxsize, lysize} <- getLevel $ blid b+  s <- getState+  let posFoes = map bpos allFoes+      myVic = vicinity lxsize lysize $ bpos b+      dist p | null posFoes = 100+             | otherwise = minimum $ map (chessDist p) posFoes+      dVic = map (dist &&& id) myVic+      -- Flee, if possible. Direct access required; not enough time to open.+      -- Can't be occupied.+      accUnocc p = Tile.isWalkable coTileSpeedup (lvl `at` p)+                   && null (posToAssocs p (blid b) s)+      accVic = filter (accUnocc . snd) dVic+      gtVic = filter ((> dist (bpos b)) . fst) accVic+      eqVic = filter ((== dist (bpos b)) . fst) accVic+      ltVic = filter ((< dist (bpos b)) . fst) accVic+      rewardPath mult (d, p) = case etgtPath of+        Right tgtPath | p `elem` tgtPath ->+          (100 * mult * d, p)+        Right tgtPath | any (adjacent p) tgtPath ->+          (10 * mult * d, p)+        Left AndPath{pathGoal} | bpos b /= pathGoal ->+          let venemy = towards (bpos b) pathGoal+              vflee = towards (bpos b) p+              sq = euclidDistSqVector venemy vflee+              skew = case compare sq 2 of+                GT -> 100 * sq+                EQ -> 10 * sq+                LT -> sq  -- going towards enemy (but may escape adjacent foes)+          in (mult * skew * d, p)+        _ -> (mult * d, p)  -- far from target path or even on target goal+      goodVic = map (rewardPath 10000) gtVic+                ++ map (rewardPath 100) eqVic+      badVic = map (rewardPath 1) ltVic+  return (goodVic, badVic)

− Game/LambdaHack/Client/AI/HandleAbilityClient.hs

@@ -1,962 +0,0 @@-{-# LANGUAGE DataKinds #-}--- | Semantics of abilities in terms of actions and the AI procedure--- for picking the best action for an actor.-module Game.LambdaHack.Client.AI.HandleAbilityClient-  ( actionStrategy-  ) where--import Control.Applicative-import Control.Arrow (second)-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Function-import Data.List-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Ord-import Data.Ratio-import Data.Text (Text)--import Game.LambdaHack.Client.AI.ConditionClient-import Game.LambdaHack.Client.AI.Preferences-import Game.LambdaHack.Client.AI.Strategy-import Game.LambdaHack.Client.BfsClient-import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Frequency-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.ModeKind-import qualified Game.LambdaHack.Content.TileKind as TK--type ToAny a = Strategy (RequestTimed a) -> Strategy RequestAnyAbility--toAny :: ToAny a-toAny strat = RequestAnyAbility <$> strat---- | AI strategy based on actor's sight, smell, etc.--- Never empty.-actionStrategy :: forall m. MonadClient m-               => ActorId -> m (Strategy RequestAnyAbility)-actionStrategy aid = do-  body <- getsState $ getActorBody aid-  activeItems <- activeItemsClient aid-  fact <- getsState $ (EM.! bfid body) . sfactionD-  condTgtEnemyPresent <- condTgtEnemyPresentM aid-  condTgtEnemyRemembered <- condTgtEnemyRememberedM aid-  condTgtEnemyAdjFriend <- condTgtEnemyAdjFriendM aid-  condAnyFoeAdj <- condAnyFoeAdjM aid-  threatDistL <- threatDistList aid-  condHpTooLow <- condHpTooLowM aid-  condOnTriggerable <- condOnTriggerableM aid-  condBlocksFriends <- condBlocksFriendsM aid-  condNoEqpWeapon <- condNoEqpWeaponM aid-  let condNoUsableWeapon = all (not . isMelee) activeItems-  condEnoughGear <- condEnoughGearM aid-  condFloorWeapon <- condFloorWeaponM aid-  condCanProject <- condCanProjectM False aid-  condNotCalmEnough <- condNotCalmEnoughM aid-  condDesirableFloorItem <- condDesirableFloorItemM aid-  condMeleeBad <- condMeleeBadM aid-  condTgtNonmoving <- condTgtNonmovingM aid-  aInAmbient <- getsState $ actorInAmbient body-  explored <- getsClient sexplored-  (fleeL, badVic) <- fleeList aid-  let lidExplored = ES.member (blid body) explored-      panicFleeL = fleeL ++ badVic-      actorShines = sumSlotNoFilter IK.EqpSlotAddLight activeItems > 0-      condThreatAdj = not $ null $ takeWhile ((== 1) . fst) threatDistL-      condThreatAtHand = not $ null $ takeWhile ((<= 2) . fst) threatDistL-      condThreatNearby = not $ null $ takeWhile ((<= 9) . fst) threatDistL-      speed1_5 = speedScale (3%2) (bspeed body activeItems)-      condFastThreatAdj = any (\(_, (_, b)) -> bspeed b activeItems > speed1_5)-                          $ takeWhile ((== 1) . fst) threatDistL-      heavilyDistressed =  -- actor hit by a proj or similarly distressed-        deltaSerious (bcalmDelta body)-  let actorMaxSk = sumSkills activeItems-      abInMaxSkill ab = EM.findWithDefault 0 ab actorMaxSk > 0-      stratToFreq :: MonadStateRead m-                  => Int -> m (Strategy RequestAnyAbility)-                  -> m (Frequency RequestAnyAbility)-      stratToFreq scale mstrat = do-        st <- mstrat-        return $! if scale == 0-                  then mzero-                  else scaleFreq scale $ bestVariant st  -- TODO: flatten instead?-      -- Order matters within the list, because it's summed with .| after-      -- filtering. Also, the results of prefix, distant and suffix-      -- are summed with .| at the end.-      prefix, suffix :: [([Ability], m (Strategy RequestAnyAbility), Bool)]-      prefix =-        [ ( [AbApply], (toAny :: ToAny 'AbApply)-            <$> applyItem aid ApplyFirstAid-          , condHpTooLow && not condAnyFoeAdj-            && not condOnTriggerable )  -- don't block stairs, perhaps ascend-        , ( [AbTrigger], (toAny :: ToAny 'AbTrigger)-            <$> trigger aid True-              -- flee via stairs, even if to wrong level-              -- may return via different stairs-          , condOnTriggerable-            && ((condNotCalmEnough || condHpTooLow)-                && condThreatNearby && not condTgtEnemyPresent-                || condMeleeBad && condThreatAdj) )-        , ( [AbDisplace]-          , displaceFoe aid  -- only swap with an enemy to expose him-          , condBlocksFriends && condAnyFoeAdj-            && not condOnTriggerable && not condDesirableFloorItem )-        , ( [AbMoveItem], (toAny :: ToAny 'AbMoveItem)-            <$> pickup aid True-          , condNoEqpWeapon && condFloorWeapon && not condHpTooLow-            && abInMaxSkill AbMelee )-        , ( [AbMelee], (toAny :: ToAny 'AbMelee)-            <$> meleeBlocker aid  -- only melee target or blocker-          , condAnyFoeAdj-            || not (abInMaxSkill AbDisplace)  -- melee friends, not displace-               && fleaderMode (gplayer fact) == LeaderNull  -- not restrained-               && condTgtEnemyPresent )  -- excited-        , ( [AbTrigger], (toAny :: ToAny 'AbTrigger)-            <$> trigger aid False-          , condOnTriggerable && not condDesirableFloorItem-            && (lidExplored || condEnoughGear)-            && not condTgtEnemyPresent )-        , ( [AbMove]-          , flee aid fleeL-          , condMeleeBad && not condFastThreatAdj-            -- Don't keep fleeing if was just hit, unless can't melee at all.-            && not (heavilyDistressed-                    && abInMaxSkill AbMelee-                    && not condNoUsableWeapon)-            && condThreatAtHand )-        , ( [AbDisplace]  -- prevents some looping movement-          , displaceBlocker aid  -- fires up only when path blocked-          , not condDesirableFloorItem )-        , ( [AbMoveItem], (toAny :: ToAny 'AbMoveItem)-            <$> equipItems aid  -- doesn't take long, very useful if safe-                                -- only if calm enough, so high priority-          , not (condAnyFoeAdj-                 || condDesirableFloorItem-                 || condNotCalmEnough) )-        ]-      -- Order doesn't matter, scaling does.-      distant :: [([Ability], m (Frequency RequestAnyAbility), Bool)]-      distant =-        [ ( [AbMoveItem]-          , stratToFreq 20000 $ (toAny :: ToAny 'AbMoveItem)-            <$> yieldUnneeded aid  -- 20000 to unequip ASAP, unless is thrown-          , True )-        , ( [AbProject]  -- for high-value target, shoot even in melee-          , stratToFreq 2 $ (toAny :: ToAny 'AbProject)-            <$> projectItem aid-          , condTgtEnemyPresent && condCanProject && not condOnTriggerable )-        , ( [AbApply]-          , stratToFreq 2 $ (toAny :: ToAny 'AbApply)-            <$> applyItem aid ApplyAll  -- use any potion or scroll-          , (condTgtEnemyPresent || condThreatNearby)  -- can affect enemies-            && not condOnTriggerable )-        , ( [AbMove]-          , stratToFreq (if not condTgtEnemyPresent-                         then 3  -- if enemy only remembered, investigate anyway-                         else if condTgtNonmoving-                         then 0-                         else if condTgtEnemyAdjFriend-                         then 1000  -- friends probably pummeled, go to help-                         else 100)-            $ chase aid True (condMeleeBad && condThreatNearby-                              && not aInAmbient && not actorShines)-          , (condTgtEnemyPresent || condTgtEnemyRemembered)-            && not (condDesirableFloorItem && not condThreatAtHand)-            && abInMaxSkill AbMelee-            && not condNoUsableWeapon )-        ]-      -- Order matters again.-      suffix =-        [ ( [AbMelee], (toAny :: ToAny 'AbMelee)-            <$> meleeAny aid  -- avoid getting damaged for naught-          , condAnyFoeAdj )-        , ( [AbMove]-          , flee aid panicFleeL  -- ultimate panic mode, displaces foes-          , condAnyFoeAdj )-        , ( [AbMoveItem], (toAny :: ToAny 'AbMoveItem)-            <$> pickup aid False-          , not condThreatAtHand )  -- e.g., to give to other party members-        , ( [AbMoveItem], (toAny :: ToAny 'AbMoveItem)-            <$> unEquipItems aid  -- late, because these items not bad-          , True )-        , ( [AbMove]-          , chase aid True (condTgtEnemyPresent-                            -- Don't keep hiding in darkness if hit right now,-                            -- unless can't melee at all.-                            && not (heavilyDistressed-                                    && abInMaxSkill AbMelee-                                    && not condNoUsableWeapon)-                            && condMeleeBad && condThreatNearby-                            && not aInAmbient && not actorShines)-          , not (condTgtNonmoving && condThreatAtHand) )--            -- TODO: unless tgt can't melee-        ]-      fallback =-        [ ( [AbWait], (toAny :: ToAny 'AbWait)-            <$> waitBlockNow-            -- Wait until friends sidestep; ensures strategy is never empty.-            -- TODO: try to switch leader away before that (we already-            -- switch him afterwards)-          , True )-        ]-      -- TODO: don't msum not to evaluate until needed-  -- Check current, not maximal skills, since this can be a non-leader action.-  actorSk <- actorSkillsClient aid-  let abInSkill ab = EM.findWithDefault 0 ab actorSk > 0-      checkAction :: ([Ability], m a, Bool) -> Bool-      checkAction (abts, _, cond) = all abInSkill abts && cond-      sumS abAction = do-        let as = filter checkAction abAction-        strats <- mapM (\(_, m, _) -> m) as-        return $! msum strats-      sumF abFreq = do-        let as = filter checkAction abFreq-        strats <- mapM (\(_, m, _) -> m) as-        return $! msum strats-      combineDistant as = liftFrequency <$> sumF as-  sumPrefix <- sumS prefix-  comDistant <- combineDistant distant-  sumSuffix <- sumS suffix-  sumFallback <- sumS fallback-  return $! sumPrefix .| comDistant .| sumSuffix .| sumFallback---- | A strategy to always just wait.-waitBlockNow :: MonadClient m => m (Strategy (RequestTimed 'AbWait))-waitBlockNow = return $! returN "wait" ReqWait--pickup :: MonadClient m-       => ActorId -> Bool -> m (Strategy (RequestTimed 'AbMoveItem))-pickup aid onlyWeapon = do-  benItemL <- benGroundItems aid-  b <- getsState $ getActorBody aid-  activeItems <- activeItemsClient aid-  -- This calmE is outdated when one of the items increases max Calm-  -- (e.g., in pickup, which handles many items at once), but this is OK,-  -- the server accepts item movement based on calm at the start, not end-  -- or in the middle.-  -- The calmE is inaccurate also if an item not IDed, but that's intended-  -- and the server will ignore and warn (and content may avoid that,-  -- e.g., making all rings identified)-  let calmE = calmEnough b activeItems-      isWeapon (_, (_, itemFull)) = isMeleeEqp itemFull-      filterWeapon | onlyWeapon = filter isWeapon-                   | otherwise = id-      prepareOne (oldN, l4) ((_, (k, _)), (iid, itemFull)) =-        let n = oldN + k-            (newN, toCStore)-              | calmE && goesIntoSha itemFull = (oldN, CSha)-              | goesIntoEqp itemFull && eqpOverfull b n =-                (oldN, if calmE then CSha else CInv)-              | goesIntoEqp itemFull = (n, CEqp)-              | otherwise = (oldN, CInv)-        in (newN, (iid, k, CGround, toCStore) : l4)-      (_, prepared) = foldl' prepareOne (0, []) $ filterWeapon benItemL-  return $! if null prepared-            then reject-            else returN "pickup" $ ReqMoveItems prepared--equipItems :: MonadClient m-           => ActorId -> m (Strategy (RequestTimed 'AbMoveItem))-equipItems aid = do-  cops <- getsState scops-  body <- getsState $ getActorBody aid-  activeItems <- activeItemsClient aid-  let calmE = calmEnough body activeItems-  fact <- getsState $ (EM.! bfid body) . sfactionD-  eqpAssocs <- fullAssocsClient aid [CEqp]-  invAssocs <- fullAssocsClient aid [CInv]-  shaAssocs <- fullAssocsClient aid [CSha]-  condAnyFoeAdj <- condAnyFoeAdjM aid-  condLightBetrays <- condLightBetraysM aid-  condTgtEnemyPresent <- condTgtEnemyPresentM aid-  let improve :: CStore-              -> (Int, [(ItemId, Int, CStore, CStore)])-              -> ( IK.EqpSlot-                 , ( [(Int, (ItemId, ItemFull))]-                   , [(Int, (ItemId, ItemFull))] ) )-              -> (Int, [(ItemId, Int, CStore, CStore)])-      improve fromCStore (oldN, l4) (slot, (bestInv, bestEqp)) =-        let n = 1 + oldN-        in case (bestInv, bestEqp) of-          ((_, (iidInv, _)) : _, []) | not (eqpOverfull body n) ->-            (n, (iidInv, 1, fromCStore, CEqp) : l4)-          ((vInv, (iidInv, _)) : _, (vEqp, _) : _)-            | not (eqpOverfull body n)-              && (vInv > vEqp || not (toShare slot)) ->-                (n, (iidInv, 1, fromCStore, CEqp) : l4)-          _ -> (oldN, l4)-      -- We filter out unneeded items. In particular, we ignore them in eqp-      -- when comparing to items we may want to equip. Anyway, the unneeded-      -- items should be removed in yieldUnneeded earlier or soon after.-      filterNeeded (_, itemFull) =-        not $ unneeded cops condAnyFoeAdj condLightBetrays-                       condTgtEnemyPresent (not calmE)-                       body activeItems fact itemFull-      bestThree = bestByEqpSlot (filter filterNeeded eqpAssocs)-                                (filter filterNeeded invAssocs)-                                (filter filterNeeded shaAssocs)-      bEqpInv = foldl' (improve CInv) (0, [])-                $ map (\((slot, _), (eqp, inv, _)) ->-                        (slot, (inv, eqp))) bestThree-      bEqpBoth | calmE =-                   foldl' (improve CSha) bEqpInv-                   $ map (\((slot, _), (eqp, _, sha)) ->-                           (slot, (sha, eqp))) bestThree-               | otherwise = bEqpInv-      (_, prepared) = bEqpBoth-  return $! if null prepared-            then reject-            else returN "equipItems" $ ReqMoveItems prepared--toShare :: IK.EqpSlot -> Bool-toShare IK.EqpSlotPeriodic = False-toShare _ = True--yieldUnneeded :: MonadClient m-              => ActorId -> m (Strategy (RequestTimed 'AbMoveItem))-yieldUnneeded aid = do-  cops <- getsState scops-  body <- getsState $ getActorBody aid-  activeItems <- activeItemsClient aid-  let calmE = calmEnough body activeItems-  fact <- getsState $ (EM.! bfid body) . sfactionD-  eqpAssocs <- fullAssocsClient aid [CEqp]-  condAnyFoeAdj <- condAnyFoeAdjM aid-  condLightBetrays <- condLightBetraysM aid-  condTgtEnemyPresent <- condTgtEnemyPresentM aid-      -- Here AI hides from the human player the Ring of Speed And Bleeding,-      -- which is a bit harsh, but fair. However any subsequent such-      -- rings will not be picked up at all, so the human player-      -- doesn't lose much fun. Additionally, if AI learns alchemy later on,-      -- they can repair the ring, wield it, drop at death and it's-      -- in play again.-  let yieldSingleUnneeded (iidEqp, itemEqp) =-        let csha = if calmE then CSha else CInv-        in if harmful cops body activeItems fact itemEqp-           then [(iidEqp, itemK itemEqp, CEqp, CInv)]-           else if hinders condAnyFoeAdj condLightBetrays-                           condTgtEnemyPresent (not calmE)-                           body activeItems itemEqp-           then [(iidEqp, itemK itemEqp, CEqp, csha)]-           else []-      yieldAllUnneeded = concatMap yieldSingleUnneeded eqpAssocs-  return $! if null yieldAllUnneeded-            then reject-            else returN "yieldUnneeded" $ ReqMoveItems yieldAllUnneeded--unEquipItems :: MonadClient m-             => ActorId -> m (Strategy (RequestTimed 'AbMoveItem))-unEquipItems aid = do-  cops <- getsState scops-  body <- getsState $ getActorBody aid-  activeItems <- activeItemsClient aid-  let calmE = calmEnough body activeItems-  fact <- getsState $ (EM.! bfid body) . sfactionD-  eqpAssocs <- fullAssocsClient aid [CEqp]-  invAssocs <- fullAssocsClient aid [CInv]-  shaAssocs <- fullAssocsClient aid [CSha]-  condAnyFoeAdj <- condAnyFoeAdjM aid-  condLightBetrays <- condLightBetraysM aid-  condTgtEnemyPresent <- condTgtEnemyPresentM aid-      -- Here AI hides from the human player the Ring of Speed And Bleeding,-      -- which is a bit harsh, but fair. However any subsequent such-      -- rings will not be picked up at all, so the human player-      -- doesn't lose much fun. Additionally, if AI learns alchemy later on,-      -- they can repair the ring, wield it, drop at death and it's-      -- in play again.-  let improve :: CStore -> ( IK.EqpSlot-                           , ( [(Int, (ItemId, ItemFull))]-                             , [(Int, (ItemId, ItemFull))] ) )-              -> [(ItemId, Int, CStore, CStore)]-      improve fromCStore (slot, (bestSha, bestEOrI)) =-        case (bestSha, bestEOrI) of-          _ | not (toShare slot)-              && fromCStore == CEqp-              && not (eqpOverfull body 1) ->  -- keep periodic items up to M-1-            []-          (_, (vEOrI, (iidEOrI, _)) : _) | (toShare slot || fromCStore == CInv)-                                           && getK bestEOrI > 1-                                           && betterThanSha vEOrI bestSha ->-            -- To share the best items with others, if they care.-            [(iidEOrI, getK bestEOrI - 1, fromCStore, CSha)]-          (_, _ : (vEOrI, (iidEOrI, _)) : _) | (toShare slot-                                                || fromCStore == CInv)-                                               && betterThanSha vEOrI bestSha ->-            -- To share the second best items with others, if they care.-            [(iidEOrI, getK bestEOrI, fromCStore, CSha)]-          (_, (vEOrI, (_, _)) : _) | fromCStore == CEqp-                                     && eqpOverfull body 1-                                     && worseThanSha vEOrI bestSha ->-            -- To make place in eqp for an item better than any ours.-            [(fst $ snd $ last bestEOrI, 1, fromCStore, CSha)]-          _ -> []-      getK [] = 0-      getK ((_, (_, itemFull)) : _) = itemK itemFull-      betterThanSha _ [] = True-      betterThanSha vEOrI ((vSha, _) : _) = vEOrI > vSha-      worseThanSha _ [] = False-      worseThanSha vEOrI ((vSha, _) : _) = vEOrI < vSha-      filterNeeded (_, itemFull) =-        not $ unneeded cops condAnyFoeAdj condLightBetrays-                       condTgtEnemyPresent (not calmE)-                       body activeItems fact itemFull-      bestThree =-        bestByEqpSlot eqpAssocs invAssocs (filter filterNeeded shaAssocs)-      bInvSha = concatMap-                  (improve CInv . (\((slot, _), (_, inv, sha)) ->-                                    (slot, (sha, inv)))) bestThree-      bEqpSha = concatMap-                  (improve CEqp . (\((slot, _), (eqp, _, sha)) ->-                                    (slot, (sha, eqp)))) bestThree-      prepared = if calmE then bInvSha ++ bEqpSha else []-  return $! if null prepared-            then reject-            else returN "unEquipItems" $ ReqMoveItems prepared--groupByEqpSlot :: [(ItemId, ItemFull)]-               -> M.Map (IK.EqpSlot, Text) [(ItemId, ItemFull)]-groupByEqpSlot is =-  let f (iid, itemFull) = case strengthEqpSlot $ itemBase itemFull of-        Nothing -> Nothing-        Just es -> Just (es, [(iid, itemFull)])-      withES = mapMaybe f is-  in M.fromListWith (++) withES--bestByEqpSlot :: [(ItemId, ItemFull)]-              -> [(ItemId, ItemFull)]-              -> [(ItemId, ItemFull)]-              -> [((IK.EqpSlot, Text)-                  , ( [(Int, (ItemId, ItemFull))]-                    , [(Int, (ItemId, ItemFull))]-                    , [(Int, (ItemId, ItemFull))] ) )]-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)-      eqpInvShaMap = M.unionsWith appendThree [eqpMap, invMap, shaMap]-      bestSingle = strongestSlot-      bestThree (eqpSlot, _) (g1, g2, g3) = (bestSingle eqpSlot g1,-                                             bestSingle eqpSlot g2,-                                             bestSingle eqpSlot g3)-  in M.assocs $ M.mapWithKey bestThree eqpInvShaMap--harmful :: Kind.COps -> Actor -> [ItemFull] -> Faction -> ItemFull -> Bool-harmful cops body activeItems fact itemFull =-  -- Items that are known and their effects are not stricly beneficial-  -- should not be equipped (either they are harmful or they waste eqp space).-  maybe False (\(u, _) -> u <= 0)-    (totalUsefulness cops body activeItems fact itemFull)--unneeded :: Kind.COps -> Bool -> Bool -> Bool -> Bool-         -> Actor -> [ItemFull] -> Faction -> ItemFull-         -> Bool-unneeded cops condAnyFoeAdj condLightBetrays-         condTgtEnemyPresent condNotCalmEnough-         body activeItems fact itemFull =-  harmful cops body activeItems fact itemFull-  || hinders condAnyFoeAdj condLightBetrays-             condTgtEnemyPresent condNotCalmEnough-             body activeItems itemFull-  || let calm10 = calmEnough10 body activeItems  -- unneeded risk-         itemLit = isJust $ strengthFromEqpSlot IK.EqpSlotAddLight itemFull-     in itemLit && not calm10---- Everybody melees in a pinch, even though some prefer ranged attacks.-meleeBlocker :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbMelee))-meleeBlocker aid = do-  b <- getsState $ getActorBody aid-  fact <- getsState $ (EM.! bfid b) . sfactionD-  actorSk <- actorSkillsClient aid-  mtgtMPath <- getsClient $ EM.lookup aid . stargetD-  case mtgtMPath of-    Just (_, Just (_ : q : _, (goal, _))) -> do-      -- We prefer the goal (e.g., when no accessible, but adjacent),-      -- but accept @q@ even if it's only a blocking enemy position.-      let maim | adjacent (bpos b) goal = Just goal-               | adjacent (bpos b) q = Just q-               | otherwise = Nothing  -- MeleeDistant-      lBlocker <- case maim of-        Nothing -> return []-        Just aim -> getsState $ posToActors aim (blid b)-      case lBlocker of-        (aid2, _) : _ -> do-          -- No problem if there are many projectiles at the spot. We just-          -- attack the first one.-          body2 <- getsState $ getActorBody aid2-          if not (actorDying body2)  -- already dying-             && (not (bproj body2)  -- displacing saves a move-                 && isAtWar fact (bfid body2)  -- they at war with us-                 || EM.findWithDefault 0 AbDisplace actorSk <= 0  -- not disp.-                    && fleaderMode (gplayer fact) == LeaderNull  -- no restrain-                    && EM.findWithDefault 0 AbMove actorSk > 0  -- blocked move-                    && bhp body2 < bhp b)  -- respect power-            then do-              mel <- maybeToList <$> pickWeaponClient aid aid2-              return $! liftFrequency $ uniformFreq "melee in the way" mel-            else return reject-        [] -> return reject-    _ -> return reject  -- probably no path to the enemy, if any---- Everybody melees in a pinch, skills and weapons allowing,--- even though some prefer ranged attacks.-meleeAny :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbMelee))-meleeAny aid = do-  b <- getsState $ getActorBody aid-  fact <- getsState $ (EM.! bfid b) . sfactionD-  allFoes <- getsState $ actorRegularAssocs (isAtWar fact) (blid b)-  let adjFoes = filter (adjacent (bpos b) . bpos . snd) allFoes-  mels <- mapM (pickWeaponClient aid . fst) adjFoes-      -- TODO: prioritize somehow-  let freq = uniformFreq "melee adjacent" $ catMaybes mels-  return $! liftFrequency freq---- TODO: take charging status into account--- TODO: make sure the stairs are specifically targetted and not--- an item on them, etc., so that we don't leave level if items visible.--- When invalidating target, make sure the stairs should really be taken.--- | The level the actor is on is either explored or the actor already--- has a weapon equipped, so no need to explore further, he tries to find--- enemies on other levels.--- We don't verify the stairs are targeted by the actor, but at least--- the actor doesn't target a visible enemy at this point.-trigger :: MonadClient m-        => ActorId -> Bool -> m (Strategy (RequestTimed 'AbTrigger))-trigger aid fleeViaStairs = do-  cops@Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops-  dungeon <- getsState sdungeon-  explored <- getsClient sexplored-  b <- getsState $ getActorBody aid-  activeItems <- activeItemsClient aid-  fact <- getsState $ (EM.! bfid b) . sfactionD-  let lid = blid b-  lvl <- getLevel lid-  unexploredD <- unexploredDepth-  s <- getState-  let lidExplored = ES.member lid explored-      allExplored = ES.size explored == EM.size dungeon-      t = lvl `at` bpos b-      feats = TK.tfeature $ okind t-      ben feat = case feat of-        TK.Cause (IK.Ascend k) -> do -- change levels sensibly, in teams-          (lid2, pos2) <- getsState $ whereTo lid (bpos b) k . sdungeon-          per <- getPerFid lid2-          let canSee = ES.member (bpos b) (totalVisible per)-              aimless = ftactic (gplayer fact) `elem` [TRoam, TPatrol]-              easier = signum k /= signum (fromEnum lid)-              unexpForth = unexploredD (signum k) lid-              unexpBack = unexploredD (- signum k) lid-              expBenefit-                | aimless = 100  -- faction is not exploring, so switch at will-                | unexpForth =-                    if easier  -- alway try as easy level as possible-                       || not unexpBack-                          && lidExplored -- no other choice for exploration-                    then 1000-                    else 0-                | not lidExplored = 0  -- fully explore current-                | unexpBack = 0  -- wait for stairs in the opposite direciton-                | not $ null $ lescape lvl = 0-                    -- all explored, stay on the escape level-                | otherwise = 2  -- no escape, switch levels occasionally-              actorsThere = posToActors pos2 lid2 s-          return $!-             if boldpos b == Just (bpos b)   -- probably used stairs last turn-                && boldlid b == lid2  -- in the opposite direction-             then 0  -- avoid trivial loops (pushing, being pushed, etc.)-             else let eben = case actorsThere of-                        [] | canSee -> expBenefit-                        _ -> min 1 expBenefit  -- risk pushing-                  in if fleeViaStairs-                     then 1000 * eben + 1  -- strongly prefer correct direction-                     else eben-        TK.Cause ef@IK.Escape{} -> return $  -- flee via this way, too-          -- Only some factions try to escape but they first explore all-          -- for high score.-          if not (fcanEscape $ gplayer fact) || not allExplored-          then 0-          else effectToBenefit cops b activeItems fact ef-        TK.Cause ef | not fleeViaStairs ->-          return $! effectToBenefit cops b activeItems fact ef-        _ -> return 0-  benFeats <- mapM ben feats-  let benFeat = zip benFeats feats-  return $! liftFrequency $ toFreq "trigger"-    [ (benefit, ReqTrigger (Just feat))-    | (benefit, feat) <- benFeat-    , benefit > 0 ]--projectItem :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbProject))-projectItem aid = do-  btarget <- getsClient $ getTarget aid-  b <- getsState $ getActorBody aid-  mfpos <- aidTgtToPos aid (blid b) btarget-  seps <- getsClient seps-  case (btarget, mfpos) of-    (_, Just fpos) | chessDist (bpos b) fpos == 1 -> return reject-    (Just TEnemy{}, Just fpos) -> do-      mnewEps <- makeLine False b fpos seps-      case mnewEps of-        Just newEps -> do-          actorSk <- actorSkillsClient aid-          let skill = EM.findWithDefault 0 AbProject actorSk-          -- ProjectAimOnself, ProjectBlockActor, ProjectBlockTerrain-          -- and no actors or obstracles along the path.-          let q _ itemFull b2 activeItems =-                either (const False) id-                $ permittedProject " " False skill itemFull b2 activeItems-          activeItems <- activeItemsClient aid-          let calmE = calmEnough b activeItems-              stores = [CEqp, CInv, CGround] ++ [CSha | calmE]-          benList <- benAvailableItems aid q stores-          localTime <- getsState $ getLocalTime (blid b)-          let coeff CGround = 2-              coeff COrgan = 3  -- can't give to others-              coeff CEqp = 100000  -- must hinder currently-              coeff CInv = 1-              coeff CSha = 1-              fRanged ( (mben, (_, cstore))-                      , (iid, itemFull@ItemFull{itemBase}) ) =-                -- We assume if the item has a timeout, most effects are under-                -- Recharging, so no point projecting if not recharged.-                -- This is not an obvious assumption, so recharging is not-                -- included in permittedProject and can be tweaked here easily.-                let recharged = hasCharge localTime itemFull-                    trange = totalRange itemBase-                    bestRange =-                      chessDist (bpos b) fpos + 2  -- margin for fleeing-                    rangeMult =  -- penalize wasted or unsafely low range-                      10 + max 0 (10 - abs (trange - bestRange))-                    durable = IK.Durable `elem` jfeature itemBase-                    durableBonus = if durable-                                   then 2  -- we or foes keep it after the throw-                                   else 1-                    benR = durableBonus-                           * coeff cstore-                           * case mben of-                               Nothing -> -1  -- experiment if no options-                               Just (_, ben) -> ben-                           * (if recharged then 1 else 0)-                in if -- Durable weapon is usually too useful for melee.-                      not (isMeleeEqp itemFull)-                      && benR < 0-                      && trange >= chessDist (bpos b) fpos-                   then Just ( -benR * rangeMult `div` 10-                             , ReqProject fpos newEps iid cstore )-                   else Nothing-              benRanged = mapMaybe fRanged benList-          return $! liftFrequency $ toFreq "projectItem" benRanged-        _ -> return reject-    _ -> return reject--data ApplyItemGroup = ApplyAll | ApplyFirstAid-  deriving Eq--applyItem :: MonadClient m-          => ActorId -> ApplyItemGroup -> m (Strategy (RequestTimed 'AbApply))-applyItem aid applyGroup = do-  actorSk <- actorSkillsClient aid-  b <- getsState $ getActorBody aid-  localTime <- getsState $ getLocalTime (blid b)-  let skill = EM.findWithDefault 0 AbApply actorSk-      q _ itemFull _ activeItems =-        -- TODO: terrible hack to prevent the use of identified healing gems-        let freq = case itemDisco itemFull of-              Nothing -> []-              Just ItemDisco{itemKind} -> IK.ifreq itemKind-        in maybe True (<= 0) (lookup "gem" freq)-           && either (const False) id-                (permittedApply " " localTime skill itemFull b activeItems)-  activeItems <- activeItemsClient aid-  let calmE = calmEnough b activeItems-      stores = [CEqp, CInv, CGround] ++ [CSha | calmE]-  benList <- benAvailableItems aid q stores-  organs <- mapM (getsState . getItemBody) $ EM.keys $ borgan b-  let itemLegal itemFull = case applyGroup of-        ApplyFirstAid ->-          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}} ->-              foldr getP False jeffects-            _ -> False-        ApplyAll -> True-      coeff CGround = 2-      coeff COrgan = 3  -- can't give to others-      coeff CEqp = 100000  -- must hinder currently-      coeff CInv = 1-      coeff CSha = 1-      fTool ((mben, (_, cstore)), (iid, itemFull@ItemFull{itemBase})) =-        let durableBonus = if IK.Durable `elem` jfeature itemBase-                           then 5  -- we keep it after use-                           else 1-            oldGrps = map (toGroupName . jname) organs-            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 (newGrps `intersect` oldGrps)-            benR = case mben of-                     Nothing -> 0-                       -- experimenting is fun, but it's better to risk-                       -- foes' skin than ours -- TODO: when {applied}-                       -- is implemented, enable this for items too heavy,-                       -- etc. for throwing-                     Just (_, ben) -> ben-                   * (if not createOrganAgain then 1 else 0)-                   * (if not dropOrganVoid then 1 else 0)-                   * durableBonus-                   * coeff cstore-        in if itemLegal itemFull && benR > 0-           then Just (benR, ReqApply iid cstore)-           else Nothing-      benTool = mapMaybe fTool benList-  return $! liftFrequency $ toFreq "applyItem" benTool---- If low on health or alone, flee in panic, close to the path to target--- and as far from the attackers, as possible. Usually fleeing from--- foes will lead towards friends, but we don't insist on that.--- We use chess distances, not pathfinding, because melee can happen--- at path distance 2.-flee :: MonadClient m-     => ActorId -> [(Int, Point)] -> m (Strategy RequestAnyAbility)-flee aid fleeL = do-  b <- getsState $ getActorBody aid-  let vVic = map (second (`vectorToFrom` bpos b)) fleeL-      str = liftFrequency $ toFreq "flee" vVic-  mapStrategyM (moveOrRunAid True aid) str--displaceFoe :: MonadClient m => ActorId -> m (Strategy RequestAnyAbility)-displaceFoe aid = do-  cops <- getsState scops-  b <- getsState $ getActorBody aid-  lvl <- getLevel $ blid b-  fact <- getsState $ (EM.! bfid b) . sfactionD-  let friendlyFid fid = fid == bfid b || isAllied fact fid-  friends <- getsState $ actorRegularList friendlyFid (blid b)-  allFoes <- getsState $ actorRegularAssocs (isAtWar fact) (blid b)-  let accessibleHere = accessible cops lvl $ bpos b-      displaceable body =  -- DisplaceAccess-        adjacent (bpos body) (bpos b) && accessibleHere (bpos body)-      nFriends body = length $ filter (adjacent (bpos body) . bpos) friends-      nFrHere = nFriends b + 1-      qualifyActor (aid2, body2) = do-        activeItems <- activeItemsClient aid2-        dEnemy <- getsState $ dispEnemy aid aid2 activeItems-          -- DisplaceDying, DisplaceBraced, DisplaceImmobile, DisplaceSupported-        let nFr = nFriends body2-        return $! if displaceable body2 && dEnemy && nFr < nFrHere-          then Just (nFr * nFr, bpos body2 `vectorToFrom` bpos b)-          else Nothing-  vFoes <- mapM qualifyActor allFoes-  let str = liftFrequency $ toFreq "displaceFoe" $ catMaybes vFoes-  mapStrategyM (moveOrRunAid True aid) str--displaceBlocker :: MonadClient m => ActorId -> m (Strategy RequestAnyAbility)-displaceBlocker aid = do-  mtgtMPath <- getsClient $ EM.lookup aid . stargetD-  str <- case mtgtMPath of-    Just (_, Just (p : q : _, _)) -> displaceTowards aid p q-    _ -> return reject  -- goal reached-  mapStrategyM (moveOrRunAid True aid) str---- TODO: perhaps modify target when actually moving, not when--- producing the strategy, even if it's a unique choice in this case.-displaceTowards :: MonadClient m-                => ActorId -> Point -> Point -> m (Strategy Vector)-displaceTowards aid source target = do-  cops <- getsState scops-  b <- getsState $ getActorBody aid-  let !_A = assert (source == bpos b && adjacent source target) ()-  lvl <- getLevel $ blid b-  if boldpos b /= Just target -- avoid trivial loops-     && accessible cops lvl source target then do  -- DisplaceAccess-    mleader <- getsClient _sleader-    mBlocker <- getsState $ posToActors target (blid b)-    case mBlocker of-      [] -> return reject-      [(aid2, b2)] | Just aid2 /= mleader -> do-        mtgtMPath <- getsClient $ EM.lookup aid2 . stargetD-        case mtgtMPath of-          Just (tgt, Just (p : q : rest, (goal, len)))-            | q == source && p == target-              || waitedLastTurn b2 -> do-              let newTgt = if q == source && p == target-                           then Just (tgt, Just (q : rest, (goal, len - 1)))-                           else Nothing-              modifyClient $ \cli ->-                cli {stargetD = EM.alter (const newTgt) aid (stargetD cli)}-              return $! returN "displace friend" $ target `vectorToFrom` source-          Just _ -> return reject-          Nothing -> do-            tfact <- getsState $ (EM.! bfid b2) . sfactionD-            activeItems <- activeItemsClient aid2-            dEnemy <- getsState $ dispEnemy aid aid2 activeItems-            if not (isAtWar tfact (bfid b)) || dEnemy then-              return $! returN "displace other" $ target `vectorToFrom` source-            else return reject  -- DisplaceDying, etc.-      _ -> return reject  -- DisplaceProjectiles or trying to displace leader-  else return reject--chase :: MonadClient m-      => ActorId -> Bool -> Bool -> m (Strategy RequestAnyAbility)-chase aid doDisplace avoidAmbient = do-  Kind.COps{cotile} <- getsState scops-  body <- getsState $ getActorBody aid-  fact <- getsState $ (EM.! bfid body) . sfactionD-  mtgtMPath <- getsClient $ EM.lookup aid . stargetD-  lvl <- getLevel $ blid body-  let isAmbient pos = Tile.isLit cotile (lvl `at` pos)-  str <- case mtgtMPath of-    Just (_, Just (p : q : _, (goal, _))) | not $ avoidAmbient && isAmbient q ->-      -- With no leader, the goal is vague, so permit arbitrary detours.-      moveTowards aid p q goal (fleaderMode (gplayer fact) == LeaderNull)-    _ -> return reject  -- goal reached-  -- If @doDisplace@: don't pick fights, assuming the target is more important.-  -- We'd normally melee the target earlier on via @AbMelee@, but for-  -- actors that don't have this ability (and so melee only when forced to),-  -- this is meaningul.-  mapStrategyM (moveOrRunAid doDisplace aid) str---- TODO: rename source here and elsewhere, it's always an ActorId in the code-moveTowards :: MonadClient m-            => ActorId -> Point -> Point -> Point -> Bool -> m (Strategy Vector)-moveTowards aid source target goal relaxed = do-  cops@Kind.COps{cotile} <- getsState scops-  b <- getsState $ getActorBody aid-  actorSk <- actorSkillsClient aid-  let alterSkill = EM.findWithDefault 0 AbAlter actorSk-      !_A = assert (source == bpos b-                    `blame` (source, bpos b, aid, b, goal)) ()-      !_B = assert (adjacent source target-                    `blame` (source, target, aid, b, goal)) ()-  lvl <- getLevel $ blid b-  fact <- getsState $ (EM.! bfid b) . sfactionD-  friends <- getsState $ actorList (not . isAtWar fact) $ blid b-  let noFriends = unoccupied friends-      accessibleHere = accessible cops lvl source-      -- Only actors with AbAlter can search for hidden doors, etc.-      bumpableHere p =-        let t = lvl `at` p-        in alterSkill >= 1-           && (Tile.isOpenable cotile t-               || Tile.isSuspect cotile t-               || Tile.isChangeable cotile t)-      enterableHere p = accessibleHere p || bumpableHere p-  if noFriends target && enterableHere target then-    return $! returN "moveTowards adjacent" $ target `vectorToFrom` source-  else do-    let goesBack v = maybe False (\oldpos -> v == oldpos `vectorToFrom` source)-                           (boldpos b)-        nonincreasing p = chessDist source goal >= chessDist p goal-        isSensible p = (relaxed || nonincreasing p)-                       && noFriends p-                       && enterableHere p-        sensible = [ ((goesBack v, chessDist p goal), v)-                   | v <- moves, let p = source `shift` v, isSensible p ]-        sorted = sortBy (comparing fst) sensible-        groups = map (map snd) $ groupBy ((==) `on` fst) sorted-        freqs = map (liftFrequency . uniformFreq "moveTowards") groups-    return $! foldr (.|) reject freqs---- | Actor moves or searches or alters or attacks. Displaces if @run@.--- This function is very general, even though it's often used in contexts--- when only one or two of the many cases can possibly occur.-moveOrRunAid :: MonadClient m-             => Bool -> ActorId -> Vector -> m (Maybe RequestAnyAbility)-moveOrRunAid run source dir = do-  cops@Kind.COps{cotile} <- getsState scops-  sb <- getsState $ getActorBody source-  actorSk <- actorSkillsClient source-  let lid = blid sb-  lvl <- getLevel lid-  let skill = EM.findWithDefault 0 AbAlter actorSk-      spos = bpos sb           -- source position-      tpos = spos `shift` dir  -- target position-      t = lvl `at` tpos-  -- We start by checking actors at the the target position,-  -- which gives a partial information (actors can be invisible),-  -- as opposed to accessibility (and items) which are always accurate-  -- (tiles can't be invisible).-  tgts <- getsState $ posToActors tpos lid-  case tgts of-    [(target, b2)] | run -> do-      -- @target@ can be a foe, as well as a friend.-      tfact <- getsState $ (EM.! bfid b2) . sfactionD-      activeItems <- activeItemsClient target-      dEnemy <- getsState $ dispEnemy source target activeItems-      if boldpos sb == Just tpos && not (waitedLastTurn sb)-           -- avoid Displace loops-         || not (accessible cops lvl spos tpos) -- DisplaceAccess-      then return Nothing-      else if isAtWar tfact (bfid sb) && not dEnemy  -- DisplaceDying, etc.-      then do-        wps <- pickWeaponClient source target-        case wps of-          Nothing -> return Nothing-          Just wp -> return $! Just $ RequestAnyAbility wp-      else return $! Just $ RequestAnyAbility $ ReqDisplace target-    (target, _) : _ -> do  -- can be a foe, as well as friend (e.g., proj.)-      -- No problem if there are many projectiles at the spot. We just-      -- attack the first one.-      -- Attacking does not require full access, adjacency is enough.-      wps <- pickWeaponClient source target-      case wps of-        Nothing -> return Nothing-        Just wp -> return $! Just $ RequestAnyAbility wp-    [] -- move or search or alter-       | accessible cops lvl spos tpos ->-         -- Movement requires full access.-         return $! Just $ RequestAnyAbility $ ReqMove dir-         -- The potential invisible actor is hit.-       | skill < 1 ->-         assert `failure` "AI causes  AlterUnskilled" `twith` (run, source, dir)-       | EM.member tpos $ lfloor lvl ->-         -- This could be, e.g., inaccessible open door with an item in it,-         -- but for this case to happen, it would also need to be unwalkable.-         assert `failure` "AI causes AlterBlockItem" `twith` (run, source, dir)-       | not (Tile.isWalkable cotile t)  -- not implied-              && (Tile.isSuspect cotile t-                  || Tile.isOpenable cotile t-                  || Tile.isClosable cotile t-                  || Tile.isChangeable cotile t) ->-         -- No access, so search and/or alter the tile.-         return $! Just $ RequestAnyAbility $ ReqAlter tpos Nothing-       | otherwise ->-         -- Boring tile, no point bumping into it, do WaitSer if really idle.-         assert `failure` "AI causes MoveNothing or AlterNothing"-                `twith` (run, source, dir)

+ Game/LambdaHack/Client/AI/HandleAbilityM.hs view

@@ -0,0 +1,971 @@+{-# LANGUAGE DataKinds #-}+-- | Semantics of abilities in terms of actions and the AI procedure+-- for picking the best action for an actor.+module Game.LambdaHack.Client.AI.HandleAbilityM+  ( actionStrategy+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , waitBlockNow, pickup, equipItems, toShare, yieldUnneeded, unEquipItems+  , groupByEqpSlot, bestByEqpSlot, harmful, meleeBlocker, meleeAny+  , trigger, projectItem, applyItem, flee+  , displaceFoe, displaceBlocker, displaceTowards+  , chase, moveTowards, moveOrRunAid+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import Data.Function+import Data.Ord+import Data.Ratio++import Game.LambdaHack.Client.AI.ConditionM+import Game.LambdaHack.Client.AI.Strategy+import Game.LambdaHack.Client.Bfs+import Game.LambdaHack.Client.BfsM+import Game.LambdaHack.Client.CommonM+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Common.Ability+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Frequency+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.ItemStrongest+import 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 qualified Game.LambdaHack.Common.PointArray as PointArray+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Vector+import qualified Game.LambdaHack.Content.ItemKind as IK+import Game.LambdaHack.Content.ModeKind++type ToAny a = Strategy (RequestTimed a) -> Strategy RequestAnyAbility++toAny :: ToAny a+toAny strat = RequestAnyAbility <$> strat++-- | AI strategy based on actor's sight, smell, etc.+-- Never empty.+actionStrategy :: forall m. MonadClient m+               => ActorId -> Bool -> m (Strategy RequestAnyAbility)+{-# INLINE actionStrategy #-}+actionStrategy aid retry = do+  body <- getsState $ getActorBody aid+  scondInMelee <- getsClient scondInMelee+  let condInMelee = fromMaybe (assert `failure` condInMelee)+                              (scondInMelee EM.! blid body)+  condAimEnemyPresent <- condAimEnemyPresentM aid+  condAimEnemyRemembered <- condAimEnemyRememberedM aid+  condAnyFoeAdj <- condAnyFoeAdjM aid+  threatDistL <- meleeThreatDistList aid+  (fleeL, badVic) <- fleeList aid+  condSupport1 <- condSupport 1 aid+  condSupport2 <- condSupport 2 aid+  canDeAmbientL <- getsState $ canDeAmbientList body+  actorSk <- currentSkillsClient aid+  condCanProject <-+    condCanProjectM (EM.findWithDefault 0 AbProject actorSk) aid+  condAdjTriggerable <- condAdjTriggerableM aid+  condBlocksFriends <- condBlocksFriendsM aid+  condNoEqpWeapon <- condNoEqpWeaponM aid+  condEnoughGear <- condEnoughGearM aid+  condFloorWeapon <- condFloorWeaponM aid+  condDesirableFloorItem <- condDesirableFloorItemM aid+  condTgtNonmoving <- condTgtNonmovingM aid+  explored <- getsClient sexplored+  actorAspect <- getsClient sactorAspect+  let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect)+      lidExplored = ES.member (blid body) explored+      panicFleeL = fleeL ++ badVic+      condHpTooLow = hpTooLow body ar+      condNotCalmEnough = not (calmEnough body ar)+      speed1_5 = speedScale (3%2) (bspeed body ar)+      condCanMelee = actorCanMelee actorAspect aid body+      condMeleeBad1 = not (condSupport1 && condCanMelee)+      condMeleeBad2 = not (condSupport2 && condCanMelee)+      condThreat n = not $ null $ takeWhile ((<= n) . fst) threatDistL+      threatAdj = takeWhile ((== 1) . fst) threatDistL+      condManyThreatAdj = length threatAdj >= 2+      condFastThreatAdj =+        any (\(_, (aid2, b2)) ->+              let ar2 = actorAspect EM.! aid2+              in bspeed b2 ar2 > speed1_5)+        threatAdj+      heavilyDistressed =  -- actor hit by a proj or similarly distressed+        deltaSerious (bcalmDelta body)+      actorShines = aShine ar > 0+      aCanDeLightL | actorShines = []+                   | otherwise = canDeAmbientL+      aCanDeLight = not $ null aCanDeLightL+      canFleeFromLight = not $ null $ aCanDeLightL `intersect` map snd fleeL+      actorMaxSk = aSkills ar+      abInMaxSkill ab = EM.findWithDefault 0 ab actorMaxSk > 0+      stratToFreq :: Int -> m (Strategy RequestAnyAbility)+                  -> m (Frequency RequestAnyAbility)+      stratToFreq scale mstrat = do+        st <- mstrat+        return $! if scale == 0+                  then mzero+                  else scaleFreq scale $ bestVariant st+      -- Order matters within the list, because it's summed with .| after+      -- filtering. Also, the results of prefix, distant and suffix+      -- are summed with .| at the end.+      prefix, suffix :: [([Ability], m (Strategy RequestAnyAbility), Bool)]+      prefix =+        [ ( [AbApply], (toAny :: ToAny 'AbApply)+            <$> applyItem aid ApplyFirstAid+          , not condAnyFoeAdj && condHpTooLow)+        , ( [AbAlter], (toAny :: ToAny 'AbAlter)+            <$> trigger aid ViaStairs+              -- explore next or flee via stairs, even if to wrong level;+              -- in the latter case, may return via different stairs later on+          , condAdjTriggerable && not condAimEnemyPresent+            && ((condNotCalmEnough || condHpTooLow)  -- flee+                && condMeleeBad2 && condThreat 1+                || (lidExplored || condEnoughGear)  -- explore+                   && not condDesirableFloorItem) )+        , ( [AbDisplace]+          , displaceFoe aid  -- only swap with an enemy to expose him+          , condAnyFoeAdj && condBlocksFriends)  -- later checks foe eligible+        , ( [AbMoveItem], (toAny :: ToAny 'AbMoveItem)+            <$> pickup aid True+          , condNoEqpWeapon  -- we assume organ weapons usually inferior+            && condFloorWeapon && not condHpTooLow+            && abInMaxSkill AbMelee )+        , ( [AbAlter], (toAny :: ToAny 'AbAlter)+            <$> trigger aid ViaEscape+          , condAdjTriggerable && not condAimEnemyPresent+            && not condDesirableFloorItem )  -- collect the last loot+        , ( [AbMove]+          , flee aid fleeL+          , -- Flee either from melee, if our melee is bad and enemy close+            -- or from missiles, if hit and enemies are only far away,+            -- can fling at us and we can't well fling at them.+            not condFastThreatAdj+            && if | condThreat 1 -> not condCanMelee+                                    || condManyThreatAdj && not condSupport1+                  | not condInMelee+                    && (condThreat 2 || condThreat 5 && canFleeFromLight) ->+                    -- Don't keep fleeing if just hit, because too close+                    -- to enemy to get out of his range, most likely,+                    -- and so melee him instead, unless can't melee at all.+                    not condCanMelee+                    || not condSupport2 && not heavilyDistressed+                  | condThreat 5 ->+                    -- Too far to flee from melee, too close from ranged,+                    -- not in ambient, so no point fleeing into dark; advance.+                    False+                  | otherwise ->+                    -- If I'm hit, they are still in range to fling at me,+                    -- even if I can't see them. And probably far away.+                    -- Too far to close in for melee; can't shoot; flee from+                    -- ranged attack and prepare ambush for later on.+                    not condInMelee+                    && heavilyDistressed+                    && (not condCanProject || canFleeFromLight) )+        , ( [AbMelee], (toAny :: ToAny 'AbMelee)+            <$> meleeBlocker aid  -- only melee blocker+          , condAnyFoeAdj  -- if foes, don't displace, otherwise friends:+            || not (abInMaxSkill AbDisplace)  -- displace friends, if possible+               && condAimEnemyPresent )  -- excited+                    -- So animals block each other until hero comes and then+                    -- the stronger makes a show for him and kills the weaker.+        , ( [AbAlter], (toAny :: ToAny 'AbAlter)+            <$> trigger aid ViaNothing+          , not condInMelee  -- don't incur overhead+            && condAdjTriggerable && not condAimEnemyPresent )+        , ( [AbDisplace]  -- prevents some looping movement+          , displaceBlocker aid retry  -- fires up only when path blocked+          , retry || not condDesirableFloorItem )+        , ( [AbMelee], (toAny :: ToAny 'AbMelee)+            <$> meleeAny aid+          , condAnyFoeAdj )  -- won't flee nor displace, so let it melee+        , ( [AbMove]+          , flee aid panicFleeL  -- ultimate panic mode, displaces foes+          , condAnyFoeAdj )+        ]+      -- Order doesn't matter, scaling does.+      -- These are flattened (taking only the best variant) and then summed,+      -- so if any of these can fire, it will fire. If none, @suffix@ is tried.+      -- Only the best variant of @chase@ is taken, but it's almost always+      -- good, and if not, the @chase@ in @suffix@ may fix that.+      distant :: [([Ability], m (Frequency RequestAnyAbility), Bool)]+      distant =+        [ ( [AbMoveItem]+          , stratToFreq (if condInMelee then 2 else 20000)+            $ (toAny :: ToAny 'AbMoveItem)+            <$> yieldUnneeded aid  -- 20000 to unequip ASAP, unless is thrown+          , True )+        , ( [AbMoveItem]+          , stratToFreq 1 $ (toAny :: ToAny 'AbMoveItem)+            <$> equipItems aid  -- doesn't take long, very useful if safe+          , not (condInMelee+                 || condDesirableFloorItem+                 || condNotCalmEnough+                 || heavilyDistressed) )+        , ( [AbProject]+          , stratToFreq (if condTgtNonmoving then 20 else 3)+              -- not too common, to leave missiles for pre-melee dance+            $ (toAny :: ToAny 'AbProject)+            <$> projectItem aid  -- equivalent of @condCanProject@ called inside+          , condAimEnemyPresent && not condInMelee )+        , ( [AbApply]+          , stratToFreq 1 $ (toAny :: ToAny 'AbApply)+            <$> applyItem aid ApplyAll  -- use any potion or scroll+          , condAimEnemyPresent || condThreat 9 )  -- can affect enemies+        , ( [AbMove]+          , stratToFreq (if | condInMelee ->+                              400  -- friends pummeled by target, go to help+                            | not condAimEnemyPresent ->+                              2  -- if enemy only remembered, investigate anyway+                            | otherwise ->+                              20)+            $ chase aid (not condInMelee+                         && (condThreat 12 || heavilyDistressed)+                         && aCanDeLight) retry+          , condCanMelee+            && (if condInMelee then condAimEnemyPresent+                else (condAimEnemyPresent || condAimEnemyRemembered)+                     && (not (condThreat 2)+                         || heavilyDistressed  -- if under fire, do something!+                         || not condMeleeBad1)+                       -- this results in animals in corridor never attacking+                       -- (unless distressed by, e.g., being hit by missiles),+                       -- because they can't swarm opponent, which is logical,+                       -- and in rooms they do attack, so not too boring;+                       -- two aliens attack always, because more aggressive+                     && not condDesirableFloorItem) )+        ]+      -- Order matters again.+      suffix =+        [ ( [AbMoveItem], (toAny :: ToAny 'AbMoveItem)+            <$> pickup aid False  -- e.g., to give to other party members+          , not condInMelee )+        , ( [AbMoveItem], (toAny :: ToAny 'AbMoveItem)+            <$> unEquipItems aid  -- late, because these items not bad+          , not condInMelee )+        , ( [AbMove]+          , chase aid (not condInMelee+                       && heavilyDistressed+                       && aCanDeLight) retry+          , if condInMelee then condCanMelee && condAimEnemyPresent+            else not (condThreat 2) || not condMeleeBad1 )+        ]+      fallback =+        [ ( [AbWait], (toAny :: ToAny 'AbWait)+            <$> waitBlockNow+            -- Wait until friends sidestep; ensures strategy is never empty.+          , True )+        ]+  -- Check current, not maximal skills, since this can be a leader as well+  -- as non-leader action.+  let abInSkill ab = EM.findWithDefault 0 ab actorSk > 0+      checkAction :: ([Ability], m a, Bool) -> Bool+      checkAction (abts, _, cond) = all abInSkill abts && cond+      sumS abAction = do+        let as = filter checkAction abAction+        strats <- mapM (\(_, m, _) -> m) as+        return $! msum strats+      sumF abFreq = do+        let as = filter checkAction abFreq+        strats <- mapM (\(_, m, _) -> m) as+        return $! msum strats+      combineDistant as = liftFrequency <$> sumF as+  sumPrefix <- sumS prefix+  comDistant <- combineDistant distant+  sumSuffix <- sumS suffix+  sumFallback <- sumS fallback+  return $! sumPrefix .| comDistant .| sumSuffix .| sumFallback++-- | A strategy to always just wait.+waitBlockNow :: MonadClient m => m (Strategy (RequestTimed 'AbWait))+waitBlockNow = return $! returN "wait" ReqWait++pickup :: MonadClient m+       => ActorId -> Bool -> m (Strategy (RequestTimed 'AbMoveItem))+pickup aid onlyWeapon = do+  benItemL <- benGroundItems aid+  b <- getsState $ getActorBody aid+  -- This calmE is outdated when one of the items increases max Calm+  -- (e.g., in pickup, which handles many items at once), but this is OK,+  -- the server accepts item movement based on calm at the start, not end+  -- or in the middle.+  -- The calmE is inaccurate also if an item not IDed, but that's intended+  -- and the server will ignore and warn (and content may avoid that,+  -- e.g., making all rings identified)+  actorAspect <- getsClient sactorAspect+  let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect)+      calmE = calmEnough b ar+      isWeapon (_, _, _, itemFull) = isMelee $ itemBase itemFull+      filterWeapon | onlyWeapon = filter isWeapon+                   | otherwise = id+      prepareOne (oldN, l4) (mben, _, iid, ItemFull{..}) =+        let prep newN toCStore = (newN, (iid, itemK, CGround, toCStore) : l4)+            inEqp = maybe (goesIntoEqp itemBase) benInEqp mben+            n = oldN + itemK+        in if | calmE && goesIntoSha itemBase && not onlyWeapon ->+                prep oldN CSha+              | inEqp && eqpOverfull b n ->+                if onlyWeapon then (oldN, l4)+                else prep oldN (if calmE then CSha else CInv)+              | inEqp ->+                prep n CEqp+              | not onlyWeapon ->+                prep oldN CInv+              | otherwise -> (oldN, l4)+      (_, prepared) = foldl' prepareOne (0, []) $ filterWeapon benItemL+  return $! if null prepared then reject+            else returN "pickup" $ ReqMoveItems prepared++-- This only concerns items that can be equipped, that is with a slot+-- and with @inEqp@ (which implies @goesIntoEqp@).+-- Such items are moved between any stores, as needed. In this case,+-- from inv or sha to eqp.+equipItems :: MonadClient m+           => ActorId -> m (Strategy (RequestTimed 'AbMoveItem))+equipItems aid = do+  body <- getsState $ getActorBody aid+  actorAspect <- getsClient sactorAspect+  let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect)+      calmE = calmEnough body ar+  eqpAssocs <- fullAssocsClient aid [CEqp]+  invAssocs <- fullAssocsClient aid [CInv]+  shaAssocs <- fullAssocsClient aid [CSha]+  condShineWouldBetray <- condShineWouldBetrayM aid+  condAimEnemyPresent <- condAimEnemyPresentM aid+  discoBenefit <- getsClient sdiscoBenefit+  let improve :: CStore+              -> (Int, [(ItemId, Int, CStore, CStore)])+              -> ( IK.EqpSlot+                 , ( [(Int, (ItemId, ItemFull))]+                   , [(Int, (ItemId, ItemFull))] ) )+              -> (Int, [(ItemId, Int, CStore, CStore)])+      improve fromCStore (oldN, l4) (slot, (bestInv, bestEqp)) =+        let n = 1 + oldN+        in case (bestInv, bestEqp) of+          ((_, (iidInv, _)) : _, []) | not (eqpOverfull body n) ->+            (n, (iidInv, 1, fromCStore, CEqp) : l4)+          ((vInv, (iidInv, _)) : _, (vEqp, _) : _)+            | not (eqpOverfull body n)+              && (vInv > vEqp || not (toShare slot)) ->+                (n, (iidInv, 1, fromCStore, CEqp) : l4)+          _ -> (oldN, l4)+      heavilyDistressed =  -- Actor hit by a projectile or similarly distressed.+        deltaSerious (bcalmDelta body)+      -- We filter out unneeded items. In particular, we ignore them in eqp+      -- when comparing to items we may want to equip, so that the unneeded+      -- but powerful items don't fool us.+      -- In any case, the unneeded items should be removed from equip+      -- in @yieldUnneeded@ earlier or soon after this check.+      -- In other stores we need to filter, for otherwise we'd have+      -- a loop of equip/yield.+      filterNeeded (_, itemFull) =+        not $ hinders condShineWouldBetray condAimEnemyPresent+                      heavilyDistressed (not calmE) body ar itemFull+      bestThree = bestByEqpSlot discoBenefit+                                (filter filterNeeded eqpAssocs)+                                (filter filterNeeded invAssocs)+                                (filter filterNeeded shaAssocs)+      bEqpInv = foldl' (improve CInv) (0, [])+                $ map (\(slot, (eqp, inv, _)) ->+                        (slot, (inv, eqp))) bestThree+      bEqpBoth | calmE =+                   foldl' (improve CSha) bEqpInv+                   $ map (\(slot, (eqp, _, sha)) ->+                           (slot, (sha, eqp))) bestThree+               | otherwise = bEqpInv+      (_, prepared) = bEqpBoth+  return $! if null prepared+            then reject+            else returN "equipItems" $ ReqMoveItems prepared++toShare :: IK.EqpSlot -> Bool+toShare IK.EqpSlotMiscBonus = False+toShare IK.EqpSlotMiscAbility = False+toShare _ = True++yieldUnneeded :: MonadClient m+              => ActorId -> m (Strategy (RequestTimed 'AbMoveItem))+yieldUnneeded aid = do+  body <- getsState $ getActorBody aid+  actorAspect <- getsClient sactorAspect+  let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect)+      calmE = calmEnough body ar+  eqpAssocs <- fullAssocsClient aid [CEqp]+  condShineWouldBetray <- condShineWouldBetrayM aid+  condAimEnemyPresent <- condAimEnemyPresentM aid+  discoBenefit <- getsClient sdiscoBenefit+  -- Here and in @unEquipItems@ AI may hide from the human player,+  -- in shared stash, the Ring of Speed And Bleeding,+  -- which is a bit harsh, but fair. However any subsequent such+  -- rings will not be picked up at all, so the human player+  -- doesn't lose much fun. Additionally, if AI learns alchemy later on,+  -- they can repair the ring, wield it, drop at death and it's+  -- in play again.+  let heavilyDistressed =  -- Actor hit by a projectile or similarly distressed.+        deltaSerious (bcalmDelta body)+      csha = if calmE then CSha else CInv+      yieldSingleUnneeded (iidEqp, itemEqp) =+        if | harmful discoBenefit iidEqp ->+             [(iidEqp, itemK itemEqp, CEqp, CInv)]  -- harmful not shared+           | hinders condShineWouldBetray condAimEnemyPresent+                     heavilyDistressed (not calmE)+                     body ar itemEqp ->+             [(iidEqp, itemK itemEqp, CEqp, csha)]+           | otherwise -> []+      yieldAllUnneeded = concatMap yieldSingleUnneeded eqpAssocs+  return $! if null yieldAllUnneeded+            then reject+            else returN "yieldUnneeded" $ ReqMoveItems yieldAllUnneeded++-- This only concerns items that can be equipped, that is with a slot+-- and with @inEqp@ (which implies @goesIntoEqp@).+-- Such items are moved between any stores, as needed. In this case,+-- from inv or eqp to sha.+unEquipItems :: MonadClient m+             => ActorId -> m (Strategy (RequestTimed 'AbMoveItem))+unEquipItems aid = do+  body <- getsState $ getActorBody aid+  actorAspect <- getsClient sactorAspect+  let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect)+      calmE = calmEnough body ar+  eqpAssocs <- fullAssocsClient aid [CEqp]+  invAssocs <- fullAssocsClient aid [CInv]+  shaAssocs <- fullAssocsClient aid [CSha]+  discoBenefit <- getsClient sdiscoBenefit+  let improve :: CStore -> ( IK.EqpSlot+                           , ( [(Int, (ItemId, ItemFull))]+                             , [(Int, (ItemId, ItemFull))] ) )+              -> [(ItemId, Int, CStore, CStore)]+      improve fromCStore (slot, (bestSha, bestEOrI)) =+        case (bestSha, bestEOrI) of+          _ | not (toShare slot)+              && fromCStore == CEqp+              && not (eqpOverfull body 1) ->  -- keep minor boosts up to M-1+            []+          (_, (vEOrI, (iidEOrI, _)) : _) | (toShare slot || fromCStore == CInv)+                                           && getK bestEOrI > 1+                                           && betterThanSha vEOrI bestSha ->+            -- To share the best items with others, if they care.+            [(iidEOrI, getK bestEOrI - 1, fromCStore, CSha)]+          (_, _ : (vEOrI, (iidEOrI, _)) : _) | (toShare slot+                                                || fromCStore == CInv)+                                               && betterThanSha vEOrI bestSha ->+            -- To share the second best items with others, if they care.+            [(iidEOrI, getK bestEOrI, fromCStore, CSha)]+          (_, (vEOrI, (_, _)) : _) | fromCStore == CEqp+                                     && eqpOverfull body 1+                                     && worseThanSha vEOrI bestSha ->+            -- To make place in eqp for an item better than any ours.+            [(fst $ snd $ last bestEOrI, 1, fromCStore, CSha)]+          _ -> []+      getK [] = 0+      getK ((_, (_, itemFull)) : _) = itemK itemFull+      betterThanSha _ [] = True+      betterThanSha vEOrI ((vSha, _) : _) = vEOrI > vSha+      worseThanSha _ [] = False+      worseThanSha vEOrI ((vSha, _) : _) = vEOrI < vSha+      -- Here we don't need to filter out items that hinder, because+      -- they are moved to sha and will be equipped by another actor+      -- at another time, where hindering will be completely different.+      bestThree = bestByEqpSlot discoBenefit eqpAssocs invAssocs shaAssocs+      bInvSha = concatMap+                  (improve CInv . (\(slot, (_, inv, sha)) ->+                                    (slot, (sha, inv)))) bestThree+      bEqpSha = concatMap+                  (improve CEqp . (\(slot, (eqp, _, sha)) ->+                                    (slot, (sha, eqp)))) bestThree+      prepared = if calmE then bInvSha ++ bEqpSha else []+  return $! if null prepared+            then reject+            else returN "unEquipItems" $ ReqMoveItems prepared++groupByEqpSlot :: [(ItemId, ItemFull)]+               -> EM.EnumMap IK.EqpSlot [(ItemId, ItemFull)]+groupByEqpSlot is =+  let f (iid, itemFull) = case strengthEqpSlot itemFull of+        Nothing -> Nothing+        Just es -> Just (es, [(iid, itemFull)])+      withES = mapMaybe f is+  in EM.fromListWith (++) withES++bestByEqpSlot :: DiscoveryBenefit+              -> [(ItemId, ItemFull)]+              -> [(ItemId, ItemFull)]+              -> [(ItemId, ItemFull)]+              -> [(IK.EqpSlot+                  , ( [(Int, (ItemId, ItemFull))]+                    , [(Int, (ItemId, ItemFull))]+                    , [(Int, (ItemId, ItemFull))] ) )]+bestByEqpSlot discoBenefit eqpAssocs invAssocs shaAssocs =+  let eqpMap = EM.map (\g -> (g, [], [])) $ groupByEqpSlot eqpAssocs+      invMap = EM.map (\g -> ([], g, [])) $ groupByEqpSlot invAssocs+      shaMap = EM.map (\g -> ([], [], g)) $ groupByEqpSlot shaAssocs+      appendThree (g1, g2, g3) (h1, h2, h3) = (g1 ++ h1, g2 ++ h2, g3 ++ h3)+      eqpInvShaMap = EM.unionsWith appendThree [eqpMap, invMap, shaMap]+      bestSingle = strongestSlot discoBenefit+      bestThree eqpSlot (g1, g2, g3) = (bestSingle eqpSlot g1,+                                        bestSingle eqpSlot g2,+                                        bestSingle eqpSlot g3)+  in EM.assocs $ EM.mapWithKey bestThree eqpInvShaMap++harmful :: DiscoveryBenefit -> ItemId -> Bool+harmful discoBenefit iid =+  -- Items that are known, perhaps recently discovered, and it's now revealed+  -- they should not be kept in equipment, should be unequipped+  -- (either they are harmful or they waste eqp space).+  maybe False (not . benInEqp) (EM.lookup iid discoBenefit)++-- Everybody melees in a pinch, even though some prefer ranged attacks.+meleeBlocker :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbMelee))+meleeBlocker aid = do+  b <- getsState $ getActorBody aid+  actorAspect <- getsClient sactorAspect+  let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect)+  fact <- getsState $ (EM.! bfid b) . sfactionD+  actorSk <- currentSkillsClient aid+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  case mtgtMPath of+    Just TgtAndPath{ tapTgt=TEnemy{}+                   , tapPath=AndPath{pathList=q : _, pathGoal} }+      | q == pathGoal -> return reject  -- not a real blocker, but goal enemy+    Just TgtAndPath{tapPath=AndPath{pathList=q : _, pathGoal}} -> do+      -- We prefer the goal position, so that we can kill the foe and enter it,+      -- but we accept any @q@ as well.+      let maim | adjacent (bpos b) pathGoal = Just pathGoal+               | adjacent (bpos b) q = Just q+               | otherwise = Nothing  -- MeleeDistant+      lBlocker <- case maim of+        Nothing -> return []+        Just aim -> getsState $ posToAssocs aim (blid b)+      case lBlocker of+        (aid2, body2) : _ -> do+          let ar2 = fromMaybe (assert `failure` aid2)+                              (EM.lookup aid2 actorAspect)+          -- No problem if there are many projectiles at the spot. We just+          -- attack the first one.+          if | actorDying body2+               || bproj body2  -- displacing saves a move+                  && EM.findWithDefault 0 AbDisplace actorSk <= 0 ->+               return reject+             | isAtWar fact (bfid body2)  -- at war with us, hit, not disp+               || (bfid body2 == bfid b+                   || isAllied fact (bfid body2)) -- don't start a war+                  && EM.findWithDefault 0 AbDisplace actorSk <= 0  -- can't disp+                  && EM.findWithDefault 0 AbMove actorSk > 0  -- blocked move+                  && 3 * bhp body2 < bhp b  -- only get rid of weak friends+                  && bspeed body2 ar2 <= bspeed b ar -> do+               mel <- maybeToList <$> pickWeaponClient aid aid2+               return $! liftFrequency $ uniformFreq "melee in the way" mel+             | otherwise -> return reject+        [] -> return reject+    _ -> return reject  -- probably no path to the enemy, if any++-- Everybody melees in a pinch, skills and weapons allowing,+-- even though some prefer ranged attacks.+meleeAny :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbMelee))+meleeAny aid = do+  b <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  adjacentAssocs <- getsState $ actorAdjacentAssocs b+  let foe (_, b2) = not (bproj b2) && isAtWar fact (bfid b2) && bhp b2 > 0+      adjFoes = filter foe adjacentAssocs+  mels <- mapM (pickWeaponClient aid . fst) adjFoes+  let freq = uniformFreq "melee adjacent" $ catMaybes mels+  return $! liftFrequency freq++-- | The level the actor is on is either explored or the actor already+-- has a weapon equipped, so no need to explore further, he tries to find+-- enemies on other levels.+-- We don't verify any embedded item is targeted by the actor, but at least+-- the actor doesn't target a visible enemy at this point.+trigger :: MonadClient m+        => ActorId -> FleeViaStairsOrEscape+        -> m (Strategy (RequestTimed 'AbAlter))+trigger aid fleeVia = do+  b <- getsState $ getActorBody aid+  lvl <- getLevel (blid b)+  let f pos = case EM.lookup pos $ lembed lvl of+        Nothing -> Nothing+        Just bag -> Just (pos, bag)+      pbags = mapMaybe f $ vicinityUnsafe (bpos b)+  efeat <- embedBenefit fleeVia aid pbags+  return $! liftFrequency $ toFreq "trigger"+    [ (benefit, ReqAlter pos)+    | (benefit, (pos, _)) <- efeat ]++projectItem :: MonadClient m+            => ActorId -> m (Strategy (RequestTimed 'AbProject))+projectItem aid = do+  btarget <- getsClient $ getTarget aid+  b <- getsState $ getActorBody aid+  mfpos <- case btarget of+    Nothing -> return Nothing+    Just target -> aidTgtToPos aid (blid b) target+  seps <- getsClient seps+  case (btarget, mfpos) of+    (_, Just fpos) | adjacent (bpos b) fpos -> return reject+    (Just TEnemy{}, Just fpos) -> do+      mnewEps <- makeLine False b fpos seps+      case mnewEps of+        Just newEps -> do+          actorSk <- currentSkillsClient aid+          let skill = EM.findWithDefault 0 AbProject actorSk+          -- ProjectAimOnself, ProjectBlockActor, ProjectBlockTerrain+          -- and no actors or obstacles along the path.+          benList <- condProjectListM skill aid+          localTime <- getsState $ getLocalTime (blid b)+          let coeff CGround = 2  -- pickup turn saved+              coeff COrgan = assert `failure` benList+              coeff CEqp = 100000  -- must hinder currently+              coeff CInv = 1+              coeff CSha = 1+              fRanged (mben, cstore, iid, itemFull@ItemFull{itemBase}) =+                -- We assume if the item has a timeout, most effects are under+                -- Recharging, so no point projecting if not recharged.+                -- This changes in time, so recharging is not included+                -- in @condProjectListM@, but checked here, just before fling.+                let recharged = hasCharge localTime itemFull+                    trange = totalRange itemBase+                    bestRange =+                      chessDist (bpos b) fpos + 2  -- margin for fleeing+                    rangeMult =  -- penalize wasted or unsafely low range+                      10 + max 0 (10 - abs (trange - bestRange))+                    benR = coeff cstore+                           * case mben of+                               Nothing -> -10  -- experiment if no good options+                               Just Benefit{benFling} -> benFling+                in if trange >= chessDist (bpos b) fpos && recharged+                   then Just ( - benR * rangeMult `div` 10+                             , ReqProject fpos newEps iid cstore )+                   else Nothing+              benRanged = mapMaybe fRanged benList+          return $! liftFrequency $ toFreq "projectItem" benRanged+        _ -> return reject+    _ -> return reject++data ApplyItemGroup = ApplyAll | ApplyFirstAid+  deriving Eq++applyItem :: MonadClient m+          => ActorId -> ApplyItemGroup -> m (Strategy (RequestTimed 'AbApply))+applyItem aid applyGroup = do+  actorSk <- currentSkillsClient aid+  b <- getsState $ getActorBody aid+  condShineWouldBetray <- condShineWouldBetrayM aid+  condAimEnemyPresent <- condAimEnemyPresentM aid+  localTime <- getsState $ getLocalTime (blid b)+  actorAspect <- getsClient sactorAspect+  let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect)+      calmE = calmEnough b ar+      condNotCalmEnough = not calmE+      heavilyDistressed =  -- Actor hit by a projectile or similarly distressed.+        deltaSerious (bcalmDelta b)+      skill = EM.findWithDefault 0 AbApply actorSk+      -- This detects if the value of keeping the item in eqp is in fact < 0.+      hind = hinders condShineWouldBetray condAimEnemyPresent+                     heavilyDistressed condNotCalmEnough b ar+      permittedActor =+        either (const False) id+        . permittedApply localTime skill calmE " "+      q (mben, _, _, itemFull) =+        let freq = case itemDisco itemFull of+              Nothing -> []+              Just ItemDisco{itemKind} -> IK.ifreq itemKind+            durable = IK.Durable `elem` jfeature (itemBase itemFull)+            (bInEqp, bApply) = case mben of+              Just Benefit{benInEqp, benApply} -> (benInEqp, benApply)+              Nothing -> (goesIntoEqp $ itemBase itemFull, 0)  -- apply unsafe+        in bApply > 0+           && (not bInEqp  -- can't wear, so OK to break+               || durable  -- can wear, but can't break, even better+               || not (isMelee $ itemBase itemFull)  -- anything else expendable+                  && hind itemFull)  -- hinders now, so possibly often, so away!+           && permittedActor itemFull+           && maybe True (<= 0) (lookup "gem" freq) -- hack for elixir of youth+      -- Organs are not taken into account, because usually they are either+      -- melee items, so harmful, or periodic, so charging between activations.+      -- The case of a weak weapon curing poison is too rare to incur overhead.+      stores = [CEqp, CInv, CGround] ++ [CSha | calmE]+  benList <- benAvailableItems aid stores+  organs <- mapM (getsState . getItemBody) $ EM.keys $ borgan b+  let hasGrps = mapMaybe (\item -> if jweight item == 0+                                   then Just $ toGroupName $ jname item+                                   else Nothing) organs+      itemLegal itemFull =+        -- Don't include @Ascend@ not @Teleport@, because can be no foe nearby.+        let getP (IK.RefillHP p) | p > 0 = True+            getP _ = False+            firstAidItem = case itemDisco itemFull of+              Just ItemDisco{itemKind} -> any getP $ IK.ieffects itemKind+              _ -> False+        in if applyGroup == ApplyFirstAid+           then firstAidItem+           else not $ hpEnough b ar && firstAidItem+      coeff CGround = 2  -- pickup turn saved+      coeff COrgan = assert `failure` benList+      coeff CEqp = 1+      coeff CInv = 1+      coeff CSha = 1+      fTool benAv@(mben, cstore, iid, itemFull@ItemFull{itemBase}) =+        let onlyVoidlyDropsOrgan =+              -- We check if the only effect of the item is that it drops a tmp+              -- organ that we don't have. If so, item should not be applied.+              -- This assumes the organ dropping is beneficial and so worth+              -- saving for the future, for otherwise the item would not+              -- be considered at all, given that it's the only effect.+              -- We don't try to intecept a case of many effects.+              let dropsGrps = strengthDropOrgan itemFull+                  hasDropOrgan = not $ null dropsGrps+                  f eff = [eff | IK.forApplyEffect eff]+              in hasDropOrgan+                 && (null hasGrps+                     || toGroupName "temporary condition" `notElem` dropsGrps+                        && null (dropsGrps `intersect` hasGrps))+                 && length (strengthEffect f itemFull) == 1+            durable = IK.Durable `elem` jfeature itemBase+            benR = case mben of+              Nothing -> 0+                -- experimenting is fun, but it's better to risk+                -- foes' skin than ours+              Just Benefit{benApply} ->+                benApply+                * if cstore == CEqp && not durable+                  then 100000  -- must hinder currently+                  else coeff cstore+        in if q benAv && itemLegal itemFull && not onlyVoidlyDropsOrgan+           then Just (benR, ReqApply iid cstore)+           else Nothing+      benTool = mapMaybe fTool benList+  return $! liftFrequency $ toFreq "applyItem" benTool++-- If low on health or alone, flee in panic, close to the path to target+-- and as far from the attackers, as possible. Usually fleeing from+-- foes will lead towards friends, but we don't insist on that.+-- We use chess distances, not pathfinding, because melee can happen+-- at path distance 2.+flee :: MonadClient m+     => ActorId -> [(Int, Point)] -> m (Strategy RequestAnyAbility)+flee aid fleeL = do+  b <- getsState $ getActorBody aid+  let vVic = map (second (`vectorToFrom` bpos b)) fleeL+      str = liftFrequency $ toFreq "flee" vVic+  mapStrategyM (moveOrRunAid aid) str++-- The result of all these conditions is that AI displaces rarely,+-- but it can't be helped as long as the enemy is smart enough to form fronts.+displaceFoe :: MonadClient m => ActorId -> m (Strategy RequestAnyAbility)+displaceFoe aid = do+  Kind.COps{coTileSpeedup} <- getsState scops+  b <- getsState $ getActorBody aid+  lvl <- getLevel $ blid b+  fact <- getsState $ (EM.! bfid b) . sfactionD+  friends <- getsState $ friendlyActorRegularList (bfid b) (blid b)+  adjacentAssocs <- getsState $ actorAdjacentAssocs b+  let foe (_, b2) = not (bproj b2) && isAtWar fact (bfid b2) && bhp b2 > 0+      adjFoes = filter foe adjacentAssocs+      displaceable body =  -- DisplaceAccess+        Tile.isWalkable coTileSpeedup (lvl `at` bpos body)+      nFriends body = length $ filter (adjacent (bpos body) . bpos) friends+      nFrNew = nFriends b + 1+      qualifyActor (aid2, body2) = do+        actorMaxSk <- maxActorSkillsClient aid2+        dEnemy <- getsState $ dispEnemy aid aid2 actorMaxSk+          -- DisplaceDying, DisplaceBraced, DisplaceImmobile, DisplaceSupported+        let nFrOld = nFriends body2+        return $! if displaceable body2 && dEnemy && nFrOld < nFrNew+                  then Just (nFrOld * nFrOld, bpos body2 `vectorToFrom` bpos b)+                  else Nothing+  vFoes <- mapM qualifyActor adjFoes+  let str = liftFrequency $ toFreq "displaceFoe" $ catMaybes vFoes+  mapStrategyM (moveOrRunAid aid) str++displaceBlocker :: MonadClient m+                => ActorId -> Bool -> m (Strategy RequestAnyAbility)+displaceBlocker aid retry = do+  b <- getsState $ getActorBody aid+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  str <- case mtgtMPath of+    Just TgtAndPath{ tapTgt=TEnemy{}+                   , tapPath=AndPath{pathList=q : _, pathGoal} }+      | q == pathGoal && not retry ->+        return reject  -- not a real blocker but goal, possibly enemy to melee+    Just TgtAndPath{tapPath=AndPath{pathList=q : _}}+      | adjacent (bpos b) q ->  -- not veered off target+      displaceTowards aid q retry+    _ -> return reject  -- goal reached+  mapStrategyM (moveOrRunAid aid) str++displaceTowards :: MonadClient m+                => ActorId -> Point -> Bool -> m (Strategy Vector)+displaceTowards aid target retry = do+  Kind.COps{coTileSpeedup} <- getsState scops+  b <- getsState $ getActorBody aid+  let source = bpos b+  let !_A = assert (adjacent source target) ()+  lvl <- getLevel $ blid b+  if boldpos b /= Just target -- avoid trivial loops+     && Tile.isWalkable coTileSpeedup (lvl `at` target) then do+       -- DisplaceAccess+    mleader <- getsClient _sleader+    mBlocker <- getsState $ posToAssocs target (blid b)+    case mBlocker of+      [] -> return reject+      [(aid2, b2)] | Just aid2 /= mleader -> do+        mtgtMPath <- getsClient $ EM.lookup aid2 . stargetD+        enemyTgt <- condAimEnemyPresentM aid+        enemyPos <- condAimEnemyRememberedM aid+        enemyTgt2 <- condAimEnemyPresentM aid2+        enemyPos2 <- condAimEnemyRememberedM aid2+        case mtgtMPath of+          Just TgtAndPath{tapPath=AndPath{pathList=q : _}}+            | q == source  -- friend wants to swap+              || retry  -- desperate+                 && not (boldpos b == Just target  -- and no displace loop+                         && not (waitedLastTurn b))+              || (enemyTgt || enemyPos) && not (enemyTgt2 || enemyPos2) ->+                 -- he doesn't have Enemy target and I have, so push him aside,+                 -- because, for heroes, he will never be a leader, so he can't+                 -- step aside himself+              return $! returN "displace friend" $ target `vectorToFrom` source+          Just _ -> return reject+          Nothing -> do  -- an enemy or ally or disoriented friend --- swap+            tfact <- getsState $ (EM.! bfid b2) . sfactionD+            actorMaxSk <- maxActorSkillsClient aid2+            dEnemy <- getsState $ dispEnemy aid aid2 actorMaxSk+            if not (isAtWar tfact (bfid b)) || dEnemy then+              return $! returN "displace other" $ target `vectorToFrom` source+            else return reject  -- DisplaceDying, etc.+      _ -> return reject  -- DisplaceProjectiles or trying to displace leader+  else return reject++chase :: MonadClient m+      => ActorId -> Bool -> Bool -> m (Strategy RequestAnyAbility)+chase aid avoidAmbient retry = do+  Kind.COps{coTileSpeedup} <- getsState scops+  body <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid body) . sfactionD+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  lvl <- getLevel $ blid body+  let isAmbient pos = Tile.isLit coTileSpeedup (lvl `at` pos)+  str <- case mtgtMPath of+    Just TgtAndPath{tapPath=AndPath{pathList=q : _, ..}}+      | pathGoal == bpos body -> return reject  -- shortcut and just to be sure+      | not $ avoidAmbient && isAmbient q ->+      -- With no leader, the goal is vague, so permit arbitrary detours.+      moveTowards aid q pathGoal (fleaderMode (gplayer fact) == LeaderNull+                                  || retry)+    _ -> return reject  -- goal reached or banned ambient lit tile+  if avoidAmbient && nullStrategy str+  then chase aid False retry+  else mapStrategyM (moveOrRunAid aid) str++moveTowards :: MonadClient m+            => ActorId -> Point -> Point -> Bool -> m (Strategy Vector)+moveTowards aid target goal relaxed = do+  b <- getsState $ getActorBody aid+  actorSk <- currentSkillsClient aid+  let source = bpos b+      alterSkill = EM.findWithDefault 0 AbAlter actorSk+      !_A = assert (source == bpos b+                    `blame` (source, bpos b, aid, b, goal)) ()+      !_B = assert (adjacent source target+                    `blame` (source, target, aid, b, goal)) ()+  fact <- getsState $ (EM.! bfid b) . sfactionD+  salter <- getsClient salter+  let noF = isAtWar fact . bfid+  noFriends <- getsState $ \s p -> all (noF . snd) $ posToAssocs p (blid b) s+  let lalter = salter EM.! blid b+      -- Only actors with AbAlter can search for hidden doors, etc.+      enterableHere p = alterSkill >= fromEnum (lalter PointArray.! p)+  if noFriends target && enterableHere target then+    return $! returN "moveTowards adjacent" $ target `vectorToFrom` source+  else do+    let goesBack p = Just p == boldpos b+        nonincreasing p = chessDist source goal >= chessDist p goal+        isSensible | relaxed = \p -> noFriends p+                                     && enterableHere p+                   | otherwise = \p -> nonincreasing p+                                       && not (goesBack p)+                                       && noFriends p+                                       && enterableHere p+        sensible = [ ((goesBack p, chessDist p goal), v)+                   | v <- moves, let p = source `shift` v, isSensible p ]+        sorted = sortBy (comparing fst) sensible+        groups = map (map snd) $ groupBy ((==) `on` fst) sorted+        freqs = map (liftFrequency . uniformFreq "moveTowards") groups+    return $! foldr (.|) reject freqs++-- | Actor moves or searches or alters or attacks.+-- This function is very general, even though it's often used in contexts+-- when only one or two of the many cases can possibly occur.+moveOrRunAid :: MonadClient m+             => ActorId -> Vector -> m (Maybe RequestAnyAbility)+moveOrRunAid source dir = do+  Kind.COps{coTileSpeedup} <- getsState scops+  sb <- getsState $ getActorBody source+  actorSk <- currentSkillsClient source+  let lid = blid sb+  lvl <- getLevel lid+  let alterSkill = EM.findWithDefault 0 AbAlter actorSk+      spos = bpos sb           -- source position+      tpos = spos `shift` dir  -- target position+      t = lvl `at` tpos+  -- We start by checking actors at the target position,+  -- which gives a partial information (actors can be invisible),+  -- as opposed to accessibility (and items) which are always accurate+  -- (tiles can't be invisible).+  tgts <- getsState $ posToAssocs tpos lid+  case tgts of+    [(target, b2)] -> do+      -- @target@ can be a foe, as well as a friend.+      tfact <- getsState $ (EM.! bfid b2) . sfactionD+      actorMaxSk <- maxActorSkillsClient target+      dEnemy <- getsState $ dispEnemy source target actorMaxSk+      if | boldpos sb == Just tpos && not (waitedLastTurn sb)+             -- avoid displace loops+           || not (Tile.isWalkable coTileSpeedup $ lvl `at` tpos) ->+             -- DisplaceAccess+           return Nothing+         | isAtWar tfact (bfid sb) && not dEnemy -> do  -- DisplaceDying, etc.+           -- If really can't displace, melee.+           wps <- pickWeaponClient source target+           case wps of+             Nothing -> return Nothing+             Just wp -> return $ Just $ RequestAnyAbility wp+         | otherwise ->+           return $ Just $ RequestAnyAbility $ ReqDisplace target+    (target, _) : _ -> do  -- can be a foe, as well as friend (e.g., projectile)+      -- If really can't displace, melee.+      -- No problem if there are many projectiles at the spot. We just+      -- attack the first one.+      -- Attacking does not require full access, adjacency is enough.+      wps <- pickWeaponClient source target+      case wps of+        Nothing -> return Nothing+        Just wp -> return $ Just $ RequestAnyAbility wp+    [] -- move or search or alter+       | Tile.isWalkable coTileSpeedup $ lvl `at` tpos ->+         -- Movement requires full access.+         return $ Just $ RequestAnyAbility $ ReqMove dir+         -- The potential invisible actor is hit.+       | alterSkill < Tile.alterMinWalk coTileSpeedup t ->+         assert `failure` "AI causes AlterUnwalked" `twith` (source, dir)+       | EM.member tpos $ lfloor lvl ->+         -- Only possible if items allowed inside unwalkable tiles.+         assert `failure` "AI causes AlterBlockItem" `twith` (source, dir)+       | otherwise ->+         -- Not walkable, but alter skill suffices, so search or alter the tile.+         return $ Just $ RequestAnyAbility $ ReqAlter tpos

− Game/LambdaHack/Client/AI/PickActorClient.hs

@@ -1,268 +0,0 @@-{-# LANGUAGE TupleSections #-}--- | Semantics of most 'ResponseAI' client commands.-module Game.LambdaHack.Client.AI.PickActorClient-  ( pickActorToMove-  ) where--import Control.Applicative-import Control.Arrow-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.List-import Data.Maybe-import Data.Ord--import Game.LambdaHack.Client.AI.ConditionClient-import Game.LambdaHack.Client.AI.PickTargetClient-import Game.LambdaHack.Client.BfsClient-import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Frequency-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ModeKind--pickActorToMove :: MonadClient m-                => ((ActorId, Actor) -> m (Maybe (Target, PathEtc)))-                -> ActorId-                -> m (ActorId, Actor)-pickActorToMove refreshTarget oldAid = do-  Kind.COps{cotile} <- getsState scops-  oldBody <- getsState $ getActorBody oldAid-  let side = bfid oldBody-      arena = blid oldBody-  fact <- getsState $ (EM.! side) . sfactionD-  lvl <- getLevel arena-  let leaderStuck = waitedLastTurn oldBody-      t = lvl `at` bpos oldBody-  mleader <- getsClient _sleader-  ours <- getsState $ actorRegularAssocs (== side) arena-  let explore = void $ refreshTarget (oldAid, oldBody)-      setPath mtgt = case mtgt of-        Nothing -> return False-        Just (tgtLeader, _) -> do-          mpath <- createPath oldAid tgtLeader-          case mpath of-            Nothing -> return False-            Just path -> do-              let tgtMPath = second Just path-              modifyClient $ \cli ->-                cli {stargetD = EM.alter (const $ Just tgtMPath)-                                         oldAid (stargetD cli)}-              return True-      follow = case mleader of-        -- If no leader at all (forced @TFollow@ tactic on an actor-        -- from a leaderless faction), fall back to @TExplore@.-        Nothing -> explore-        Just leader -> do-          onLevel <- getsState $ memActor leader arena-          -- If leader not on this level, fall back to @TExplore@.-          if not onLevel then explore-          else do-            modifyClient $ \cli ->-              cli { sbfsD = invalidateBfs oldAid (sbfsD cli)-                  , seps = seps cli + 773 }  -- randomize paths-            -- Copy over the leader's target, if any, or follow his bpos.-            mtgt <- getsClient $ EM.lookup leader . stargetD-            tgtPathSet <- setPath mtgt-            let enemyPath = Just (TEnemy leader True, Nothing)-            unless tgtPathSet $ do-               enemyPathSet <- setPath enemyPath-               unless enemyPathSet $-                 -- If no path even to the leader himself, explore.-                 explore-      pickOld = do-        if mleader == Just oldAid then explore-        else case ftactic $ gplayer fact of-          TExplore -> explore-          TFollow -> follow-          TFollowNoItems -> follow-          TMeleeAndRanged -> explore  -- needs to find ranged targets-          TMeleeAdjacent -> explore  -- probably not needed, but may change-          TBlock -> return ()  -- no point refreshing target-          TRoam -> explore  -- @TRoam@ is checked again inside @explore@-          TPatrol -> explore  -- TODO-        return (oldAid, oldBody)-  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-      -> pickOld-    [] -> assert `failure` (oldAid, oldBody)-    [_] -> pickOld  -- Keep the leader: he is alone on the level.-    (captain, captainBody) : (sergeant, sergeantBody) : _ -> do-      -- At this point we almost forget who the old leader was-      -- and treat all party actors the same, eliminating candidates-      -- until we can't distinguish them any more, at which point we prefer-      -- the old leader, if he is among the best candidates-      -- (to make the AI appear more human-like and easier to observe).-      -- TODO: this also takes melee into account, but not shooting.-      let refresh aidBody = do-            mtgt <- refreshTarget aidBody-            return $! (aidBody,) <$> mtgt-      oursTgt <- catMaybes <$> mapM refresh ours-      let actorVulnerable ((aid, body), _) = do-            activeItems <- activeItemsClient aid-            condMeleeBad <- condMeleeBadM aid-            threatDistL <- threatDistList aid-            (fleeL, _) <- fleeList aid-            let actorMaxSk = sumSkills activeItems-                abInMaxSkill ab = EM.findWithDefault 0 ab actorMaxSk > 0-                condNoUsableWeapon = all (not . isMelee) activeItems-                canMelee = abInMaxSkill AbMelee && not condNoUsableWeapon-                condCanFlee = not (null fleeL)-                condThreatAtHandVeryClose =-                  not $ null $ takeWhile ((<= 2) . fst) threatDistL-                threatAdj = takeWhile ((== 1) . fst) threatDistL-                condThreatAdj = not $ null threatAdj-                condFastThreatAdj =-                  any (\(_, (_, b)) ->-                         bspeed b activeItems > bspeed body activeItems)-                      threatAdj-                heavilyDistressed =-                  -- Actor hit by a projectile or similarly distressed.-                  deltaSerious (bcalmDelta body)-            return $! not (canMelee && condThreatAdj)-                      && if condThreatAtHandVeryClose-                         then condCanFlee && condMeleeBad-                              && not condFastThreatAdj-                         else heavilyDistressed  -- shot at-                           -- TODO: modify when reaction fire is possible-          actorHearning (_, (TEnemyPos{}, (_, (_, d)))) | d <= 2 =-            return False  -- noise probably due to fleeing target-          actorHearning ((_aid, b), _) = do-            allFoes <- getsState $ actorRegularList (isAtWar fact) (blid b)-            let closeFoes = filter ((<= 3) . chessDist (bpos b) . bpos) allFoes-                mildlyDistressed = deltaMild (bcalmDelta b)-            return $! mildlyDistressed  -- e.g., actor hears an enemy-                      && null closeFoes  -- the enemy not visible; a trap!-          -- AI has to be prudent and not lightly waste leader for meleeing,-          -- even if his target is distant-          actorMeleeing ((aid, _), _) = condAnyFoeAdjM aid-          actorMeleeBad ((aid, _), _) = do-            threatDistL <- threatDistList aid-            let condThreatMedium =  -- if foes far, friends may still come-                  not $ null $ takeWhile ((<= 5) . fst) threatDistL-            condMeleeBad <- condMeleeBadM aid-            return $! condThreatMedium && condMeleeBad-      oursVulnerable <- filterM actorVulnerable oursTgt-      oursSafe <- filterM (fmap not . actorVulnerable) oursTgt-        -- TODO: partitionM-      oursMeleeing <- filterM actorMeleeing oursSafe-      oursNotMeleeing <- filterM (fmap not . actorMeleeing) oursSafe-      oursHearing <- filterM actorHearning oursNotMeleeing-      oursNotHearing <- filterM (fmap not . actorHearning) oursNotMeleeing-      oursMeleeBad <- filterM actorMeleeBad oursNotHearing-      oursNotMeleeBad <- filterM (fmap not . actorMeleeBad) oursNotHearing-      let targetTEnemy (_, (TEnemy{}, _)) = True-          targetTEnemy (_, (TEnemyPos{}, _)) = True-          targetTEnemy _ = False-          (oursTEnemy, oursOther) = partition targetTEnemy oursNotMeleeBad-          -- These are not necessarily stuck (perhaps can go around),-          -- but their current path is blocked by friends.-          targetBlocked our@((_aid, _b), (_tgt, (path, _etc))) =-            let next = case path of-                  [] -> assert `failure` our-                  [_goal] -> Nothing-                  _ : q : _ -> Just q-            in any ((== next) . Just . bpos . snd) ours--- TODO: stuck actors are picked while others close could approach an enemy;--- we should detect stuck actors (or one-sided stuck)--- so far we only detect blocked and only in Other mode---             && not (aid == oldAid && waitedLastTurn b time)  -- not stuck--- this only prevents staying stuck-          (oursBlocked, oursPos) =-            partition targetBlocked $ oursOther ++ oursMeleeBad-          -- Lower overhead is better.-          overheadOurs :: ((ActorId, Actor), (Target, PathEtc))-                       -> (Int, Int, Bool)-          overheadOurs our@((aid, b), (_, (_, (goal, d)))) =-            if targetTEnemy our then-              -- TODO: take weapon, walk and fight speed, etc. into account-              ( d + if targetBlocked our then 2 else 0  -- possible delay, hacky-              , - 10 * fromIntegral (bhp b `div` (10 * oneM))-              , aid /= oldAid )-            else-              -- Keep proper formation, not too dense, not to sparse.-              let-                -- TODO: vary the parameters according to the stage of game,-                -- enough equipment or not, game mode, level map, etc.-                minSpread = 7-                maxSpread = 12 * 2-                dcaptain p =-                  chessDistVector $ bpos captainBody `vectorToFrom` p-                dsergeant p =-                  chessDistVector $ bpos sergeantBody `vectorToFrom` p-                minDist | aid == captain = dsergeant (bpos b)-                        | aid == sergeant = dcaptain (bpos b)-                        | otherwise = dsergeant (bpos b)-                                      `min` dcaptain (bpos b)-                pDist p = dcaptain p + dsergeant p-                sumDist = pDist (bpos b)-                -- Positive, if the goal gets us closer to the party.-                diffDist = sumDist - pDist goal-                minCoeff | minDist < minSpread =-                  (minDist - minSpread) `div` 3-                  - if aid == oldAid then 3 else 0-                         | otherwise = 0-                explorationValue = diffDist * (sumDist `div` 4)--- TODO: this half is not yet ready:--- instead spread targets between actors; moving many actors--- to a single target and stopping and starting them--- is very wasteful; also, pick targets not closest to the actor in hand,--- but to the sum of captain and sergant or something-                sumCoeff | sumDist > maxSpread = - explorationValue-                         | otherwise = 0-              in ( if d == 0 then d-                   else max 1 $ minCoeff + if d < 10-                                           then 3 + d `div` 4-                                           else 9 + d `div` 10-                 , sumCoeff-                 , aid /= oldAid )-          sortOurs = sortBy $ comparing overheadOurs-          goodGeneric ((aid, b), (_tgt, _pathEtc)) =-            not (aid == oldAid && waitedLastTurn b)  -- not stuck-          goodTEnemy our@((_aid, b), (TEnemy{}, (_path, (goal, _d)))) =-            not (adjacent (bpos b) goal) -- not in melee range already-            && goodGeneric our-          goodTEnemy our = goodGeneric our-          oursVulnerableGood = filter goodTEnemy oursVulnerable-          oursTEnemyGood = filter goodTEnemy oursTEnemy-          oursPosGood = filter goodGeneric oursPos-          oursMeleeingGood = filter goodGeneric oursMeleeing-          oursHearingGood = filter goodTEnemy oursHearing-          oursBlockedGood = filter goodGeneric oursBlocked-          candidates = [ sortOurs oursVulnerableGood-                       , sortOurs oursTEnemyGood-                       , sortOurs oursPosGood-                       , sortOurs oursMeleeingGood-                       , sortOurs oursHearingGood-                       , sortOurs oursBlockedGood-                       ]-      case filter (not . null) candidates of-        l@(c : _) : _ -> do-          let best = takeWhile ((== overheadOurs c) . overheadOurs) l-              freq = uniformFreq "candidates for AI leader" best-          ((aid, b), _) <- rndToAction $ frequency freq-          s <- getState-          modifyClient $ updateLeader aid s-          return (aid, b)-        _ -> return (oldAid, oldBody)

+ Game/LambdaHack/Client/AI/PickActorM.hs view

@@ -0,0 +1,318 @@+-- | Semantics of most 'ResponseAI' client commands.+module Game.LambdaHack.Client.AI.PickActorM+  ( pickActorToMove, useTactics+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.EnumMap.Strict as EM+import Data.Ratio++import Game.LambdaHack.Client.AI.ConditionM+import Game.LambdaHack.Client.AI.PickTargetM+import Game.LambdaHack.Client.Bfs+import Game.LambdaHack.Client.BfsM+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Frequency+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.State+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Content.ModeKind++-- Pick a new leader from among the actors on the current level.+-- Refresh the target of the new leader, even if unchanged.+pickActorToMove :: MonadClient m => Maybe ActorId -> m ActorId+{-# INLINE pickActorToMove #-}+pickActorToMove maidToAvoid = do+  actorAspect <- getsClient sactorAspect+  mleader <- getsClient _sleader+  let oldAid = fromMaybe (assert `failure` maidToAvoid) mleader+  oldBody <- getsState $ getActorBody oldAid+  let side = bfid oldBody+      arena = blid oldBody+  fact <- getsState $ (EM.! side) . sfactionD+  -- Find our actors on the current level only.+  ours <- getsState $ filter (isNothing . btrajectory . snd)+                      . actorRegularAssocs (== side) arena+  let pickOld = do+        void $ refreshTarget (oldAid, oldBody)+        return oldAid+  case ours of+    _ | -- Keep the leader: faction discourages client leader change on level,+        -- so will only be changed if waits (maidToAvoid)+        -- to avoid wasting his higher mobility.+        -- This is OK for monsters even if in melee, because both having+        -- a meleeing actor a leader (and higher DPS) and rescuing actor+        -- a leader (and so faster to get in melee range) is good.+        -- And we are guaranteed that only the two classes of actors are+        -- not waiting, with some exceptions (urgent unequip, flee via starts,+        -- melee-less trying to flee, first aid, etc.).+        snd (autoDungeonLevel fact) && isNothing maidToAvoid+      -> pickOld+    [] -> assert `failure` (oldAid, oldBody)+    [_] -> pickOld  -- Keep the leader: he is alone on the level.+    _ -> do+      -- At this point we almost forget who the old leader was+      -- and treat all party actors the same, eliminating candidates+      -- until we can't distinguish them any more, at which point we prefer+      -- the old leader, if he is among the best candidates+      -- (to make the AI appear more human-like and easier to observe).+      let refresh aidBody = do+            mtgt <- refreshTarget aidBody+            return (aidBody, mtgt)+          goodGeneric (_, Nothing) = Nothing+          goodGeneric (_, Just TgtAndPath{tapPath=NoPath}) = Nothing+            -- this case means melee-less heroes adjacent to foes, etc.+            -- will never flee if melee is happening; but this is rare;+            -- this also ensures even if a lone actor melees and nobody+            -- can come to rescue, he will become and remain the leader,+            -- because otherwise an explorer would need to become a leader+            -- and fighter will be 1 clip slower for the whole fight,+            -- just for a few turns of exploration in return+          goodGeneric ((aid, b), Just tgt) = case maidToAvoid of+            Nothing | not (aid == oldAid && waitedLastTurn b) ->+              -- Not the old leader that was stuck last turn+              -- because he is likely to be still stuck.+              Just ((aid, b), tgt)+            Just aidToAvoid | aid /= aidToAvoid ->+              -- Not an attempted leader stuck this turn/+              Just ((aid, b), tgt)+            _ -> Nothing+      oursTgtRaw <- mapM refresh ours+      let oursTgt = mapMaybe goodGeneric oursTgtRaw+          -- This should be kept in sync with @actionStrategy@.+          actorVulnerable ((aid, body), _) = do+            scondInMelee <- getsClient scondInMelee+            let condInMelee = fromMaybe (assert `failure` condInMelee)+                                        (scondInMelee EM.! blid body)+                ar = fromMaybe (assert `failure` aid)+                               (EM.lookup aid actorAspect)+            threatDistL <- meleeThreatDistList aid+            (fleeL, _) <- fleeList aid+            condSupport1 <- condSupport 1 aid+            condSupport2 <- condSupport 2 aid+            canDeAmbientL <- getsState $ canDeAmbientList body+            let condCanFlee = not (null fleeL)+                speed1_5 = speedScale (3%2) (bspeed body ar)+                condCanMelee = actorCanMelee actorAspect aid body+                condThreat n = not $ null $ takeWhile ((<= n) . fst) threatDistL+                threatAdj = takeWhile ((== 1) . fst) threatDistL+                condManyThreatAdj = length threatAdj >= 2+                condFastThreatAdj =+                  any (\(_, (aid2, b2)) ->+                    let ar2 = actorAspect EM.! aid2+                    in bspeed b2 ar2 > speed1_5)+                  threatAdj+                heavilyDistressed =+                  -- Actor hit by a projectile or similarly distressed.+                  deltaSerious (bcalmDelta body)+                actorShines = aShine ar > 0+                aCanDeLightL | actorShines = []+                             | otherwise = canDeAmbientL+                canFleeFromLight =+                  not $ null $ aCanDeLightL `intersect` map snd fleeL+            return $!+              not condFastThreatAdj+              && if | condThreat 1 -> not condCanMelee+                                      || condManyThreatAdj && not condSupport1+                    | not condInMelee+                      && (condThreat 2 || condThreat 5 && canFleeFromLight) ->+                      not condCanMelee+                      || not condSupport2 && not heavilyDistressed+                    -- not used: | condThreat 5 -> False+                    -- because actor should be picked anyway, to try to melee+                    | otherwise ->+                      not condInMelee+                      && heavilyDistressed+                      -- Make him a leader even if can't delight, etc.+                      -- because he may instead take off light or otherwise+                      -- cope with being pummeled by projectiles.+                      -- He is still vulnerable, just not necessarily needs+                      -- to flee, but may cover himself otherwise.+                      -- && (not condCanProject || canFleeFromLight)+              && condCanFlee+          actorHearning (_, TgtAndPath{ tapTgt=TPoint TEnemyPos{} _ _+                                      , tapPath=NoPath }) =+            return False+          actorHearning (_, TgtAndPath{ tapTgt=TPoint TEnemyPos{} _ _+                                      , tapPath=AndPath{pathLen} })+            | pathLen <= 2 =+            return False  -- noise probably due to fleeing target+          actorHearning ((_aid, b), _) = do+            allFoes <- getsState $ warActorRegularList side (blid b)+            let closeFoes = filter ((<= 3) . chessDist (bpos b) . bpos) allFoes+                mildlyDistressed = deltaMild (bcalmDelta b)+            return $! mildlyDistressed  -- e.g., actor hears an enemy+                      && null closeFoes  -- the enemy not visible; a trap!+          -- AI has to be prudent and not lightly waste leader for meleeing,+          -- even if his target is distant+          actorMeleeing ((aid, _), _) = condAnyFoeAdjM aid+      (oursVulnerable, oursSafe) <- partitionM actorVulnerable oursTgt+      (oursMeleeing, oursNotMeleeing) <- partitionM actorMeleeing oursSafe+      (oursHearing, oursNotHearing) <- partitionM actorHearning oursNotMeleeing+      let actorRanged ((aid, body), _) =+            not $ actorCanMelee actorAspect aid body+          targetTEnemy (_, TgtAndPath{tapTgt=TEnemy{}}) = True+          targetTEnemy (_, TgtAndPath{tapTgt=TPoint TEnemyPos{} _ _}) = True+          targetTEnemy _ = False+          actorNoSupport ((aid, _), _) = do+            threatDistL <- meleeThreatDistList aid+            condSupport2 <- condSupport 2 aid+            let condThreat n = not $ null $ takeWhile ((<= n) . fst) threatDistL+            -- If foes far, friends may still come, so we let him move.+            -- The net effect is that lone heroes close to foes freeze+            -- until support comes.+            return $! condThreat 5 && not condSupport2+          (oursRanged, oursNotRanged) = partition actorRanged oursNotHearing+          (oursTEnemyAll, oursOther) = partition targetTEnemy oursNotRanged+          -- These are not necessarily stuck (perhaps can go around),+          -- but their current path is blocked by friends.+          notSwapReady abt@((_, b), _)+                       (ab2, Just t2@TgtAndPath{tapPath=+                                       AndPath{pathList=q : _}}) =+            let source = bpos b+                retry = False  -- avoid forced displace, unless all need it+                enemyTgtOrenemyPos = targetTEnemy abt+                enemyTgt2OrenemyPos2 = targetTEnemy (ab2, t2)+            -- Copied from 'displaceTowards':+            in not (q == source  -- friend wants to swap+                    || retry  -- desperate+                    || enemyTgtOrenemyPos && not enemyTgt2OrenemyPos2)+          notSwapReady _ _ = True+          targetBlocked abt@((aid, body), TgtAndPath{tapPath}) = case tapPath of+            AndPath{pathList= q : _} ->+               waitedLastTurn body  -- 1 free sidestep+               && any (\abt2@((aid2, body2), _) ->+                         aid2 /= aid  -- in case pushed on goal+                         && bpos body2 == q+                         && notSwapReady abt abt2)+                      oursTgtRaw+            _ -> False+          (oursTEnemyBlocked, oursTEnemy) =+            partition targetBlocked oursTEnemyAll+      (oursNoSupportRaw, oursSupportRaw) <-+        if length oursTEnemy <= 2+        then return ([], oursTEnemy)+        else partitionM actorNoSupport oursTEnemy+      let (oursNoSupport, oursSupport) =+            if length oursSupportRaw <= 1  -- make sure picks random enough+            then ([], oursTEnemy)+            else (oursNoSupportRaw, oursSupportRaw)+          (oursBlocked, oursPos) =+            partition targetBlocked $ oursRanged ++ oursOther+          -- Lower overhead is better.+          overheadOurs :: ((ActorId, Actor), TgtAndPath) -> Int+          overheadOurs ((aid, _), TgtAndPath{tapPath=NoPath}) =+            100 + if aid == oldAid then 1 else 0+          overheadOurs abt@( (aid, b)+                           , TgtAndPath{tapPath=AndPath{pathLen=d,pathGoal}} ) =+            -- Keep proper formation. Too dense and exploration takes+            -- too long; too sparse and actors fight alone.+            -- Note that right now, while we set targets separately for each+            -- hero, perhaps on opposite borders of the map,+            -- we can't help that sometimes heroes are separated.+            let maxSpread = 3 + length ours+                pDist p = minimum [ chessDist (bpos b2) p+                                  | (aid2, b2) <- ours, aid2 /= aid]+                aidDist = pDist (bpos b)+                -- Negative, if the goal gets us closer to the party.+                diffDist = pDist pathGoal - aidDist+                -- If actor already at goal or equidistant, count it as closer.+                sign = if diffDist <= 0 then -1 else 1+                formationValue =+                  sign * (abs diffDist `max` maxSpread)+                  * (aidDist `max` maxSpread) ^ (2 :: Int)+                fightValue | targetTEnemy abt =+                  - fromEnum (bhp b `div` (10 * oneM))+                           | otherwise = 0+            in formationValue `div` 3 + fightValue+               + (if targetBlocked abt then 5 else 0)+               + (case d of+                    0 -> -400 -- do your thing ASAP and retarget+                    1 -> -200 -- prevent others from occupying the tile+                    _ -> if d < 8 then d `div` 4 else 2 + d `div` 10)+               + (if aid == oldAid then 1 else 0)+          positiveOverhead ab =+            let ov = 200 - overheadOurs ab+            in if ov <= 0 then 1 else ov+          candidates = [ oursVulnerable+                       , oursSupport+                       , oursNoSupport+                       , oursPos+                       , oursMeleeing ++ oursTEnemyBlocked+                           -- make melee a leader to displace or at least melee+                           -- without overhead if all others blocked+                       , oursHearing+                       , oursBlocked+                       ]+      case filter (not . null) candidates of+        l : _ -> do+          let freq = toFreq "candidates for AI leader"+                     $ map (positiveOverhead &&& id) l+          ((aid, _), _) <- rndToAction $ frequency freq+          s <- getState+          modifyClient $ updateLeader aid s+          return aid+        _ -> return oldAid++useTactics :: MonadClient m => ActorId -> m ()+{-# INLINE useTactics #-}+useTactics oldAid = do+  oldBody <- getsState $ getActorBody oldAid+  scondInMelee <- getsClient scondInMelee+  let condInMelee = fromMaybe (assert `failure` condInMelee)+                              (scondInMelee EM.! blid oldBody)+  mleader <- getsClient _sleader+  let !_A = assert (mleader /= Just oldAid) ()+  let side = bfid oldBody+      arena = blid oldBody+  fact <- getsState $ (EM.! side) . sfactionD+  let explore = void $ refreshTarget (oldAid, oldBody)+      setPath mtgt = case mtgt of+        Nothing -> return False+        Just TgtAndPath{tapTgt} -> do+          tap <- createPath oldAid tapTgt+          case tap of+            TgtAndPath{tapPath=NoPath} -> return False+            _ -> do+              modifyClient $ \cli ->+                cli {stargetD = EM.insert oldAid tap (stargetD cli)}+              return True+      follow = case mleader of+        -- If no leader at all (forced @TFollow@ tactic on an actor+        -- from a leaderless faction), fall back to @TExplore@.+        Nothing -> explore+        Just leader -> do+          onLevel <- getsState $ memActor leader arena+          -- If leader not on this level, fall back to @TExplore@.+          if not onLevel || condInMelee then explore+          else do+            -- Copy over the leader's target, if any, or follow his bpos.+            mtgt <- getsClient $ EM.lookup leader . stargetD+            tgtPathSet <- setPath mtgt+            let enemyPath = Just TgtAndPath{ tapTgt = TEnemy leader True+                                           , tapPath = NoPath }+            unless tgtPathSet $ do+               enemyPathSet <- setPath enemyPath+               unless enemyPathSet+                 -- If no path even to the leader himself, explore.+                 explore+  case ftactic $ gplayer fact of+    TExplore -> explore+    TFollow -> follow+    TFollowNoItems -> follow+    TMeleeAndRanged -> explore  -- needs to find ranged targets+    TMeleeAdjacent -> explore  -- probably not needed, but may change+    TBlock -> return ()  -- no point refreshing target+    TRoam -> explore  -- @TRoam@ is checked again inside @explore@+    TPatrol -> explore  -- WIP

− Game/LambdaHack/Client/AI/PickTargetClient.hs

@@ -1,371 +0,0 @@-{-# LANGUAGE TupleSections #-}--- | Let AI pick the best target for an actor.-module Game.LambdaHack.Client.AI.PickTargetClient-  ( targetStrategy, createPath-  ) where--import Control.Applicative-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.List-import Data.Maybe--import Game.LambdaHack.Client.AI.ConditionClient-import Game.LambdaHack.Client.AI.Preferences-import Game.LambdaHack.Client.AI.Strategy-import Game.LambdaHack.Client.Bfs-import Game.LambdaHack.Client.BfsClient-import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Frequency-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.RuleKind---- | AI proposes possible targets for the actor. Never empty.-targetStrategy :: forall m. MonadClient m-               => ActorId -> m (Strategy (Target, Maybe PathEtc))-targetStrategy aid = do-  cops@Kind.COps{corule, cotile=cotile@Kind.Ops{ouniqGroup}} <- getsState scops-  let stdRuleset = Kind.stdRuleset corule-      nearby = rnearby stdRuleset-  itemToF <- itemToFullClient-  modifyClient $ \cli -> cli { sbfsD = invalidateBfs aid (sbfsD cli)-                             , seps = seps cli + 773 }  -- randomize paths-  b <- getsState $ getActorBody aid-  activeItems <- activeItemsClient aid-  lvl@Level{lxsize, lysize} <- getLevel $ blid b-  let stepAccesible mtgt@(Just (_, (p : q : _ : _, _))) = -- goal not adjacent-        if accessible cops lvl p q then mtgt else Nothing-      stepAccesible mtgt = mtgt  -- goal can be inaccessible, e.g., suspect-  mtgtMPath <- getsClient $ EM.lookup aid . stargetD-  oldTgtUpdatedPath <- case mtgtMPath of-    Just (tgt, Nothing) ->-      -- This case is especially for TEnemyPos that would be lost otherwise.-      -- This is also triggered by @UpdLeadFaction@. The recreated path can be-      -- different than on the other client (AI or UI), but we don't care-      -- as long as the target stays the same at least for a moment.-      createPath aid tgt-    Just (tgt, Just path) -> do-      mvalidPos <- aidTgtToPos aid (blid b) (Just tgt)-      if isNothing mvalidPos then return Nothing  -- wrong level-      else return $! case path of-        (p : q : rest, (goal, len)) -> stepAccesible $-          if bpos b == p-          then Just (tgt, path)  -- no move last turn-          else if bpos b == q-               then Just (tgt, (q : rest, (goal, len - 1)))  -- step along path-               else Nothing  -- veered off the path-        ([p], (goal, _)) -> do-          let !_A = assert (p == goal `blame` (aid, b, mtgtMPath)) ()-          if bpos b == p then-            Just (tgt, path)  -- goal reached; stay there picking up items-          else-            Nothing  -- somebody pushed us off the goal; let's target again-        ([], _) -> assert `failure` (aid, b, mtgtMPath)-    Nothing -> return Nothing  -- no target assigned yet-  let !_A = assert (not $ bproj b) ()  -- would work, but is probably a bug-  fact <- getsState $ (EM.! bfid b) . sfactionD-  allFoes <- getsState $ actorRegularAssocs (isAtWar fact) (blid b)-  dungeon <- getsState sdungeon-  -- We assume the actor eventually becomes a leader (or has the same-  -- set of abilities as the leader, anyway) and set his target accordingly.-  let actorMaxSk = sumSkills activeItems-  actorMinSk <- getsState $ actorSkills Nothing aid activeItems-  condCanProject <- condCanProjectM True aid-  condHpTooLow <- condHpTooLowM aid-  condEnoughGear <- condEnoughGearM aid-  condMeleeBad <- condMeleeBadM aid-  let friendlyFid fid = fid == bfid b || isAllied fact fid-  friends <- getsState $ actorRegularList friendlyFid (blid b)-  -- TODO: refine all this when some actors specialize in ranged attacks-  -- (then we have to target, but keep the distance, we can do similarly for-  -- wounded or alone actors, perhaps only until they are shot first time,-  -- and only if they can shoot at the moment)-  canEscape <- factionCanEscape (bfid b)-  explored <- getsClient sexplored-  smellRadius <- sumOrganEqpClient IK.EqpSlotAddSmell aid-  let condNoUsableWeapon = all (not . isMelee) activeItems-      lidExplored = ES.member (blid b) explored-      allExplored = ES.size explored == EM.size dungeon-      canSmell = smellRadius > 0-      meleeNearby | canEscape = nearby `div` 2  -- not aggresive-                  | otherwise = nearby-      rangedNearby = 2 * meleeNearby-      -- Don't target nonmoving actors at all if bad melee,-      -- because nonmoving can't be lured nor ambushed.-      -- This is especially important for fences, tower defense actors, etc.-      -- If content gives nonmoving actor loot, this becomes problematic.-      targetableMelee aidE body = do-        activeItemsE <- activeItemsClient aidE-        let actorMaxSkE = sumSkills activeItemsE-            attacksFriends = any (adjacent (bpos body) . bpos) friends-            n = if attacksFriends then rangedNearby else meleeNearby-            nonmoving = EM.findWithDefault 0 AbMove actorMaxSkE <= 0-        return {-keep lazy-} $-           chessDist (bpos body) (bpos b) < n-           && not condNoUsableWeapon-           && EM.findWithDefault 0 AbMelee actorMaxSk > 0-           && not (hpTooLow b activeItems)-           && not (nonmoving && condMeleeBad)-      targetableRangedOrSpecial body =-        chessDist (bpos body) (bpos b) < rangedNearby-        && condCanProject-      targetableEnemy (aidE, body) = do-        tMelee <- targetableMelee aidE body-        return $! targetableRangedOrSpecial body || tMelee-  nearbyFoes <- filterM targetableEnemy allFoes-  let unknownId = ouniqGroup "unknown space"-      itemUsefulness itemFull =-        fst <$> totalUsefulness cops b activeItems fact itemFull-      desirableBag bag = any (\(iid, k) ->-        let itemFull = itemToF iid k-            use = itemUsefulness itemFull-        in desirableItem canEscape use itemFull) $ EM.assocs bag-      desirable (_, (_, Nothing)) = True-      desirable (_, (_, Just bag)) = desirableBag bag-      -- TODO: make more common when weak ranged foes preferred, etc.-      focused = bspeed b activeItems < speedNormal || condHpTooLow-      couldMoveLastTurn =-        let axtorSk = if (fst <$> gleader fact) == Just aid-                      then actorMaxSk-                      else actorMinSk-        in EM.findWithDefault 0 AbMove axtorSk > 0-      isStuck = waitedLastTurn b && couldMoveLastTurn-      slackTactic =-        ftactic (gplayer fact)-          `elem` [TMeleeAndRanged, TMeleeAdjacent, TBlock, TRoam, TPatrol]-      setPath :: Target -> m (Strategy (Target, Maybe PathEtc))-      setPath tgt = do-        mpath <- createPath aid tgt-        let take5 (TEnemy{}, pgl) =-              (tgt, Just pgl)  -- for projecting, even by roaming actors-            take5 (_, pgl@(path, (goal, _))) =-              if slackTactic then-                -- Best path only followed 5 moves; then straight on.-                let path5 = take 5 path-                    vtgt | bpos b == goal = tgt-                         | otherwise = TVector $ towards (bpos b) goal-                in (vtgt, Just (path5, (last path5, length path5 - 1)))-              else (tgt, Just pgl)-        return $! returN "setPath" $ maybe (tgt, Nothing) take5 mpath-      pickNewTarget :: m (Strategy (Target, Maybe PathEtc))-      pickNewTarget = do-        -- This is mostly lazy and used between 0 and 3 times below.-        ctriggers <- closestTriggers Nothing aid-        -- TODO: for foes, items, etc. consider a few nearby, not just one-        cfoes <- closestFoes nearbyFoes aid-        case cfoes of-          (_, (aid2, _)) : _ -> setPath $ TEnemy aid2 False-          [] -> do-            -- Tracking enemies is more important than exploring,-            -- and smelling actors are usually blind, so bad at exploring.-            -- TODO: prefer closer items to older smells-            smpos <- if canSmell-                     then closestSmell aid-                     else return []-            case smpos of-              [] -> do-                let ctriggersEarly =-                      if EM.findWithDefault 0 AbTrigger actorMaxSk > 0-                         && condEnoughGear-                      then ctriggers-                      else mzero-                if nullFreq ctriggersEarly then do-                  citems <--                    if EM.findWithDefault 0 AbMoveItem actorMaxSk > 0-                    then closestItems aid-                    else return []-                  case filter desirable citems of-                    [] -> do-                      let vToTgt v0 = do-                            let vFreq = toFreq "vFreq"-                                        $ (20, v0) : map (1,) moves-                            v <- rndToAction $ frequency vFreq-                            -- Items and smells, etc. considered every 7 moves.-                            let tra = trajectoryToPathBounded-                                        lxsize lysize (bpos b) (replicate 7 v)-                                path = nub $ bpos b : tra-                            return $! returN "tgt with no exploration"-                              ( TVector v-                              , if length path == 1-                                then Nothing-                                else Just (path, (last path, length path - 1)) )-                          oldpos = fromMaybe (Point 0 0) (boldpos b)-                          vOld = bpos b `vectorToFrom` oldpos-                          pNew = shiftBounded lxsize lysize (bpos b) vOld-                      if slackTactic && not isStuck-                         && isUnit vOld && bpos b /= pNew-                         && accessible cops lvl (bpos b) pNew-                      then vToTgt vOld-                      else do-                        upos <- if lidExplored-                                then return Nothing-                                else closestUnknown aid-                        case upos of-                          Nothing -> do-                            csuspect <- if lidExplored-                                        then return []-                                        else closestSuspect aid-                            case csuspect of-                              [] -> do-                                let ctriggersMiddle =-                                      if EM.findWithDefault 0 AbTrigger-                                                            actorMaxSk > 0-                                         && not allExplored-                                      then ctriggers-                                      else mzero-                                if nullFreq ctriggersMiddle then do-                                  -- All stones turned, time to win or die.-                                  afoes <- closestFoes allFoes aid-                                  case afoes of-                                    (_, (aid2, _)) : _ ->-                                      setPath $ TEnemy aid2 False-                                    [] ->-                                      if nullFreq ctriggers then do-                                        furthest <- furthestKnown aid-                                        setPath $ TPoint (blid b) furthest-                                      else do-                                        p <- rndToAction $ frequency ctriggers-                                        setPath $ TPoint (blid b) p-                                else do-                                  p <- rndToAction $ frequency ctriggers-                                  setPath $ TPoint (blid b) p-                              p : _ -> setPath $ TPoint (blid b) p-                          Just p -> setPath $ TPoint (blid b) p-                    (_, (p, _)) : _ -> setPath $ TPoint (blid b) p-                else do-                  p <- rndToAction $ frequency ctriggers-                  setPath $ TPoint (blid b) p-              (_, (p, _)) : _ -> setPath $ TPoint (blid b) p-      tellOthersNothingHere pos = do-        let f (tgt, _) = case tgt of-              TEnemyPos _ lid p _ -> p /= pos || lid /= blid b-              _ -> True-        modifyClient $ \cli -> cli {stargetD = EM.filter f (stargetD cli)}-        pickNewTarget-      updateTgt :: Target -> PathEtc-                -> m (Strategy (Target, Maybe PathEtc))-      updateTgt oldTgt updatedPath@(_, (_, len)) = case oldTgt of-        TEnemy a permit -> do-          body <- getsState $ getActorBody a-          if not focused  -- prefers closer foes-             && a `notElem` map fst nearbyFoes  -- old one not close enough-             || blid body /= blid b  -- wrong level-             || actorDying body  -- foe already dying-             || permit  -- never follow a friend more than 1 step-          then pickNewTarget-          else if bpos body == fst (snd updatedPath)-               then return $! returN "TEnemy" (oldTgt, Just updatedPath)-                      -- The enemy didn't move since the target acquired.-                      -- If any walls were added that make the enemy-                      -- unreachable, AI learns that the hard way,-                      -- as soon as it bumps into them.-               else do-                 let p = bpos body-                 (bfs, mpath) <- getCacheBfsAndPath aid p-                 case mpath of-                   Nothing -> pickNewTarget  -- enemy became unreachable-                   Just path ->-                      return $! returN "TEnemy"-                        (oldTgt, Just ( bpos b : path-                                      , (p, fromMaybe (assert `failure` mpath)-                                            $ accessBfs bfs p) ))-        TEnemyPos _ lid p permit-          -- Chase last position even if foe hides or dies,-          -- to find his companions, loot, etc.-          | lid /= blid b  -- wrong level-            || chessDist (bpos b) p >= nearby  -- too far and not visible-            || permit  -- never follow a friend more than 1 step-            -> pickNewTarget-          | p == bpos b -> tellOthersNothingHere p-          | otherwise ->-              return $! returN "TEnemyPos" (oldTgt, Just updatedPath)-        _ | not $ null nearbyFoes ->-          pickNewTarget  -- prefer close foes to anything-        TPoint lid pos -> do-          bag <- getsState $ getCBag $ CFloor lid pos-          let t = lvl `at` pos-          if lid /= blid b  -- wrong level-             -- Below we check the target could not be picked again in-             -- pickNewTarget, and only in this case it is invalidated.-             -- This ensures targets are eventually reached (unless a foe-             -- shows up) and not changed all the time mid-route-             -- to equally interesting, but perhaps a bit closer targets,-             -- most probably already targeted by other actors.-             ||-               (EM.findWithDefault 0 AbMoveItem actorMaxSk <= 0-                || not (desirableBag bag))  -- closestItems-               &&-               (pos == bpos b-                || (not canSmell  -- closestSmell-                    || let sml = EM.findWithDefault timeZero pos (lsmell lvl)-                       in sml <= ltime lvl)-                   && if not lidExplored-                      then t /= unknownId  -- closestUnknown-                           && not (Tile.isSuspect cotile t)  -- closestSuspect-                           && not (condEnoughGear && Tile.isStair cotile t)-                      else  -- closestTriggers-                        -- Try to kill that very last enemy for his loot before-                        -- leaving the level or dungeon.-                        not (null allFoes)-                        || -- If all explored, escape/block escapes.-                           (not (Tile.isEscape cotile t)-                            || not allExplored)-                           -- The next case is stairs in closestTriggers.-                           -- We don't determine if the stairs are interesting-                           -- (this changes with time), but allow the actor-                           -- to reach them and then retarget, unless he can't-                           -- trigger them at all.-                           && (EM.findWithDefault 0 AbTrigger actorMaxSk <= 0-                               || not (Tile.isStair cotile t))-                           -- The remaining case is furthestKnown. This is-                           -- always an unimportant target, so we forget it-                           -- if the actor is stuck (waits, though could move;-                           -- or has zeroed individual moving skill,-                           -- but then should change targets often anyway).-                           && (isStuck-                               || not allExplored))-          then pickNewTarget-          else return $! returN "TPoint" (oldTgt, Just updatedPath)-        TVector{} | len > 1 ->-          return $! returN "TVector" (oldTgt, Just updatedPath)-        TVector{} -> pickNewTarget-  case oldTgtUpdatedPath of-    Just (oldTgt, updatedPath) -> updateTgt oldTgt updatedPath-    Nothing -> pickNewTarget--createPath :: MonadClient m-           => ActorId -> Target -> m (Maybe (Target, PathEtc))-createPath aid tgt = do-  b <- getsState $ getActorBody aid-  mpos <- aidTgtToPos aid (blid b) (Just tgt)-  case mpos of-    Nothing -> return Nothing--- TODO: for now, an extra turn at target is needed, e.g., to pick up items---  Just p | p == bpos b -> return Nothing-    Just p -> do-      (bfs, mpath) <- getCacheBfsAndPath aid p-      return $! case mpath of-        Nothing -> Nothing-        Just path -> Just (tgt, ( bpos b : path-                                , (p, fromMaybe (assert `failure` mpath)-                                      $ accessBfs bfs p) ))

+ Game/LambdaHack/Client/AI/PickTargetM.hs view

@@ -0,0 +1,426 @@+{-# LANGUAGE TupleSections #-}+-- | Let AI pick the best target for an actor.+module Game.LambdaHack.Client.AI.PickTargetM+  ( refreshTarget+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , targetStrategy+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES++import Game.LambdaHack.Client.AI.ConditionM+import Game.LambdaHack.Client.AI.Strategy+import Game.LambdaHack.Client.Bfs+import Game.LambdaHack.Client.BfsM+import Game.LambdaHack.Client.CommonM+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Common.Ability+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Frequency+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Content.TileKind (isUknownSpace)++-- | Verify and possibly change the target of an actor. This function both+-- updates the target in the client state and returns the new target explicitly.+refreshTarget :: MonadClient m => (ActorId, Actor) -> m (Maybe TgtAndPath)+-- This inline speeds up execution by 6% and increases allocation by 9%,+-- despite probably bloating executable (but it slows down execution+-- if pickAI is not inlined):+{-# INLINE refreshTarget #-}+refreshTarget (aid, body) = do+  side <- getsClient sside+  let !_A = assert (bfid body == side+                    `blame` "AI tries to move an enemy actor"+                    `twith` (aid, body, side)) ()+  let !_A = assert (isNothing (btrajectory body) && not (bproj body)+                    `blame` "AI gets to manually move its projectiles"+                    `twith` (aid, body, side)) ()+  stratTarget <- targetStrategy aid+  if nullStrategy stratTarget then do+    -- Melee in progress and the actor can't contribute+    -- and would slow down others if he acted.+    modifyClient $ \cli -> cli {stargetD = EM.delete aid (stargetD cli)}+    return Nothing+  else do+    -- _debugoldTgt <- getsClient $ EM.lookup aid . stargetD+    -- Choose a target from those proposed by AI for the actor.+    tgtMPath <- rndToAction $ frequency $ bestVariant stratTarget+    modifyClient $ \cli ->+      cli {stargetD = EM.insert aid tgtMPath (stargetD cli)}+    return $ Just tgtMPath+    -- let _debug = T.unpack+    --       $ "\nHandleAI symbol:"    <+> tshow (bsymbol body)+    --       <> ", aid:"               <+> tshow aid+    --       <> ", pos:"               <+> tshow (bpos body)+    --       <> "\nHandleAI oldTgt:"   <+> tshow _debugoldTgt+    --       <> "\nHandleAI strTgt:"   <+> tshow stratTarget+    --       <> "\nHandleAI target:"   <+> tshow tgtMPath+    -- trace _debug $ return $ Just tgtMPath++-- | AI proposes possible targets for the actor. Never empty.+targetStrategy :: forall m. MonadClient m+               => ActorId -> m (Strategy TgtAndPath)+{-# INLINE targetStrategy #-}+targetStrategy aid = do+  Kind.COps{corule, coTileSpeedup} <- getsState scops+  b <- getsState $ getActorBody aid+  mleader <- getsClient _sleader+  scondInMelee <- getsClient scondInMelee+  salter <- getsClient salter+  -- We assume the actor eventually becomes a leader (or has the same+  -- set of abilities as the leader, anyway) and set his target accordingly.+  actorAspect <- getsClient sactorAspect+  let lalter = salter EM.! blid b+      condInMelee = fromMaybe (assert `failure` condInMelee)+                              (scondInMelee EM.! blid b)+      stdRuleset = Kind.stdRuleset corule+      nearby = rnearby stdRuleset+      ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect)+      actorMaxSk = aSkills ar+      alterSkill = EM.findWithDefault 0 AbAlter actorMaxSk+  lvl@Level{lxsize, lysize} <- getLevel $ blid b+  let stepAccesible :: AndPath -> Bool+      stepAccesible AndPath{pathList=q : _} =+        -- Effectively, only @alterMinWalk@ is checked, because real altering+        -- is not done via target path, but action after end of path.+        alterSkill >= fromEnum (lalter PointArray.! q)+      stepAccesible _ = False+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  oldTgtUpdatedPath <- case mtgtMPath of+    Just TgtAndPath{tapTgt,tapPath=NoPath} ->+      -- This case is especially for TEnemyPos that would be lost otherwise.+      -- This is also triggered by @UpdLeadFaction@.+      Just <$> createPath aid tapTgt+    Just tap@TgtAndPath{..} -> do+      mvalidPos <- aidTgtToPos aid (blid b) tapTgt+      if | isNothing mvalidPos -> return Nothing  -- wrong level+         | bpos b == pathGoal tapPath ->+             return mtgtMPath  -- goal reached; stay there picking up items+         | otherwise -> return $! case tapPath of+             AndPath{pathList=q : rest,..} -> case chessDist (bpos b) q of+               0 ->  -- step along path+                 let newPath = AndPath{ pathList = rest+                                      , pathGoal+                                      , pathLen = pathLen - 1 }+                 in if stepAccesible newPath+                    then Just tap{tapPath=newPath}+                    else Nothing+               1 ->  -- no move or a sidestep last turn+                 if stepAccesible tapPath+                 then mtgtMPath+                 else Nothing+               _ -> Nothing  -- veered off the path+             AndPath{pathList=[],..}->+               Nothing  -- path to the goal was partial; let's target again+             NoPath -> assert `failure` ()+    Nothing -> return Nothing  -- no target assigned yet+  fact <- getsState $ (EM.! bfid b) . sfactionD+  allFoes <- getsState $ actorRegularAssocs (isAtWar fact) (blid b)+  dungeon <- getsState sdungeon+  let canMove = EM.findWithDefault 0 AbMove actorMaxSk > 0+                || EM.findWithDefault 0 AbDisplace actorMaxSk > 0+                -- Needed for now, because AI targets and shoots enemies+                -- based on the path to them, not LOS to them:+                || EM.findWithDefault 0 AbProject actorMaxSk > 0+  actorMinSk <- getsState $ actorSkills Nothing aid ar+  condCanProject <-+    condCanProjectM (EM.findWithDefault 0 AbProject actorMaxSk) aid+  condEnoughGear <- condEnoughGearM aid+  let condCanMelee = actorCanMelee actorAspect aid b+      condHpTooLow = hpTooLow b ar+  friends <- getsState $ friendlyActorRegularList (bfid b) (blid b)+  let canEscape = fcanEscape (gplayer fact)+      canSmell = aSmell ar > 0+      meleeNearby | canEscape = nearby `div` 2+                  | otherwise = nearby+      rangedNearby = 2 * meleeNearby+      -- Don't melee-target nonmoving actors, unless they attack ours,+      -- because nonmoving can't be lured nor ambushed nor can't chase.+      -- This is especially important for fences, tower defense actors, etc.+      -- If content gives nonmoving actor loot, this becomes problematic.+      targetableMelee aidE body = do+        actorMaxSkE <- maxActorSkillsClient aidE+        let attacksFriends = any (adjacent (bpos body) . bpos) friends+            -- 3 is+            -- 1 from condSupport1+            -- + 2 from foe being 2 away from friend before he closed in+            -- + 1 for as a margin for ambush, given than actors exploring+            -- can't physically keep adjacent all the time+            n | condInMelee = if attacksFriends then 4 else 0+              | otherwise = meleeNearby+            nonmoving = EM.findWithDefault 0 AbMove actorMaxSkE <= 0+        return {-keep lazy-} $+          case chessDist (bpos body) (bpos b) of+            1 -> True  -- if adjacent, target even if can't melee, to flee+            cd -> condCanMelee && cd <= n && (not nonmoving || attacksFriends)+      -- Even when missiles run out, the non-moving foe will still be+      -- targeted, which is fine, since he is weakened by ranged, so should be+      -- meleed ASAP, even if without friends.+      targetableRanged body =+        not condInMelee+        && chessDist (bpos body) (bpos b) < rangedNearby+        && condCanProject+      targetableEnemy (aidE, body) = do+        tMelee <- targetableMelee aidE body+        return $! targetableRanged body || tMelee+  nearbyFoes <- filterM targetableEnemy allFoes+  explored <- getsClient sexplored+  isStairPos <- getsState $ \s lid p -> isStair lid p s+  discoBenefit <- getsClient sdiscoBenefit+  s <- getState+  let lidExplored = ES.member (blid b) explored+      desirableBagFloor bag = any (\iid ->+        let item = getItemBody iid s+            benPick = benPickup <$> EM.lookup iid discoBenefit+        in desirableItem canEscape benPick item) $ EM.keys bag+      desirableFloor (_, (_, bag)) = desirableBagFloor bag+      focused = bspeed b ar < speedWalk || condHpTooLow+      couldMoveLastTurn =+        let actorSk = if mleader == Just aid then actorMaxSk else actorMinSk+        in EM.findWithDefault 0 AbMove actorSk > 0+      isStuck = waitedLastTurn b && couldMoveLastTurn+      slackTactic =+        ftactic (gplayer fact)+          `elem` [TMeleeAndRanged, TMeleeAdjacent, TBlock, TRoam, TPatrol]+      setPath :: Target -> m (Strategy TgtAndPath)+      setPath tgt = do+        let take7 tap@TgtAndPath{tapTgt=TEnemy{}} =+              tap  -- @TEnemy@ needed for projecting, even by roaming actors+            take7 tap@TgtAndPath{tapTgt,tapPath=AndPath{..}} =+              if slackTactic then+                -- Best path only followed 7 moves; then straight on. Cheaper.+                let path7 = take 7 pathList+                    vtgt | bpos b == pathGoal = tapTgt  -- goal reached+                         | otherwise = TVector $ towards (bpos b) pathGoal+                in TgtAndPath{tapTgt=vtgt, tapPath=AndPath{pathList=path7, ..}}+              else tap+            take7 tap = tap+        tgtpath <- createPath aid tgt+        return $! returN "setPath" $ take7 tgtpath+      pickNewTarget :: m (Strategy TgtAndPath)+      pickNewTarget = do+        cfoes <- closestFoes nearbyFoes aid+        case cfoes of+          (_, (aid2, _)) : _ -> setPath $ TEnemy aid2 False+          [] | condInMelee -> return reject  -- don't slow down fighters+            -- this looks a bit strange, because teammates stop in their tracks+            -- all around the map (unless very close to the combatant),+            -- but the intuition is, not being able to help immediately,+            -- and not being too friendly to each other, they just wait and see+            -- and also shout to the teammate to flee and lure foes into ambush+          [] -> do+            -- Tracking enemies is more important than exploring,+            -- and smelling actors are usually blind, so bad at exploring.+            smpos <- if canSmell+                     then closestSmell aid+                     else return []+            case smpos of+              [] -> do+                citemsRaw <- closestItems aid+                let citems = toFreq "closestItems"+                             $ filter desirableFloor citemsRaw+                if nullFreq citems then do+                  -- This is mostly lazy and referred to a few times below.+                  ctriggersRaw <- closestTriggers ViaAnything aid+                  let ctriggers = toFreq "closestTriggers" ctriggersRaw+                  if nullFreq ctriggers then do+                      let vToTgt v0 = do+                            let vFreq = toFreq "vFreq"+                                        $ (20, v0) : map (1,) moves+                            v <- rndToAction $ frequency vFreq+                            -- Items and smells, etc. considered every 7 moves.+                            let pathSource = bpos b+                                tra = trajectoryToPathBounded+                                        lxsize lysize pathSource (replicate 7 v)+                                pathList = nub tra+                                pathGoal = last pathList+                                pathLen = length pathList+                            return $! returN "tgt with no exploration"+                              TgtAndPath+                                { tapTgt = TVector v+                                , tapPath = if pathLen == 0+                                            then NoPath+                                            else AndPath{..} }+                          oldpos = fromMaybe originPoint (boldpos b)+                          vOld = bpos b `vectorToFrom` oldpos+                          pNew = shiftBounded lxsize lysize (bpos b) vOld+                      if slackTactic && not isStuck+                         && isUnit vOld && bpos b /= pNew+                         && Tile.isWalkable coTileSpeedup (lvl `at` pNew)+                              -- if initial altering, consider carefully below+                      then vToTgt vOld+                      else do+                        upos <- if lidExplored+                                then return Nothing+                                else closestUnknown aid -- modifies sexplored+                        case upos of+                          Nothing -> do+                            explored2 <- getsClient sexplored+                            let allExplored2 = ES.size explored2+                                               == EM.size dungeon+                            if allExplored2 || nullFreq ctriggers then do+                              -- All stones turned, time to win or die.+                              afoes <- closestFoes allFoes aid+                              case afoes of+                                (_, (aid2, _)) : _ ->+                                  setPath $ TEnemy aid2 False+                                [] ->+                                  if nullFreq ctriggers then do+                                    furthest <- furthestKnown aid+                                    setPath $ TPoint TKnown (blid b) furthest+                                  else do+                                    (p, (p0, bag)) <-+                                      rndToAction $ frequency ctriggers+                                    setPath $ TPoint (TEmbed bag p0) (blid b) p+                            else do+                              (p, (p0, bag)) <-+                                rndToAction $ frequency ctriggers+                              setPath $ TPoint (TEmbed bag p0) (blid b) p+                          Just p -> setPath $ TPoint TUnknown (blid b) p+                  else do+                    (p, (p0, bag)) <- rndToAction $ frequency ctriggers+                    setPath $ TPoint (TEmbed bag p0) (blid b) p+                else do+                  (p, bag) <- rndToAction $ frequency citems+                  setPath $ TPoint (TItem bag) (blid b) p+              (_, (p, _)) : _ -> setPath $ TPoint TSmell (blid b) p+      tellOthersNothingHere pos = do+        let f TgtAndPath{tapTgt} = case tapTgt of+              TPoint _ lid p -> p /= pos || lid /= blid b+              _ -> True+        modifyClient $ \cli -> cli {stargetD = EM.filter f (stargetD cli)}+        pickNewTarget+      tileAdj :: (Point -> Bool) -> Point -> Bool+      tileAdj f p = any f $ vicinityUnsafe p+      updateTgt :: TgtAndPath -> m (Strategy TgtAndPath)+      updateTgt TgtAndPath{tapPath=NoPath} = pickNewTarget+      updateTgt tap@TgtAndPath{tapPath=AndPath{..},tapTgt} = case tapTgt of+        TEnemy a permit -> do+          body <- getsState $ getActorBody a+          if | (condInMelee || not focused)  -- prefers closer foes+               && a `notElem` map fst nearbyFoes  -- old one not close enough+               || blid body /= blid b  -- wrong level+               || actorDying body  -- foe already dying+               || permit+                  && (condInMelee  -- in melee, stop following+                      || mleader == Just aid) ->  -- a leader, never follow+               pickNewTarget+             | bpos body == pathGoal ->+               return $! returN "TEnemy" tap+                 -- The enemy didn't move since the target acquired.+                 -- If any walls were added that make the enemy+                 -- unreachable, AI learns that the hard way,+                 -- as soon as it bumps into them.+             | otherwise -> do+               -- If there are no unwalkable tiles on the path to enemy,+               -- he gets target @TEnemy@ and then, even if such tiles emerge,+               -- the target updated by his moves remains @TEnemy@.+               -- Conversely, he is stuck with @TKnown@ if initial target had+               -- unwalkable tiles, for as long as they remain. Harmless quirk.+               mpath <- getCachePath aid $ bpos body+               case mpath of+                 NoPath -> pickNewTarget  -- enemy became unreachable+                 AndPath{pathLen=0} -> pickNewTarget  -- he is his own enemy+                 AndPath{} -> return $! returN "TEnemy" tap{tapPath=mpath}+          -- In this case, need to retarget, to focus on foes that melee ours+          -- and not, e.g., on remembered foes or items.+        _ | condInMelee -> pickNewTarget+        TPoint _ lid _ | lid /= blid b -> pickNewTarget  -- wrong level+        TPoint tgoal lid pos -> case tgoal of+          _ | not $ null nearbyFoes ->+            pickNewTarget  -- prefer close foes to anything else+          TEnemyPos _ permit  -- chase last position even if foe hides+            | bpos b == pos -> tellOthersNothingHere pos+            | permit+              && (condInMelee  -- in melee, stop following+                  || mleader == Just aid) ->  -- a leader, never follow+              pickNewTarget  -- melee, stop following+            | otherwise -> return $! returN "TEnemyPos" tap+          -- Below we check the target could not be picked again in+          -- pickNewTarget (e.g., an item got picked up by our teammate)+          -- and only in this case it is invalidated.+          -- This ensures targets are eventually reached (unless a foe+          -- shows up) and not changed all the time mid-route+          -- to equally interesting, but perhaps a bit closer targets,+          -- most probably already targeted by other actors.+          TEmbed bag p -> assert (adjacent pos p) $ do+            -- First, stairs and embedded items from @closestTriggers@.+            -- We don't check skills, because they normally don't change+            -- or we can put some equipment back and recover them.+            -- We don't determine if the stairs or embed are interesting+            -- (this changes with time), but allow the actor+            -- to reach them and then retarget. The two things we check+            -- is whether the embedded bag is still there, or used up+            -- and whether we happen to be already adjacent to @p@,+            -- even though not necessarily at @pos@.+            bag2 <- getsState $ getEmbedBag lid p  -- not @pos@+            if | bag /= bag2 -> pickNewTarget  -- others will notice soon enough+               | adjacent (bpos b) p ->  -- regardless if at @pos@ or not+                   setPath $ TPoint TAny lid (bpos b)+                     -- stay there one turn (high chance to become leader)+                     -- to enable triggering; if trigger fails+                     -- (e.g, changed skills), will retarget next turn (@TAny@)+               | otherwise -> return $! returN "TEmbed" tap+          TItem bag -> do+            bag2 <- getsState $ getFloorBag lid pos+            if | bag /= bag2 -> pickNewTarget  -- others will notice soon enough+               | bpos b == pos ->+                   setPath $ TPoint TAny lid (bpos b)+                     -- stay there one turn (high chance to become leader)+                     -- to enable pickup; if pickup fails, will retarget+               | otherwise -> return $! returN "TItem" tap+          TSmell ->+            if not canSmell+               || let sml = EM.findWithDefault timeZero pos (lsmell lvl)+                  in sml <= ltime lvl+            then pickNewTarget  -- others will notice soon enough+            else return $! returN "TSmell" tap+          TUnknown ->+            let t = lvl `at` pos+            in if lidExplored+                  || not (isUknownSpace t)+                  || condEnoughGear && tileAdj (isStairPos lid) pos+                       -- the unknown may be on the other side of the level+                       -- and getting there only to explore 1 tile and get back+                       -- looks silly+               then pickNewTarget  -- others will notice soon enough+               else return $! returN "TUnknown" tap+          TKnown ->+            if bpos b == pos+               || isStuck+               || alterSkill < fromEnum (lalter PointArray.! pos)+                    -- tile was searched or altered or skill lowered+            then pickNewTarget  -- others unconcerned+            else return $! returN "TKnown" tap+          TAny -> pickNewTarget  -- reset elsewhere or carried over from UI+        TVector{} -> if pathLen > 1+                     then return $! returN "TVector" tap+                     else pickNewTarget+  if canMove+  then case oldTgtUpdatedPath of+    Nothing -> pickNewTarget+    Just tap -> updateTgt tap+  else return $! returN "NoMove" $ TgtAndPath (TEnemy aid True) NoPath

− Game/LambdaHack/Client/AI/Preferences.hs

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

Game/LambdaHack/Client/AI/Strategy.hs view

@@ -6,22 +6,20 @@   , (.|), reject, (.=>), only, bestVariant, renameStrategy, returN, mapStrategyM   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Control.Applicative-import Control.Monad-import Data.Foldable (Foldable)-import Data.Maybe-import Data.Text (Text)-import Data.Traversable (Traversable)  import Game.LambdaHack.Common.Frequency as Frequency-import Game.LambdaHack.Common.Msg  -- | A strategy is a choice of (non-empty) frequency tables -- of possible actions. newtype Strategy a = Strategy { runStrategy :: [Frequency a] }   deriving (Show, Foldable, Traversable) --- | Strategy is a monad. TODO: Can we write this as a monad transformer?+-- | Strategy is a monad. instance Monad Strategy where   {-# INLINE return #-}   return x = Strategy $ return $! uniformFreq "Strategy_return" [x]@@ -43,7 +41,6 @@  instance MonadPlus Strategy where   mzero = Strategy []-  {-# INLINE mplus #-}   mplus (Strategy xs) (Strategy ys) = Strategy (xs ++ ys)  instance Alternative Strategy where@@ -100,7 +97,6 @@ returN :: Text -> a -> Strategy a returN name x = Strategy $ return $! uniformFreq name [x] --- TODO: express with traverse? mapStrategyM :: Monad m => (a -> m (Maybe b)) -> Strategy a -> m (Strategy b) mapStrategyM f s = do   let mapFreq freq = do

Game/LambdaHack/Client/Bfs.hs view

@@ -1,30 +1,34 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} -- | Breadth first search algorithms. module Game.LambdaHack.Client.Bfs-  ( BfsDistance, MoveLegal(..), apartBfs-  , fillBfs, findPathBfs, accessBfs+  ( BfsDistance, MoveLegal(..), minKnownBfs, apartBfs, fillBfs+  , AndPath(..), findPathBfs+  , accessBfs #ifdef EXPOSE_INTERNAL     -- * Internal operations-  , minKnownBfs #endif   ) where -import Control.Exception.Assert.Sugar+import Prelude ()++import Game.LambdaHack.Common.Prelude++import Control.Monad.ST.Strict import Data.Binary import Data.Bits (Bits, complement, (.&.), (.|.))-import Data.List-import Data.Maybe+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as VM+import GHC.Generics (Generic)  import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.Vector  -- | Weighted distance between points along shortest paths.-newtype BfsDistance = BfsDistance Word8+newtype BfsDistance = BfsDistance {bfsDistance :: Word8}   deriving (Show, Eq, Ord, Enum, Bounded, Bits)  -- | State of legality of moves between adjacent points.-data MoveLegal = MoveBlocked | MoveToOpen | MoveToUnknown+data MoveLegal = MoveBlocked | MoveToOpen | MoveToClosed | MoveToUnknown   deriving Eq  -- | The minimal distance value assigned to paths that don't enter@@ -32,130 +36,204 @@ minKnownBfs :: BfsDistance minKnownBfs = toEnum $ (1 + fromEnum (maxBound :: BfsDistance)) `div` 2 --- | The distance value that denote no legal path between points.--- The next value is the minimal distance value assigned to paths--- that don't enter any unknown tiles.+-- | The distance value that denotes no legal path between points,+-- either due to blocked tiles or pathfinding aborted at earlier tiles,+-- e.g., due to unknown tiles. apartBfs :: BfsDistance apartBfs = pred minKnownBfs --- TODO: costly; use a ring buffer instead of the lists, don't call so often+-- | The distance value that denotes that path search was aborted+-- at this tile due to too large actual distance+-- and that the tile was known and not blocked.+-- It is also a true distance value for this tile+-- (shifted by minKnownBfs, as all distances of known tiles).+abortedKnownBfs :: BfsDistance+abortedKnownBfs = pred maxBound++-- | The distance value that denotes that path search was aborted+-- at this tile due to too large actual distance+-- and that the tile was unknown.+-- It is also a true distance value for this tile.+abortedUnknownBfs :: BfsDistance+abortedUnknownBfs = pred apartBfs++type PointI = Int++type VectorI = Int+ -- | Fill out the given BFS array. -- Unsafe @PointArray@ operations are OK here, because the intermediate -- values of the vector don't leak anywhere outside nor are kept unevaluated -- and so they can't be overwritten by the unsafe side-effect.-fillBfs :: (Point -> Point -> MoveLegal)  -- ^ is a move from known tile legal-        -> (Point -> Point -> Bool)       -- ^ is a move from unknown legal+--+-- When computing move cost, we assume doors openable at no cost,+-- because other actors use them, too, so the cost is shared and the extra+-- visiblity is valuable, too. We treat unknown tiles specially.+-- Whether suspect tiles are considered openable depends on @smarkSuspect@.+fillBfs :: PointArray.Array Word8+        -> Word8         -> 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 maxKnownBfs = pred maxBound-      predMaxKnownBfs = pred maxKnownBfs-      bfs :: BfsDistance-          -> [Point]-          -> [Point]-          -> PointArray.Array BfsDistance-          -> PointArray.Array BfsDistance-      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 = PointArray.unsafeUpdateA a2 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 = PointArray.unsafeUpdateA a2 upd-              in (mvsU ++ succU2, a3)-            (succU4, !a4) = foldl' processUnknown ([], a) predU-            (succK6, succU6, !a6) = foldl' processKnown ([], succU4, a4) predK-        in if null succK6 && null succU6  -- no more dungeon positions to check-              || distance == predMaxKnownBfs  -- wasting one Known slot-           then a6  -- too far-           else bfs (succ distance) succK6 succU6 a6-  in bfs (succ minKnownBfs) [origin] []-         (PointArray.unsafeUpdateA aInitial [(origin, minKnownBfs)])+fillBfs lalter alterSkill source arr@PointArray.Array{..} =+  let vToI (x, y) = PointArray.pindex axsize (Point x y)+      movesI :: [VectorI]+      movesI = map vToI+        [(-1, -1), (0, -1), (1, -1), (1, 0), (1, 1), (0, 1), (-1, 1), (-1, 0)]+      unsafeWriteI :: Int -> BfsDistance -> ()+      {-# INLINE unsafeWriteI #-}+      unsafeWriteI p c = runST $ do+        vThawed <- U.unsafeThaw avector+        VM.unsafeWrite vThawed p (bfsDistance c)+        void $ U.unsafeFreeze vThawed+      bfs :: BfsDistance -> [PointI] -> ()  -- modifies the vector+      bfs !distance !predK =+        let processKnown :: PointI -> [PointI] -> [PointI]+            processKnown !pos !succK2 =+              -- Terrible hack trigger warning!+              -- Unsafe ops inside @fKnown@ seem to be OK, for no particularly+              -- clear reason. The array value given to each p depends on+              -- array value only at p (it's not overwritten if already there).+              -- So the only problem with the unsafe ops writing at p is+              -- if one with higher depth (dist) is evaluated earlier+              -- than another with lower depth. The particular pattern of+              -- laziness and order of list elements below somehow+              -- esures the lowest possible depth is always written first.+              -- The code also doesn't keep a wholly evaluated list of all p+              -- at a given depth, but generates them on demand, unlike a fully+              -- strict version inside the ST monad. So it uses little memory+              -- and is fast.+              let fKnown :: [PointI] -> VectorI -> [PointI]+                  fKnown !l !move =+                    let !p = pos + move+                        visitedMove =+                          BfsDistance (arr `PointArray.accessI` p) /= apartBfs+                    in if visitedMove+                       then l+                       else let alter :: Word8+                                !alter = lalter `PointArray.accessI` p+                            in if | alterSkill < alter -> l+                                  | alter == 1 ->+                                      let distCompl =+                                            distance .&. complement minKnownBfs+                                      in unsafeWriteI p distCompl+                                         `seq` l+                                  | otherwise -> unsafeWriteI p distance+                                                 `seq` p : l+              in foldl' fKnown succK2 movesI+            succK4 = foldr processKnown [] predK+        in if null succK4 || distance == abortedKnownBfs+           then () -- no more dungeon positions to check, or we delved too deep+           else bfs (succ distance) succK4+  in bfs (succ minKnownBfs) [PointArray.pindex axsize source] --- TODO: Use http://harablog.wordpress.com/2011/09/07/jump-point-search/--- to determine a few really different paths and compare them,--- e.g., how many closed doors they pass, open doors, unknown tiles--- on the path or close enough to reveal them.--- Also, check if JPS can somehow optimize BFS or pathBfs.+data AndPath =+    AndPath { pathList :: ![Point]+            , pathGoal :: !Point    -- needn't be @last pathList@+            , pathLen  :: !Int      -- needn't be @length pathList@+            }+  | NoPath+  deriving (Show, Generic)++instance Binary AndPath+ -- | Find a path, without the source position, with the smallest length.--- The @eps@ coefficient determines which direction (or the closest+-- The @eps@ coefficient determines which direction (of the closest -- directions available) that path should prefer, where 0 means north-west -- and 1 means north.-findPathBfs :: (Point -> Point -> MoveLegal)-            -> (Point -> Point -> Bool)-            -> Point -> Point -> Int -> PointArray.Array BfsDistance-            -> Maybe [Point]+findPathBfs :: PointArray.Array Word8 -> (Point -> Bool)+            -> Point -> Point -> Int+            -> PointArray.Array BfsDistance+            -> AndPath {-# INLINE findPathBfs #-}-findPathBfs isEnterable passUnknown source target sepsRaw bfs =-  assert (bfs PointArray.! source == minKnownBfs) $-  let targetDist = bfs PointArray.! target-  in if targetDist == apartBfs-     then Nothing-     else-       let eps = sepsRaw `mod` 4-           (mc1, mc2) = splitAt eps movesCardinal-           (md1, md2) = splitAt eps movesDiagonal-           preferredMoves = mc1 ++ reverse mc2 ++ md2 ++ reverse md1  -- fuzz-           track :: Point -> BfsDistance -> [Point] -> [Point]-           track pos oldDist suffix | oldDist == minKnownBfs =-             assert (pos == source-                     `blame` (source, target, pos, suffix)) suffix-           track pos oldDist suffix | oldDist > minKnownBfs =-             let dist = pred oldDist-                 children = map (shift pos) preferredMoves-                 matchesDist p = bfs PointArray.! p == dist-                                 && isEnterable p pos == MoveToOpen-                 minP = fromMaybe (assert `failure` (pos, oldDist, children))-                                  (find matchesDist children)-             in track minP dist (pos : suffix)-           track pos oldDist suffix =-             let distUnknown = pred oldDist-                 distKnown = distUnknown .|. minKnownBfs-                 children = map (shift pos) preferredMoves-                 matchesDistUnknown p = bfs PointArray.! p == distUnknown-                                        && passUnknown p pos-                 matchesDistKnown p = bfs PointArray.! p == distKnown-                                      && isEnterable p pos == MoveToUnknown-                 (minP, dist) = case find matchesDistKnown children of-                   Just p -> (p, distKnown)-                   Nothing -> case find matchesDistUnknown children of-                     Just p -> (p, distUnknown)-                     Nothing -> assert `failure` (pos, oldDist, children)-             in track minP dist (pos : suffix)-       in Just $ track target targetDist []+findPathBfs lalter fovLit pathSource pathGoal sepsRaw+            arr@PointArray.Array{..} =+  let !pathGoalI = PointArray.pindex axsize pathGoal+      !pathSourceI = PointArray.pindex axsize pathSource+      eps = sepsRaw `mod` 4+      (mc1, mc2) = splitAt eps [(0, -1), (1, 0), (0, 1), (-1, 0)]+      (md1, md2) = splitAt eps [(-1, -1), (1, -1), (1, 1), (-1, 1)]+      -- Prefer cardinal directions when closer to the target, so that+      -- the enemy can't easily disengage (open/unknown below overrides that).+      prefMoves = mc1 ++ reverse mc2 ++ md2 ++ reverse md1  -- fuzz+      vToI (x, y) = PointArray.pindex axsize (Point x y)+      movesI :: [VectorI]+      movesI = map vToI prefMoves+      track :: PointI -> BfsDistance -> [Point] -> [Point]+      track !pos !oldDist !suffix | oldDist == minKnownBfs =+        assert (pos == pathSourceI) suffix+      track pos oldDist suffix | oldDist == succ minKnownBfs =+        let !posP = PointArray.punindex axsize pos+        in posP : suffix  -- avoid calculating minP and dist for the last call+      track pos oldDist suffix =+        let !dist = pred oldDist+            minChild !minP _ _ [] = minP+            minChild minP maxDark minAlter (mv : mvs) =+              let !p = pos + mv+                  backtrackingMove =+                    BfsDistance (arr `PointArray.accessI` p) /= dist+              in if backtrackingMove+                 then minChild minP maxDark minAlter mvs+                 else let alter = lalter `PointArray.accessI` p+                          dark = not $ fovLit $ PointArray.punindex axsize p+                      -- Prefer paths through more easily opened tiles+                      -- and, secondly, in the ambient dark (even if light+                      -- carried, because it can be taken off at any moment).+                      in if | alter == 0 && dark -> p  -- speedup+                            | alter < minAlter -> minChild p dark alter mvs+                            | dark > maxDark && alter == minAlter ->+                              minChild p dark alter mvs+                            | otherwise -> minChild minP maxDark minAlter mvs+            -- @maxBound@ means not alterable, so some child will be lower+            !newPos = minChild pos{-dummy-} False maxBound movesI+#ifdef WITH_EXPENSIVE_ASSERTIONS+            !_A = assert (newPos /= pos) ()+#endif+            !posP = PointArray.punindex axsize pos+        in track newPos dist (posP : suffix)+      !goalDist = BfsDistance $ arr `PointArray.accessI` pathGoalI+      pathLen = fromEnum $ goalDist .&. complement minKnownBfs+      pathList = track pathGoalI (goalDist .|. minKnownBfs) []+      andPath = AndPath{..}+  in assert (BfsDistance (arr `PointArray.accessI` pathSourceI)+             == minKnownBfs) $+     if goalDist /= apartBfs && pathLen < 2 * chessDist pathSource pathGoal+     then andPath+     else let f :: (Point, Int, Int, Int) -> Point -> BfsDistance+                -> (Point, Int, Int, Int)+              f acc@(pAcc, dAcc, chessAcc, sumAcc) p d =+                if d <= abortedUnknownBfs  -- works in visible secrets mode only+                   || d /= apartBfs && adjacent p pathGoal  -- works for stairs+                then let dist = fromEnum $ d .&. complement minKnownBfs+                         chessNew = chessDist p pathGoal+                         sumNew = dist + 2 * chessNew+                         resNew = (p, dist, chessNew, sumNew)+                     in case compare sumNew sumAcc of+                       LT -> resNew+                       EQ -> case compare chessNew chessAcc of+                         LT -> resNew+                         EQ -> case compare dist dAcc of+                           LT -> resNew+                           EQ | euclidDistSq p pathGoal+                                < euclidDistSq pAcc pathGoal -> resNew+                           _ -> acc+                         _ -> acc+                       _ -> acc+                else acc+              initAcc = (originPoint, maxBound, maxBound, maxBound)+              (pRes, dRes, _, sumRes) = PointArray.ifoldlA' f initAcc arr+          in if sumRes == maxBound+                || goalDist /= apartBfs && pathLen < sumRes+             then if goalDist /= apartBfs then andPath else NoPath+             else let pathList2 = track (PointArray.pindex axsize pRes)+                                        (toEnum dRes .|. minKnownBfs) []+                  in AndPath{pathList = pathList2, pathLen = sumRes, ..}  -- | Access a BFS array and interpret the looked up distance value. accessBfs :: PointArray.Array BfsDistance -> Point -> Maybe Int-{-# INLINE accessBfs #-}-accessBfs bfs target =-  let dist = bfs PointArray.! target+accessBfs bfs p =+  let dist = bfs PointArray.! p   in if dist == apartBfs      then Nothing      else Just $ fromEnum $ dist .&. complement minKnownBfs

− Game/LambdaHack/Client/BfsClient.hs

@@ -1,368 +0,0 @@-{-# LANGUAGE CPP, TupleSections #-}--- | Breadth first search and realted algorithms using the client monad.-module Game.LambdaHack.Client.BfsClient-  ( invalidateBfs, getCacheBfsAndPath, getCacheBfs, accessCacheBfs-  , unexploredDepth, closestUnknown, closestSuspect, closestSmell, furthestKnown-  , closestTriggers, closestItems, closestFoes-  ) where--import Control.Applicative-import Control.Arrow ((&&&))-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.List-import Data.Maybe-import Data.Ord--import Game.LambdaHack.Client.Bfs-import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import qualified Game.LambdaHack.Common.Ability as Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Frequency-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Point-import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.TileKind (TileKind)--invalidateBfs :: ActorId-              -> EM.EnumMap ActorId-                   ( Bool, PointArray.Array BfsDistance-                   , Point, Int, Maybe [Point])-              -> EM.EnumMap ActorId-                   ( Bool, PointArray.Array BfsDistance-                   , Point, Int, Maybe [Point])-invalidateBfs =-  EM.adjust-    (\(_, bfs, target, seps, mpath) -> (False, bfs, target, seps, mpath))---- | Get cached BFS data and path or, if not stored, generate,--- store and return. Due to laziness, they are not calculated until needed.-getCacheBfsAndPath :: forall m. MonadClient m-                   => ActorId -> Point-                   -> 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-        let mpath = findPathBfs isEnterable passUnknown origin target seps bfs-        modifyClient $ \cli ->-          cli {sbfsD = EM.insert aid (True, bfs, target, seps, mpath)-                                 (sbfsD cli)}-        return (bfs, mpath)-  mbfs <- getsClient $ EM.lookup aid . sbfsD-  -- TODO: record past skills too, in case mobility lost; but no great harm,-  -- perhaps the loss is temporary-  case mbfs of-    Just (True, bfs, targetOld, sepsOld, mpath)-      -- TODO: hack: in screensavers this is not always ensured, so check here:-      | bfs PointArray.! bpos b == succ apartBfs ->-      if targetOld == target && sepsOld == seps-      then return (bfs, mpath)-      else pathAndStore bfs-    _ -> do-      -- Reduce the number of pointers to @bfsInvalid@, to help @safeSetA@.-      modifyClient $ \cli -> cli {sbfsD = EM.delete aid $ sbfsD cli}-      Level{lxsize, lysize} <- getLevel $ blid b-      let vInitial = case mbfs of-            Just (_, bfsInvalid, _, _, _) ->  -- TODO: we should verify size-              -- We need to use the safe set, because previous values-              -- of the BFS array for the actor can be stuck unevaluated-              -- in thunks and we are not allowed to overwrite them.-              PointArray.safeSetA apartBfs bfsInvalid-            _ ->-              PointArray.replicateA lxsize lysize apartBfs-          bfs = fillBfs isEnterable passUnknown origin vInitial-      pathAndStore bfs--getCacheBfs :: MonadClient m => ActorId -> m (PointArray.Array BfsDistance)-{-# INLINE getCacheBfs #-}-getCacheBfs aid = do-  mbfs <- getsClient $ EM.lookup aid . sbfsD-  case mbfs of-    Just (True, bfs, _, _, _) -> return bfs-    _ -> fst <$> getCacheBfsAndPath aid (Point 0 0)-      -- @undefined@ here crashes, because it's used to invalidate cache,-      -- but the paths is not computed, until needed (unlikely at (0, 0))--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-  -- set of abilities as the leader, anyway). Otherwise we'd have-  -- to reset BFS after leader changes, but it would still lead to-  -- wasted movement if, e.g., non-leaders move but only leaders open doors-  -- and leader change is very rare.-  activeItems <- activeItemsClient aid-  let actorMaxSk = sumSkills activeItems-      alterSkill = EM.findWithDefault 0 Ability.AbAlter actorMaxSk-      canSearchAndOpen = alterSkill >= 1-      canMove = EM.findWithDefault 0 Ability.AbMove actorMaxSk > 0-                || EM.findWithDefault 0 Ability.AbDisplace actorMaxSk > 0-                -- TODO: needed for now, because AI targets enemies-                -- based on the path to them, not LOS to them.-                || EM.findWithDefault 0 Ability.AbProject actorMaxSk > 0-  lvl <- getLevel $ blid b-  smarkSuspect <- getsClient smarkSuspect-  fact <- getsState $ (EM.! bfid b) . sfactionD-  let underAI = isAIFact fact-      enterSuspect = canSearchAndOpen && (smarkSuspect || underAI)-      isPassable | enterSuspect = Tile.isPassable-                 | otherwise = Tile.isPassableNoSuspect-  -- We treat doors as an open tile and don't add an extra step for opening-  -- the doors, because other actors open and use them, too,-  -- so it's amortized. We treat unknown tiles specially.-  let unknownId = ouniqGroup "unknown space"-      chAccess = checkAccess cops lvl-      chDoorAccess = [checkDoorAccess cops lvl | canSearchAndOpen]-      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-            allOK = all (\f -> f spos tpos) conditions-        in if tt == unknownId-           then if not (Tile.isSuspect cotile st) && allOK-                then MoveToUnknown-                else MoveBlocked-           else if isPassable cotile tt-                   && not (Tile.isChangeable cotile st)  -- takes time to change-                   && allOK-                then MoveToOpen-                else MoveBlocked-      -- Legality of move from an unknown tile, assuming unknown are open.-      passUnknown :: Point -> Point -> Bool-      {-# 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-  if canMove-    then return (isEnterable, passUnknown)-    else return (\_ _ -> MoveBlocked, \_ _ -> False)--accessCacheBfs :: MonadClient m => ActorId -> Point -> m (Maybe Int)-{-# INLINE accessCacheBfs #-}-accessCacheBfs aid target = do-  bfs <- getCacheBfs aid-  return $! accessBfs bfs target---- | Furthest (wrt paths) known position.-furthestKnown :: MonadClient m => ActorId -> m Point-furthestKnown aid = do-  bfs <- getCacheBfs aid-  getMaxIndex <- rndToAction $ oneOf [ PointArray.maxIndexA-                                     , PointArray.maxLastIndexA ]-  let furthestPos = getMaxIndex bfs-      dist = bfs PointArray.! furthestPos-  return $! assert (dist > apartBfs `blame` (aid, furthestPos, dist))-                   furthestPos---- | Closest reachable unknown tile position, if any.-closestUnknown :: MonadClient m => ActorId -> m (Maybe Point)-closestUnknown aid = do-  body <- getsState $ getActorBody aid-  lvl@Level{lxsize, lysize} <- getLevel $ blid body-  bfs <- getCacheBfs aid-  let closestPoss = PointArray.minIndexesA bfs-      dist = bfs PointArray.! head closestPoss-  if dist >= apartBfs then do-    when (lclear lvl == lseen lvl) $ do  -- explored fully, mark it once for all-      let !_A = assert (lclear lvl >= lseen lvl) ()-      modifyClient $ \cli ->-        cli {sexplored = ES.insert (blid body) (sexplored cli)}-    return Nothing-  else do-    let unknownAround p =-          let vic = vicinity lxsize lysize p-              posUnknown pos = bfs PointArray.! pos < apartBfs-              vicUnknown = filter posUnknown vic-          in length vicUnknown-        cmp = comparing unknownAround-    return $ Just $ maximumBy cmp closestPoss---- TODO: this is costly, because target has to be changed every--- turn when walking along trail. But inverting the sort and going--- to the newest smell, while sometimes faster, may result in many--- actors following the same trail, unless we wipe the trail as soon--- as target is assigned (but then we don't know if we should keep the target--- or not, because somebody already followed it). OTOH, trails are not--- common and so if wiped they can't incur a large total cost.--- TODO: remove targets where the smell is likely to get too old by the time--- the actor gets there.--- | Finds smells closest to the actor, except under the actor.-closestSmell :: MonadClient m => ActorId -> m [(Int, (Point, Tile.SmellTime))]-closestSmell aid = do-  body <- getsState $ getActorBody aid-  Level{lsmell, ltime} <- getLevel $ blid body-  let smells = filter ((> ltime) . snd) $ EM.assocs lsmell-  case smells of-    [] -> return []-    _ -> do-      bfs <- getCacheBfs aid-      let ts = mapMaybe (\x@(p, _) -> fmap (,x) (accessBfs bfs p)) smells-          ds = filter (\(d, _) -> d /= 0) ts  -- bpos of aid-      return $! sortBy (comparing (fst &&& absoluteTimeNegate . snd . snd)) ds---- | Closest (wrt paths) suspect tile.-closestSuspect :: MonadClient m => ActorId -> m [Point]-closestSuspect aid = do-  Kind.COps{cotile} <- getsState scops-  body <- getsState $ getActorBody aid-  lvl <- getLevel $ blid body-  let f :: [Point] -> Point -> Kind.Id TileKind -> [Point]-      f acc p t = if Tile.isSuspect cotile t then p : acc else acc-      suspect = PointArray.ifoldlA f [] $ ltile lvl-  case suspect of-    [] -> do-      -- If the level has inaccessible open areas (at least from some stairs)-      -- here finally mark it explored, to enable transition to other levels.-      -- We should generally avoid such levels, because digging and/or trying-      -- to find other stairs leading to disconnected areas is not KISS-      -- so we don't do this in AI, so AI is at a disadvantage.-      modifyClient $ \cli ->-        cli {sexplored = ES.insert (blid body) (sexplored cli)}-      return []-    _ -> do-      bfs <- getCacheBfs aid-      let ds = mapMaybe (\p -> fmap (,p) (accessBfs bfs p)) suspect-      return $! map snd $ sortBy (comparing fst) ds---- TODO: We assume linear dungeon in @unexploredD@,--- because otherwise we'd need to calculate shortest paths in a graph, etc.--- | Closest (wrt paths) triggerable open tiles.--- The level the actor is on is either explored or the actor already--- has a weapon equipped, so no need to explore further, he tries to find--- enemies on other levels.-closestTriggers :: MonadClient m => Maybe Bool -> ActorId -> m (Frequency Point)-closestTriggers onlyDir aid = do-  Kind.COps{cotile} <- getsState scops-  body <- getsState $ getActorBody aid-  explored <- getsClient sexplored-  let lid = blid body-  lvl <- getLevel lid-  dungeon <- getsState sdungeon-  let escape = any (not . null . lescape) $ EM.elems dungeon-  unexploredD <- unexploredDepth-  let allExplored = ES.size explored == EM.size dungeon-      -- If lid not explored, aid equips a weapon and so can leave level.-      lidExplored = ES.member (blid body) explored-      f :: [(Int, Point)] -> Point -> Kind.Id TileKind -> [(Int, Point)]-      f acc p t =-        if Tile.isWalkable cotile t && not (null $ Tile.causeEffects cotile t)-        then case Tile.ascendTo cotile t of-          [] ->-            -- Escape (or guard) only after exploring, for high score, etc.-            if isNothing onlyDir && allExplored-            then (9999999, p) : acc  -- all from that level congregate here-            else acc-          l ->-            if not escape && allExplored-            -- Direction irrelevant; wander randomly.-            then map (,p) l ++ acc-            else let g k =-                       let easier = signum k /= signum (fromEnum lid)-                           unexpForth = unexploredD (signum k) lid-                           unexpBack = unexploredD (- signum k) lid-                           aiCond = if unexpForth-                                    then easier-                                         || not unexpBack && lidExplored-                                    else not unexpBack && lidExplored-                                         && null (lescape lvl)-                       in maybe aiCond (\d -> d == (k > 0)) onlyDir-                 in map (,p) (filter g l) ++ acc-        else acc-      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,-      -- unless the actor has just returned via the very stairs.-      triggers = filter ((/= bpos body) . snd) triggersAll-  bfs <- getCacheBfs aid-  return $ case triggers of  -- keep lazy-    [] -> mzero-    _ | isNothing onlyDir && not escape && allExplored ->-      -- Distance also irrelevant, to ensure random wandering.-      toFreq "closestTriggers when allExplored" triggers-    _ ->-      -- Prefer stairs to easier levels.-      -- If exactly one escape, these stairs will all be in one direction.-      let mix (k, p) dist =-            let easier = signum k /= signum (fromEnum lid)-                depthDelta = if easier then 2 else 1-                maxd = fromEnum (maxBound :: BfsDistance)-                       - fromEnum apartBfs-                v = (maxd * maxd * maxd) `div` ((dist + 1) * (dist + 1))-            in (depthDelta * v, p)-          ds = mapMaybe (\(k, p) -> mix (k, p) <$> accessBfs bfs p) triggers-      in toFreq "closestTriggers" ds--unexploredDepth :: MonadClient m => m (Int -> LevelId -> Bool)-unexploredDepth = do-  dungeon <- getsState sdungeon-  explored <- getsClient sexplored-  let allExplored = ES.size explored == EM.size dungeon-      unexploredD p =-        let unex lid = allExplored-                       && not (null $ lescape $ dungeon EM.! lid)-                       || ES.notMember lid explored-                       || unexploredD p lid-        in any unex . ascendInBranch dungeon p-  return unexploredD---- | Closest (wrt paths) items and changeable tiles (e.g., item caches).-closestItems :: MonadClient m => ActorId -> m [(Int, (Point, Maybe ItemBag))]-closestItems aid = do-  Kind.COps{cotile} <- getsState scops-  body <- getsState $ getActorBody aid-  lvl@Level{lfloor} <- getLevel $ blid body-  let items = EM.assocs lfloor-      f :: [Point] -> Point -> Kind.Id TileKind -> [Point]-      f acc p t = if Tile.isChangeable cotile t then p : acc else acc-      changeable = PointArray.ifoldlA f [] $ ltile lvl-  if null items && null changeable then return []-  else do-    bfs <- getCacheBfs aid-    let is = mapMaybe (\(p, bag) ->-                        fmap (, (p, Just bag)) (accessBfs bfs p)) items-        cs = mapMaybe (\p ->-                        fmap (, (p, Nothing)) (accessBfs bfs p)) changeable-    return $! sortBy (comparing fst) $ is ++ cs---- | Closest (wrt paths) enemy actors.-closestFoes :: MonadClient m-            => [(ActorId, Actor)] -> ActorId -> m [(Int, (ActorId, Actor))]-closestFoes foes aid =-  case foes of-    [] -> return []-    _ -> do-      bfs <- getCacheBfs aid-      let ds = mapMaybe (\x@(_, b) -> fmap (,x) (accessBfs bfs (bpos b))) foes-      return $! sortBy (comparing fst) ds

+ Game/LambdaHack/Client/BfsM.hs view

@@ -0,0 +1,453 @@+{-# LANGUAGE TupleSections #-}+-- | Breadth first search and realted algorithms using the client monad.+module Game.LambdaHack.Client.BfsM+  ( invalidateBfsAid, invalidateBfsLid, invalidateBfsAll+  , createBfs, condBFS, getCacheBfsAndPath, getCacheBfs+  , getCachePath, createPath+  , unexploredDepth+  , closestUnknown, closestSmell, furthestKnown+  , FleeViaStairsOrEscape(..), embedBenefit, closestTriggers+  , closestItems, closestFoes+  , condEnoughGearM+#ifdef EXPOSE_INTERNAL+  , updatePathFromBfs+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import Data.Ord+import Data.Word++import Game.LambdaHack.Client.Bfs+import Game.LambdaHack.Client.CommonM+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import qualified Game.LambdaHack.Common.Ability as Ability+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import 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 qualified Game.LambdaHack.Common.PointArray as PointArray+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Vector+import qualified Game.LambdaHack.Content.ItemKind as IK+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Content.TileKind (isUknownSpace)++invalidateBfsAid :: MonadClient m => ActorId -> m ()+invalidateBfsAid aid =+  modifyClient $ \cli -> cli {sbfsD = EM.insert aid BfsInvalid (sbfsD cli)}++invalidateBfsLid :: MonadClient m => LevelId -> m ()+invalidateBfsLid lid = do+  side <- getsClient sside+  let f (_, b) = blid b == lid && bfid b == side && not (bproj b)+  as <- getsState $ filter f . EM.assocs . sactorD+  mapM_ (invalidateBfsAid . fst) as++invalidateBfsAll :: MonadClient m => m ()+invalidateBfsAll =+  modifyClient $ \cli -> cli {sbfsD = EM.map (const BfsInvalid) (sbfsD cli)}++createBfs :: MonadClient m+          => Bool -> Word8 -> ActorId -> m (PointArray.Array BfsDistance)+createBfs canMove alterSkill aid = do+  b <- getsState $ getActorBody aid+  let lid = blid b+  Level{lxsize, lysize} <- getLevel lid+  let !aInitial = PointArray.replicateA lxsize lysize apartBfs+      !source = bpos b+      !_ = PointArray.unsafeWriteA aInitial source minKnownBfs+  when canMove $ do+    salter <- getsClient salter+    let !lalter = salter EM.! lid+        !_a = fillBfs lalter alterSkill source aInitial+    return ()+  return aInitial++updatePathFromBfs :: MonadClient m+                  => Bool -> BfsAndPath -> ActorId -> Point+                  -> m (PointArray.Array BfsDistance, AndPath)+updatePathFromBfs canMove bfsAndPathOld aid !target = do+  Kind.COps{coTileSpeedup} <- getsState scops+  let (oldBfsArr, oldBfsPath) = case bfsAndPathOld of+        BfsAndPath{bfsArr, bfsPath} -> (bfsArr, bfsPath)+        BfsInvalid -> assert `failure` (bfsAndPathOld, aid, target)+  let bfsArr = oldBfsArr+  if not canMove+  then return (bfsArr, NoPath)+  else do+    b <- getsState $ getActorBody aid+    let lid = blid b+    seps <- getsClient seps+    salter <- getsClient salter+    lvl <- getLevel lid+    let !lalter = salter EM.! lid+        fovLit p = Tile.isLit coTileSpeedup $ lvl `at` p+        !source = bpos b+        !mpath = findPathBfs lalter fovLit source target seps bfsArr+        !bfsPath = EM.insert target mpath oldBfsPath+        bap = BfsAndPath{..}+    modifyClient $ \cli -> cli {sbfsD = EM.insert aid bap $ sbfsD cli}+    return (bfsArr, mpath)++-- | Get cached BFS array and path or, if not stored, generate and store first.+getCacheBfsAndPath :: forall m. MonadClient m+                   => ActorId -> Point+                   -> m (PointArray.Array BfsDistance, AndPath)+getCacheBfsAndPath aid target = do+  mbfs <- getsClient $ EM.lookup aid . sbfsD+  case mbfs of+    Just bap@BfsAndPath{..} ->+      case EM.lookup target bfsPath of+        Nothing -> do+          (!canMove, _) <- condBFS aid+          updatePathFromBfs canMove bap aid target+        Just mpath -> return (bfsArr, mpath)+    _ -> do+      (!canMove, !alterSkill) <- condBFS aid+      !bfsArr <- createBfs canMove alterSkill aid+      let bfsPath = EM.empty+      updatePathFromBfs canMove BfsAndPath{..} aid target++-- | Get cached BFS array or, if not stored, generate and store first.+getCacheBfs :: MonadClient m => ActorId -> m (PointArray.Array BfsDistance)+getCacheBfs aid = do+  mbfs <- getsClient $ EM.lookup aid . sbfsD+  case mbfs of+    Just BfsAndPath{bfsArr} -> return bfsArr+    _ -> do+      (!canMove, !alterSkill) <- condBFS aid+      !bfsArr <- createBfs canMove alterSkill aid+      let bfsPath = EM.empty+      modifyClient $ \cli ->+        cli {sbfsD = EM.insert aid BfsAndPath{..} (sbfsD cli)}+      return bfsArr++-- | Get cached BFS path or, if not stored, generate and store first.+getCachePath :: MonadClient m => ActorId -> Point -> m AndPath+getCachePath aid target = do+  b <- getsState $ getActorBody aid+  let source = bpos b+  if | source == target -> return $! AndPath [] target 0  -- speedup+     | otherwise -> snd <$> getCacheBfsAndPath aid target++createPath :: MonadClient m => ActorId -> Target -> m TgtAndPath+createPath aid tapTgt = do+  Kind.COps{coTileSpeedup} <- getsState scops+  b <- getsState $ getActorBody aid+  lvl <- getLevel $ blid b+  let stopAtUnwalkable tapPath@AndPath{..} =+        let (walkable, rest) =+              -- Unknown tiles are not walkable, so path stops before them,+              -- which is good, because by the time actor reaches them,+              -- they are no longer unknown, so target invalidated.+              span (Tile.isWalkable coTileSpeedup . at lvl) pathList+        in case rest of+          [] -> TgtAndPath{..}+          [g] | g == pathGoal -> TgtAndPath{..}+          newGoal : _ ->+            let newTgt = TPoint TKnown (blid b) newGoal+                newPath = AndPath{ pathList = walkable ++ [newGoal]+                                 , pathGoal = newGoal+                                 , pathLen = length walkable + 1 }+            in TgtAndPath{tapTgt = newTgt, tapPath = newPath}+      stopAtUnwalkable tapPath@NoPath = TgtAndPath{..}+  mpos <- aidTgtToPos aid (blid b) tapTgt+  case mpos of+    Nothing -> return TgtAndPath{tapTgt, tapPath=NoPath}+    Just p -> do+      path <- getCachePath aid p+      return $! stopAtUnwalkable path++condBFS :: MonadClient m => ActorId -> m (Bool, Word8)+condBFS aid = do+  side <- getsClient sside+  -- We assume the actor eventually becomes a leader (or has the same+  -- set of abilities as the leader, anyway). Otherwise we'd have+  -- to reset BFS after leader changes, but it would still lead to+  -- wasted movement if, e.g., non-leaders move but only leaders open doors+  -- and leader change is very rare.+  actorMaxSk <- maxActorSkillsClient aid+  let alterSkill =+        min (maxBound - 1)  -- @maxBound :: Word8@ means unalterable+            (toEnum $ EM.findWithDefault 0 Ability.AbAlter actorMaxSk)+      canMove = EM.findWithDefault 0 Ability.AbMove actorMaxSk > 0+                || EM.findWithDefault 0 Ability.AbDisplace actorMaxSk > 0+                || EM.findWithDefault 0 Ability.AbProject actorMaxSk > 0+  smarkSuspect <- getsClient smarkSuspect+  fact <- getsState $ (EM.! side) . sfactionD+  let underAI = isAIFact fact+      -- Under UI, playing a hero party, we let AI set our target each+      -- turn for henchmen that can't move and can't alter, usually to TUnknown.+      -- This is rather useless, but correct.+      enterSuspect = smarkSuspect > 0 || underAI+      skill | enterSuspect = alterSkill  -- dig and search at will+            | otherwise = 1  -- only walkable tiles and unknown+  return (canMove, skill)  -- keep it lazy++-- | Furthest (wrt paths) known position.+furthestKnown :: MonadClient m => ActorId -> m Point+furthestKnown aid = do+  bfs <- getCacheBfs aid+  getMaxIndex <- rndToAction $ oneOf [ PointArray.maxIndexA+                                     , PointArray.maxLastIndexA ]+  let furthestPos = getMaxIndex bfs+      dist = bfs PointArray.! furthestPos+  return $! assert (dist > apartBfs `blame` (aid, furthestPos, dist))+                   furthestPos++-- | Closest reachable unknown tile position, if any.+--+-- Note: some of these tiles are behind suspect tiles and they are chosen+-- in preference to more distant directly accessible unknown tiles.+-- This is in principle OK, but in dungeons with few hidden doors+-- AI is at a disadvantage (and with many hidden doors, it fares as well+-- as a human that deduced the dungeon properties). Changing Bfs to accomodate+-- all dungeon styles would be complex and would slow down the engine.+--+-- If the level has inaccessible open areas (at least from the stairs AI used)+-- the level will be nevertheless here finally marked explored,+-- to enable transition to other levels.+-- We should generally avoid such levels, because digging and/or trying+-- to find other stairs leading to disconnected areas is not KISS+-- so we don't do this in AI, so AI is at a disadvantage.+closestUnknown :: MonadClient m => ActorId -> m (Maybe Point)+closestUnknown aid = do+  body <- getsState $ getActorBody aid+  lvl <- getLevel $ blid body+  bfs <- getCacheBfs aid+  let closestPoss = PointArray.minIndexesA bfs+      dist = bfs PointArray.! head closestPoss+      !_A = assert (lclear lvl >= lseen lvl) ()+  if lclear lvl <= lseen lvl+       -- Some unknown may still be visible and even pathable, but we already+       -- know from global level info that they are blocked.+     || dist >= apartBfs+       -- Global level info may tell us that terrain was changed and so+       -- some new explorable tile appeared, but we don't care about those+       -- and we know we already explored all initially seen unknown tiles+       -- and it's enough for us (otherwise we'd need to hunt all around+       -- the map for tiles altered by enemies).+  then do+    modifyClient $ \cli ->+      cli {sexplored = ES.insert (blid body) (sexplored cli)}+    return Nothing+  else do+    let unknownAround pos =+          let vic = vicinityUnsafe pos+              countUnknown :: Int -> Point -> Int+              countUnknown c p = if isUknownSpace $ lvl `at` p then c + 1 else c+          in foldl' countUnknown 0 vic+        cmp = comparing unknownAround+    return $ Just $ maximumBy cmp closestPoss++-- | Finds smells closest to the actor, except under the actor,+-- because actors consume smell only moving over them, not standing.+-- Of the closest, prefers the newest smell.+closestSmell :: MonadClient m => ActorId -> m [(Int, (Point, Time))]+closestSmell aid = do+  body <- getsState $ getActorBody aid+  Level{lsmell, ltime} <- getLevel $ blid body+  let smells = filter (\(p, sm) -> sm > ltime && p /= bpos body)+                      (EM.assocs lsmell)+  case smells of+    [] -> return []+    _ -> do+      bfs <- getCacheBfs aid+      let ts = mapMaybe (\x@(p, _) -> fmap (,x) (accessBfs bfs p)) smells+      return $! sortBy (comparing (fst &&& absoluteTimeNegate . snd . snd)) ts++data FleeViaStairsOrEscape =+  ViaStairs | ViaStairsUp | ViaStairsDown | ViaEscape | ViaNothing | ViaAnything+  deriving (Show, Eq)++embedBenefit :: MonadClient m+             => FleeViaStairsOrEscape -> ActorId+             -> [(Point, ItemBag)]+             -> m [(Int, (Point, ItemBag))]+embedBenefit fleeVia aid pbags = do+  Kind.COps{coitem=Kind.Ops{okind}, coTileSpeedup} <- getsState scops+  dungeon <- getsState sdungeon+  explored <- getsClient sexplored+  b <- getsState $ getActorBody aid+  actorSk <- if fleeVia == ViaAnything  -- targeting, e.g., when not a leader+             then maxActorSkillsClient aid+             else currentSkillsClient aid+  let alterSkill = EM.findWithDefault 0 Ability.AbAlter actorSk+  fact <- getsState $ (EM.! bfid b) . sfactionD+  lvl <- getLevel (blid b)+  unexploredTrue <- unexploredDepth True (blid b)+  unexploredFalse <- unexploredDepth False (blid b)+  condEnoughGear <- condEnoughGearM aid+  discoKind <- getsClient sdiscoKind+  discoBenefit <- getsClient sdiscoBenefit+  s <- getState+  let alterMinSkill p = Tile.alterMinSkill coTileSpeedup $ lvl `at` p+      lidExplored = ES.member (blid b) explored+      allExplored = ES.size explored == EM.size dungeon+      -- Ignoring the number of items, because only one of each @iid@+      -- is triggered at the same time, others are left to be used later on.+      iidToEffs iid = case EM.lookup (jkindIx $ getItemBody iid s) discoKind of+        Nothing -> []+        Just KindMean{kmKind} -> IK.ieffects $ okind kmKind+      isEffEscapeOrAscend IK.Ascend{} = True+      isEffEscapeOrAscend IK.Escape{} = True+      isEffEscapeOrAscend _ = False+      feats bag = concatMap iidToEffs $ EM.keys bag+      -- For simplicity, we assume at most one exit at each position.+      -- AI uses exit regardless of traps or treasures at the spot.+      bens (_, bag) = case find isEffEscapeOrAscend $ feats bag of+        Just IK.Escape{} ->+          -- Escape (or guard) only after exploring, for high score, etc.+          let escapeOrGuard = fcanEscape (gplayer fact)+                              || fleeVia == ViaAnything  -- targeting to guard+          in if fleeVia `elem` [ViaEscape, ViaAnything]+                && escapeOrGuard+                && allExplored+             then 10+             else 0  -- don't escape prematurely+        Just (IK.Ascend up) ->  -- change levels sensibly, in teams+          let easier = up /= (fromEnum (blid b) > 0)+              unexpForth = if up then unexploredTrue else unexploredFalse+              unexpBack = if not up then unexploredTrue else unexploredFalse+              -- Forbid loops via peeking at unexplored and getting back.+              aiCond = if unexpForth+                       then easier && condEnoughGear+                            || (not unexpBack || easier) && lidExplored+                       else easier && allExplored && null (lescape lvl)+              -- Prefer one direction of stairs, to team up+              -- and prefer embed (may, e.g.,  create loot) over stairs.+              v = if aiCond then if easier then 10 else 1 else 0+          in case fleeVia of+            ViaStairsUp | up -> 1+            ViaStairsDown | not up -> 1+            ViaStairs -> v+            ViaAnything -> v+            _ -> 0  -- don't ascend prematurely+        _ ->+          if fleeVia `elem` [ViaNothing, ViaAnything]++          then -- Actor uses the embedded item on himself, hence @effApply@.+               -- Let distance be the deciding factor and also prevent+               -- overflow on 32-bit machines.+               min 1000 $ sum+               $ mapMaybe (\iid -> benApply <$> EM.lookup iid discoBenefit)+                          (EM.keys bag)+          else 0+      interestingHere p =+        -- For speed and to avoid greedy AI loops, filter targets.+        Tile.consideredByAI coTileSpeedup (lvl `at` p)+        -- Only actors with high enough AbAlter can trigger embedded items.+        && alterSkill >= fromEnum (alterMinSkill p)+      ebags = filter (interestingHere . fst) pbags+      benFeats = map (\pbag -> (bens pbag, pbag)) ebags+  return $! filter ((> 0 ) . fst) benFeats++-- | Closest (wrt paths) AI-triggerable tiles with embedded items.+-- In AI, the level the actor is on is either explored or the actor already+-- has a weapon equipped, so no need to explore further, he tries to find+-- enemies on other levels, but before that, he triggers other tiles+-- in hope of some loot or beneficial effect to enter next level with.+closestTriggers :: MonadClient m => FleeViaStairsOrEscape -> ActorId+                -> m [(Int, (Point, (Point, ItemBag)))]+closestTriggers fleeVia aid = do+  b <- getsState $ getActorBody aid+  lvl <- getLevel (blid b)+  let pbags = EM.assocs $ lembed lvl+  efeat <- embedBenefit fleeVia aid pbags+  -- The advantage of targeting the tiles in vicinity of triggers is that+  -- triggers don't need to be pathable (and so AI doesn't bump into them+  -- by chance while walking elsewhere) and that many accesses to the tiles+  -- are more likely to be targeted by different AI actors (even starting+  -- from the same location), so there is less risk of clogging stairs and,+  -- OTOH, siege of stairs or escapes is more effective.+  bfs <- getCacheBfs aid+  let vicTrigger (cid, (p0, bag)) =+        map (\p -> (cid, (p, (p0, bag)))) $ vicinityUnsafe p0+      vicAll = concatMap vicTrigger efeat+  return $  -- keep lazy+    let mix (benefit, ppbag) dist =+          let maxd = fromEnum (maxBound :: BfsDistance)+                     - fromEnum apartBfs+              -- Bewqre of overflowing 32-bit integers here.+              v = (maxd * 10) `div` (dist + 1)+          in (benefit * v, ppbag)+    in mapMaybe (\bpp@(_, (p, _)) ->+         mix bpp <$> accessBfs bfs p) vicAll++-- | Check whether the actor has enough gear to go look for enemies.+-- We assume weapons in equipment are better than any among organs+-- or at least provide some essential diversity.+-- Disabled if, due to tactic, actors follow leader and so would+-- repeatedly move towards and away form stairs at leader change,+-- depending on current leader's gear.+-- Number of items of a single kind is ignored, because variety is needed.+condEnoughGearM :: MonadClient m => ActorId -> m Bool+condEnoughGearM aid = do+  b <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  let followTactic = ftactic (gplayer fact) `elem` [TFollow, TFollowNoItems]+  eqpAssocs <- getsState $ getActorAssocs aid CEqp+  invAssocs <- getsState $ getActorAssocs aid CInv+  return $ not followTactic  -- keep it lazy+           && (any (isMelee . snd) eqpAssocs+               || length (eqpAssocs ++ invAssocs) >= 5)++unexploredDepth :: MonadClient m => Bool -> LevelId -> m Bool+unexploredDepth !up !lidCurrent = do+  dungeon <- getsState sdungeon+  explored <- getsClient sexplored+  let allExplored = ES.size explored == EM.size dungeon+      unexploredD =+        let unex !lid = allExplored+                        && not (null $ lescape $ dungeon EM.! lid)+                        || ES.notMember lid explored+                        || unexploredD lid+        in any unex . ascendInBranch dungeon up+  return $ unexploredD lidCurrent  -- keep it lazy++-- | Closest (wrt paths) items.+closestItems :: MonadClient m => ActorId -> m [(Int, (Point, ItemBag))]+closestItems aid = do+  actorMaxSk <- maxActorSkillsClient aid+  if EM.findWithDefault 0 Ability.AbMoveItem actorMaxSk <= 0 then return []+  else do+    body <- getsState $ getActorBody aid+    Level{lfloor} <- getLevel $ blid body+    if EM.null lfloor then return [] else do+      bfs <- getCacheBfs aid+      let mix pbag dist =+            let maxd = fromEnum (maxBound :: BfsDistance)+                       - fromEnum apartBfs+                -- Bewqre of overflowing 32-bit integers here.+                -- Here distance is the only factor influencing frequency,+                -- unless item not desirable, which is checked later on.+                v = (maxd * 10) `div` (dist + 1)+            in (v, pbag)+      return $! mapMaybe (\(p, bag) ->+        mix (p, bag) <$> accessBfs bfs p) (EM.assocs lfloor)++-- | Closest (wrt paths) enemy actors.+closestFoes :: MonadClient m+            => [(ActorId, Actor)] -> ActorId -> m [(Int, (ActorId, Actor))]+closestFoes foes aid =+  case foes of+    [] -> return []+    _ -> do+      bfs <- getCacheBfs aid+      let ds = mapMaybe (\x@(_, b) -> fmap (,x) (accessBfs bfs (bpos b))) foes+      return $! sortBy (comparing fst) ds

− Game/LambdaHack/Client/CommonClient.hs

@@ -1,277 +0,0 @@-{-# LANGUAGE DataKinds #-}--- | Common client monad operations.-module Game.LambdaHack.Client.CommonClient-  ( getPerFid, aidTgtToPos, aidTgtAims, makeLine-  , partAidLeader, partActorLeader, partPronounLeader-  , actorSkillsClient, updateItemSlot, fullAssocsClient, activeItemsClient-  , itemToFullClient, pickWeaponClient, sumOrganEqpClient-  ) where--import Control.Applicative-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.Maybe-import Data.Tuple-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Client.ItemSlot-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import qualified Game.LambdaHack.Common.Ability as Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import 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.Msg-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import Game.LambdaHack.Common.Vector-import qualified Game.LambdaHack.Content.ItemKind as IK---- | Get the current perception of a client.-getPerFid :: MonadClient m => LevelId -> m Perception-getPerFid lid = do-  fper <- getsClient sfper-  let assFail = assert `failure` "no perception at given level"-                       `twith` (lid, fper)-  return $! EM.findWithDefault assFail lid fper---- | The part of speech describing the actor or "you" if a leader--- of the client's faction. The actor may be not present in the dungeon.-partActorLeader :: MonadClient m => ActorId -> Actor -> m MU.Part-partActorLeader aid b = do-  mleader <- getsClient _sleader-  return $! case mleader of-    Just leader | aid == leader -> "you"-    _ -> partActor b---- | The part of speech with the actor's pronoun or "you" if a leader--- of the client's faction. The actor may be not present in the dungeon.-partPronounLeader :: MonadClient m => ActorId -> Actor -> m MU.Part-partPronounLeader aid b = do-  mleader <- getsClient _sleader-  return $! case mleader of-    Just leader | aid == leader -> "you"-    _ -> partPronoun b---- | The part of speech describing the actor (designated by actor id--- and present in the dungeon) or a special name if a leader--- of the observer's faction.-partAidLeader :: MonadClient m => ActorId -> m MU.Part-partAidLeader aid = do-  b <- getsState $ getActorBody aid-  partActorLeader aid b---- | Calculate the position of an actor's target.-aidTgtToPos :: MonadClient m-            => ActorId -> LevelId -> Maybe Target -> m (Maybe Point)-aidTgtToPos aid lidV tgt =-  case tgt of-    Just (TEnemy a _) -> do-      body <- getsState $ getActorBody a-      return $! if blid body == lidV-                then Just (bpos body)-                else Nothing-    Just (TEnemyPos _ lid p _) ->-      return $! if lid == lidV then Just p else Nothing-    Just (TPoint lid p) ->-      return $! if lid == lidV then Just p else Nothing-    Just (TVector v) -> do-      b <- getsState $ getActorBody aid-      Level{lxsize, lysize} <- getLevel lidV-      let shifted = shiftBounded lxsize lysize (bpos b) v-      return $! if shifted == bpos b && v /= Vector 0 0-                then Nothing-                else Just shifted-    Nothing -> do-      scursor <- getsClient scursor-      aidTgtToPos aid lidV $ Just scursor---- | Check whether one is permitted to aim at a target--- (this is only checked for actors; positions let player--- shoot at obstacles, e.g., to destroy them).--- This assumes @aidTgtToPos@ does not return @Nothing@.--- Returns a different @seps@, if needed to reach the target actor.------ Note: Perception is not enough for the check,--- because the target actor can be obscured by a glass wall--- or be out of sight range, but in weapon range.-aidTgtAims :: MonadClient m-           => ActorId -> LevelId -> Maybe Target -> m (Either Msg Int)-aidTgtAims aid lidV tgt = do-  let findNewEps onlyFirst pos = do-        oldEps <- getsClient seps-        b <- getsState $ getActorBody aid-        mnewEps <- makeLine onlyFirst b pos oldEps-        case mnewEps of-          Just newEps -> return $ Right newEps-          Nothing ->-            return $ Left-                   $ if onlyFirst then "aiming blocked at the first step"-                     else "aiming line to the opponent blocked somewhere"-  case tgt of-    Just (TEnemy a _) -> do-      body <- getsState $ getActorBody a-      let pos = bpos body-      if blid body == lidV-      then findNewEps False pos-      else return $ Left "selected opponent not on this level"-    Just TEnemyPos{} -> return $ Left "selected opponent not visible"-    Just (TPoint lid pos) ->-      if lid == lidV-      then findNewEps True pos-      else return $ Left "selected position not on this level"-    Just (TVector v) -> do-      b <- getsState $ getActorBody aid-      Level{lxsize, lysize} <- getLevel lidV-      let shifted = shiftBounded lxsize lysize (bpos b) v-      if shifted == bpos b && v /= Vector 0 0-      then return $ Left "selected translation is void"-      else findNewEps True shifted-    Nothing -> do-      scursor <- getsClient scursor-      aidTgtAims aid lidV $ Just scursor---- | Counts the number of steps until the projectile would hit--- an actor or obstacle. Starts searching with the given eps and returns--- the first found eps for which the number reaches the distance between--- actor and target position, or Nothing if none can be found.-makeLine :: MonadClient m => Bool -> Actor -> Point -> Int -> m (Maybe Int)-makeLine onlyFirst body fpos epsOld = do-  cops@Kind.COps{cotile=Kind.Ops{ouniqGroup}} <- getsState scops-  lvl@Level{lxsize, lysize} <- getLevel (blid body)-  bs <- getsState $ filter (not . bproj)-                    . actorList (const True) (blid body)-  let unknownId = ouniqGroup "unknown space"-      dist = chessDist (bpos body) fpos-      calcScore eps = case bla lxsize lysize eps (bpos body) fpos of-        Just bl ->-          let blDist = take dist bl-              blZip = zip (bpos body : blDist) blDist-              noActor p = all ((/= p) . bpos) bs || p == fpos-              accessU = all noActor blDist-                        && all (uncurry $ accessibleUnknown cops lvl) blZip-              accessFirst | not onlyFirst = False-                          | otherwise =-                all noActor (take 1 blDist)-                && all (uncurry $ accessibleUnknown cops lvl) (take 1 blZip)-              nUnknown = length $ filter ((== unknownId) . (lvl `at`)) blDist-          in if accessU then - nUnknown-             else if accessFirst then -10000-             else minBound-        Nothing -> assert `failure` (body, fpos, epsOld)-      tryLines curEps (acc, _) | curEps == epsOld + dist = acc-      tryLines curEps (acc, bestScore) =-        let curScore = calcScore curEps-            newAcc = if curScore > bestScore-                     then (Just curEps, curScore)-                     else (acc, bestScore)-        in tryLines (curEps + 1) newAcc-  return $! if dist <= 0 then Nothing  -- ProjectAimOnself-            else if calcScore epsOld > minBound then Just epsOld  -- keep old-            else tryLines (epsOld + 1) (Nothing, minBound)  -- generate best--actorSkillsClient :: MonadClient m => ActorId -> m Ability.Skills-actorSkillsClient aid = do-  activeItems <- activeItemsClient aid-  body <- getsState $ getActorBody aid-  fact <- getsState $ (EM.! bfid body) . sfactionD-  side <- getsClient sside-  -- Newest Leader in _sleader, not yet in sfactionD.-  mleader1 <- if side == bfid body then getsClient _sleader else return Nothing-  let mleader2 = fst <$> gleader fact-      mleader = mleader1 `mplus` mleader2-  getsState $ actorSkills mleader aid activeItems--updateItemSlot :: MonadClient m-               => CStore -> Maybe ActorId -> ItemId -> m SlotChar-updateItemSlot store maid iid = do-  slots@(itemSlots, organSlots) <- getsClient sslots-  let onlyOrgans = store == COrgan-      lSlots = if onlyOrgans then organSlots else itemSlots-      incrementPrefix m l iid2 = EM.insert l iid2 $-        case EM.lookup l m of-          Nothing -> m-          Just iidOld ->-            let lNew = SlotChar (slotPrefix l + 1) (slotChar l)-            in incrementPrefix m lNew iidOld-  case lookup iid $ map swap $ EM.assocs lSlots of-    Nothing -> do-      side <- getsClient sside-      item <- getsState $ getItemBody iid-      lastSlot <- getsClient slastSlot-      mb <- maybe (return Nothing) (fmap Just . getsState . getActorBody) maid-      l <- getsState $ assignSlot store item side mb slots lastSlot-      let newSlots | onlyOrgans = ( itemSlots-                                  , incrementPrefix organSlots l iid )-                   | otherwise =  ( incrementPrefix itemSlots l iid-                                  , organSlots )-      modifyClient $ \cli -> cli {sslots = newSlots}-      return l-    Just l -> return l  -- slot already assigned; a letter or a number--fullAssocsClient :: MonadClient m-                 => ActorId -> [CStore] -> m [(ItemId, ItemFull)]-fullAssocsClient aid cstores = do-  cops <- getsState scops-  discoKind <- getsClient sdiscoKind-  discoEffect <- getsClient sdiscoEffect-  getsState $ fullAssocs cops discoKind discoEffect aid cstores--activeItemsClient :: MonadClient m => ActorId -> m [ItemFull]-activeItemsClient aid = do-  activeAssocs <- fullAssocsClient aid [CEqp, COrgan]-  return $! map snd activeAssocs--itemToFullClient :: MonadClient m => m (ItemId -> ItemQuant -> ItemFull)-itemToFullClient = do-  cops <- getsState scops-  discoKind <- getsClient sdiscoKind-  discoEffect <- getsClient sdiscoEffect-  s <- getState-  let itemToF iid = itemToFull cops discoKind discoEffect iid-                               (getItemBody iid s)-  return itemToF---- Client has to choose the weapon based on its partial knowledge,--- because if server chose it, it would leak item discovery information.-pickWeaponClient :: MonadClient m-                 => ActorId -> ActorId-                 -> m (Maybe (RequestTimed 'Ability.AbMelee))-pickWeaponClient source target = do-  eqpAssocs <- fullAssocsClient source [CEqp]-  bodyAssocs <- fullAssocsClient source [COrgan]-  actorSk <- actorSkillsClient source-  sb <- getsState $ getActorBody source-  localTime <- getsState $ getLocalTime (blid sb)-  let allAssocs = eqpAssocs ++ bodyAssocs-      calm10 = calmEnough10 sb $ map snd allAssocs-      forced = assert (not $ bproj sb) False-      permitted = permittedPrecious calm10 forced-      preferredPrecious = either (const False) id . permitted-      strongest = strongestMelee True localTime allAssocs-      strongestPreferred = filter (preferredPrecious . snd . snd) strongest-  case strongestPreferred of-    _ | EM.findWithDefault 0 Ability.AbMelee actorSk <= 0 -> return Nothing-    [] -> return Nothing-    iis@((maxS, _) : _) -> do-      let maxIis = map snd $ takeWhile ((== maxS) . fst) iis-      (iid, _) <- rndToAction $ oneOf maxIis-      -- Prefer COrgan, to hint to the player to trash the equivalent CEqp item.-      let cstore = if isJust (lookup iid bodyAssocs) then COrgan else CEqp-      return $ Just $ ReqMelee target iid cstore--sumOrganEqpClient :: MonadClient m-                  => IK.EqpSlot -> ActorId -> m Int-sumOrganEqpClient eqpSlot aid = do-  activeItems <- activeItemsClient aid-  return $! sumSlotNoFilter eqpSlot activeItems

+ Game/LambdaHack/Client/CommonM.hs view

@@ -0,0 +1,221 @@+{-# LANGUAGE DataKinds #-}+-- | Common client monad operations.+module Game.LambdaHack.Client.CommonM+  ( getPerFid, aidTgtToPos, makeLine+  , maxActorSkillsClient, currentSkillsClient, fullAssocsClient+  , itemToFullClient, pickWeaponClient, updateSalter, createSalter+  , aspectRecordFromItemClient, aspectRecordFromActorClient, createSactorAspect+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.EnumMap.Strict as EM++import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import qualified Game.LambdaHack.Common.Ability as Ability+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Perception+import Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.TileKind (TileKind, isUknownSpace)++-- | Get the current perception of a client.+getPerFid :: MonadClient m => LevelId -> m Perception+getPerFid lid = do+  fper <- getsClient sfper+  let assFail = assert `failure` "no perception at given level"+                       `twith` (lid, fper)+  return $! EM.findWithDefault assFail lid fper++-- | Calculate the position of an actor's target.+aidTgtToPos :: MonadClient m => ActorId -> LevelId -> Target -> m (Maybe Point)+aidTgtToPos aid lidV tgt =+  case tgt of+    TEnemy a _ -> do+      body <- getsState $ getActorBody a+      return $! if blid body == lidV+                then Just (bpos body)+                else Nothing+    TPoint _ lid p ->+      return $! if lid == lidV then Just p else Nothing+    TVector v -> do+      b <- getsState $ getActorBody aid+      Level{lxsize, lysize} <- getLevel lidV+      let shifted = shiftBounded lxsize lysize (bpos b) v+      return $! if shifted == bpos b && v /= Vector 0 0+                then Nothing+                else Just shifted++-- | Counts the number of steps until the projectile would hit+-- an actor or obstacle. Starts searching with the given eps and returns+-- the first found eps for which the number reaches the distance between+-- actor and target position, or Nothing if none can be found.+makeLine :: MonadClient m => Bool -> Actor -> Point -> Int -> m (Maybe Int)+makeLine onlyFirst body fpos epsOld = do+  Kind.COps{coTileSpeedup} <- getsState scops+  lvl@Level{lxsize, lysize} <- getLevel (blid body)+  posA <- getsState $ \s p -> posToAssocs p (blid body) s+  let dist = chessDist (bpos body) fpos+      calcScore eps = case bla lxsize lysize eps (bpos body) fpos of+        Just bl ->+          let blDist = take dist bl+              noActor p = all (bproj . snd) (posA p) || p == fpos+              accessibleUnknown tpos =+                let tt = lvl `at` tpos+                in Tile.isWalkable coTileSpeedup tt || isUknownSpace tt+              accessU = all noActor blDist+                        && all accessibleUnknown blDist+              accessFirst | not onlyFirst = False+                          | otherwise =+                all noActor (take 1 blDist)+                && all accessibleUnknown (take 1 blDist)+              nUnknown = length $ filter (isUknownSpace . (lvl `at`)) blDist+          in if | accessU -> - nUnknown+                | accessFirst -> -10000+                | otherwise -> minBound+        Nothing -> assert `failure` (body, fpos, epsOld)+      tryLines curEps (acc, _) | curEps == epsOld + dist = acc+      tryLines curEps (acc, bestScore) =+        let curScore = calcScore curEps+            newAcc = if curScore > bestScore+                     then (Just curEps, curScore)+                     else (acc, bestScore)+        in tryLines (curEps + 1) newAcc+  return $! if | dist <= 0 -> Nothing  -- ProjectAimOnself+               | calcScore epsOld > minBound -> Just epsOld  -- keep old+               | otherwise ->+                 tryLines (epsOld + 1) (Nothing, minBound)  -- generate best++maxActorSkillsClient :: MonadClient m => ActorId -> m Ability.Skills+maxActorSkillsClient aid = do+  actorAspect <- getsClient sactorAspect+  case EM.lookup aid actorAspect of+    Just aspectRecord -> return $ aSkills aspectRecord  -- keep it lazy+    Nothing -> assert `failure` aid++currentSkillsClient :: MonadClient m => ActorId -> m Ability.Skills+currentSkillsClient aid = do+  actorAspect <- getsClient sactorAspect+  let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect)+  body <- getsState $ getActorBody aid+  side <- getsClient sside+  -- Newest Leader in _sleader, not yet in sfactionD.+  mleader <- if side == bfid body+             then getsClient _sleader+             else do+               fact <- getsState $ (EM.! bfid body) . sfactionD+               return $! _gleader fact+  getsState $ actorSkills mleader aid ar  -- keep it lazy++fullAssocsClient :: MonadClient m+                 => ActorId -> [CStore] -> m [(ItemId, ItemFull)]+fullAssocsClient aid cstores = do+  cops <- getsState scops+  discoKind <- getsClient sdiscoKind+  discoAspect <- getsClient sdiscoAspect+  getsState $ fullAssocs cops discoKind discoAspect aid cstores++itemToFullClient :: MonadClient m => m (ItemId -> ItemQuant -> ItemFull)+itemToFullClient = do+  cops <- getsState scops+  discoKind <- getsClient sdiscoKind+  discoAspect <- getsClient sdiscoAspect+  s <- getState+  let itemToF iid = itemToFull cops discoKind discoAspect iid+                               (getItemBody iid s)+  return itemToF++-- Client has to choose the weapon based on its partial knowledge,+-- because if server chose it, it would leak item discovery information.+pickWeaponClient :: MonadClient m+                 => ActorId -> ActorId+                 -> m (Maybe (RequestTimed 'Ability.AbMelee))+pickWeaponClient source target = do+  eqpAssocs <- fullAssocsClient source [CEqp]+  bodyAssocs <- fullAssocsClient source [COrgan]+  actorSk <- currentSkillsClient source+  actorAspect <- getsClient sactorAspect+  let allAssocsRaw = eqpAssocs ++ bodyAssocs+      allAssocs = filter (isMelee . itemBase . snd) allAssocsRaw+  discoBenefit <- getsClient sdiscoBenefit+  strongest <- pickWeaponM (Just discoBenefit)+                           allAssocs actorSk actorAspect source+  case strongest of+    [] -> return Nothing+    iis@((maxS, _) : _) -> do+      let maxIis = map snd $ takeWhile ((== maxS) . fst) iis+      (iid, _) <- rndToAction $ oneOf maxIis+      -- Prefer COrgan, to hint to the player to trash the equivalent CEqp item.+      let cstore = if isJust (lookup iid bodyAssocs) then COrgan else CEqp+      return $ Just $ ReqMelee target iid cstore++updateSalter :: MonadClient m => LevelId -> [(Point, Kind.Id TileKind)] -> m ()+updateSalter lid pts = do+  Kind.COps{coTileSpeedup} <- getsState scops+  let pas = map (second $ toEnum . Tile.alterMinWalk coTileSpeedup) pts+      f = (PointArray.// pas)+  modifyClient $ \cli -> cli {salter = EM.adjust f lid $ salter cli}++createSalter :: State -> AlterLid+createSalter s =+  let Kind.COps{coTileSpeedup} = scops s+      f Level{ltile} =+        PointArray.mapA (toEnum . Tile.alterMinWalk coTileSpeedup) ltile+  in EM.map f $ sdungeon s++aspectRecordFromItem :: DiscoveryKind -> DiscoveryAspect -> ItemId -> Item+                     -> AspectRecord+aspectRecordFromItem disco discoAspect iid itemBase =+  case EM.lookup iid discoAspect of+    Just ar -> ar+    Nothing -> case EM.lookup (jkindIx itemBase) disco of+        Just KindMean{kmMean} -> kmMean+        Nothing -> emptyAspectRecord++aspectRecordFromItemClient :: MonadClient m => ItemId -> Item -> m AspectRecord+aspectRecordFromItemClient iid itemBase = do+  disco <- getsClient sdiscoKind+  discoAspect <- getsClient sdiscoAspect+  return $! aspectRecordFromItem disco discoAspect iid itemBase++aspectRecordFromActorState :: DiscoveryKind -> DiscoveryAspect -> Actor -> State+                           -> AspectRecord+aspectRecordFromActorState disco discoAspect b s =+  let processIid (iid, (k, _)) =+        let itemBase = getItemBody iid s+            ar = aspectRecordFromItem disco discoAspect iid itemBase+        in (ar, k)+      processBag ass = sumAspectRecord $ map processIid ass+  in processBag $ EM.assocs (borgan b) ++ EM.assocs (beqp b)++aspectRecordFromActorClient :: MonadClient m+                            => Actor -> [(ItemId, Item)] -> m AspectRecord+aspectRecordFromActorClient b ais = do+  disco <- getsClient sdiscoKind+  discoAspect <- getsClient sdiscoAspect+  s <- getState+  let f (iid, itemBase) = EM.insert iid itemBase+      sAis = updateItemD (\itemD -> foldr f itemD ais) s+  return $! aspectRecordFromActorState disco discoAspect b sAis++createSactorAspect :: MonadClient m => State -> m ActorAspect+createSactorAspect s = do+  disco <- getsClient sdiscoKind+  discoAspect <- getsClient sdiscoAspect+  let f b = aspectRecordFromActorState disco discoAspect b s+  return $! EM.map f $ sactorD s

− Game/LambdaHack/Client/HandleAtomicClient.hs

@@ -1,382 +0,0 @@-{-# LANGUAGE TupleSections #-}--- | Handle atomic commands received by the client.-module Game.LambdaHack.Client.HandleAtomicClient-  ( cmdAtomicSemCli, cmdAtomicFilterCli-  ) where--import Control.Applicative-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Maybe-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Atomic-import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Content.ItemKind (ItemKind)-import qualified Game.LambdaHack.Content.TileKind as TK---- * RespUpdAtomicAI---- | Clients keep a subset of atomic commands sent by the server--- and add some of their own. The result of this function is the list--- of commands kept for each command received.-cmdAtomicFilterCli :: MonadClient m => UpdAtomic -> m [UpdAtomic]-cmdAtomicFilterCli cmd = case cmd of-  UpdAlterTile lid p fromTile toTile -> do-    Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops-    lvl <- getLevel lid-    let t = lvl `at` p-    if t == fromTile-      then return [cmd]-      else do-        -- From @UpdAlterTile@ we know @t == freshClientTile@,-        -- which is uncanny, so we produce a message.-        -- It happens when a client thinks the tile is @t@,-        -- but it's @fromTile@, and @UpdAlterTile@ changes it-        -- to @toTile@. See @updAlterTile@.-        let subject = ""  -- a hack, we we don't handle adverbs well-            verb = "turn into"-            msg = makeSentence [ "the", MU.Text $ TK.tname $ okind t-                               , "at position", MU.Text $ tshow p-                               , "suddenly"  -- adverb-                               , MU.SubjectVerbSg subject verb-                               , MU.AW $ MU.Text $ TK.tname $ okind toTile ]-        return [ cmd  -- reveal the tile-               , UpdMsgAll msg  -- show the message-               ]-  UpdSearchTile aid p fromTile toTile -> do-    b <- getsState $ getActorBody aid-    lvl <- getLevel $ blid b-    let t = lvl `at` p-    return $!-      if t == fromTile-      then -- Fully ignorant. (No intermediate knowledge possible.)-           [ cmd  -- show the message-           , UpdAlterTile (blid b) p fromTile toTile  -- reveal tile-           ]-      else assert (t == toTile `blame` "LoseTile fails to reset memory"-                               `twith` (aid, p, fromTile, toTile, b, t, cmd))-                  [cmd]  -- Already knows the tile fully, only confirm.-  UpdLearnSecrets aid fromS _toS -> do-    b <- getsState $ getActorBody aid-    lvl <- getLevel $ blid b-    return $! [cmd | lsecret lvl == fromS]  -- secrets not revealed previously-  UpdSpotTile lid ts -> do-    Kind.COps{cotile} <- getsState scops-    lvl <- getLevel lid-    -- We ignore the server resending us hidden versions of the tiles-    -- (and resending us the same data we already got).-    -- If the tiles are changed to other variants of the hidden tile,-    -- we can still verify by searching, and the UI warns us "obscured".-    let notKnown (p, t) = let tClient = lvl `at` p-                          in t /= tClient-                             && (not (knownLsecret lvl && isSecretPos lvl p)-                                 || t /= Tile.hideAs cotile tClient)-        newTs = filter notKnown ts-    return $! if null newTs then [] else [UpdSpotTile lid newTs]-  UpdDiscover c iid _ seed ldepth -> do-    itemD <- getsState sitemD-    case EM.lookup iid itemD of-      Nothing -> return []-      Just item -> do-        discoKind <- getsClient sdiscoKind-        if jkindIx item `EM.member` discoKind-          then do-            discoEffect <- getsClient sdiscoEffect-            if iid `EM.member` discoEffect-              then return []-              else return [UpdDiscoverSeed c iid seed ldepth]-          else return [cmd]-  UpdCover c iid ik _ _ -> do-    itemD <- getsState sitemD-    case EM.lookup iid itemD of-      Nothing -> return []-      Just item -> do-        discoKind <- getsClient sdiscoKind-        if jkindIx item `EM.notMember` discoKind-          then return []-          else do-            discoEffect <- getsClient sdiscoEffect-            if iid `EM.notMember` discoEffect-              then return [cmd]-              else return [UpdCoverKind c iid ik]-  UpdDiscoverKind _ iid _ -> do-    itemD <- getsState sitemD-    case EM.lookup iid itemD of-      Nothing -> return []-      Just item -> do-        discoKind <- getsClient sdiscoKind-        if jkindIx item `EM.notMember` discoKind-        then return []-        else return [cmd]-  UpdCoverKind _ iid _ -> do-    itemD <- getsState sitemD-    case EM.lookup iid itemD of-      Nothing -> return []-      Just item -> do-        discoKind <- getsClient sdiscoKind-        if jkindIx item `EM.notMember` discoKind-        then return []-        else return [cmd]-  UpdDiscoverSeed _ iid _ _ -> do-    itemD <- getsState sitemD-    case EM.lookup iid itemD of-      Nothing -> return []-      Just item -> do-        discoKind <- getsClient sdiscoKind-        if jkindIx item `EM.notMember` discoKind-        then return []-        else do-          discoEffect <- getsClient sdiscoEffect-          if iid `EM.member` discoEffect-            then return []-            else return [cmd]-  UpdCoverSeed _ iid _ _ -> do-    itemD <- getsState sitemD-    case EM.lookup iid itemD of-      Nothing -> return []-      Just item -> do-        discoKind <- getsClient sdiscoKind-        if jkindIx item `EM.notMember` discoKind-        then return []-        else do-          discoEffect <- getsClient sdiscoEffect-          if iid `EM.notMember` discoEffect-            then return []-            else return [cmd]-  UpdPerception lid outPer inPer -> do-    -- Here we cheat by setting a new perception outright instead of-    -- in @cmdAtomicSemCli@, to avoid computing perception twice.-    -- TODO: try to assert similar things as for @atomicRemember@:-    -- that posUpdAtomic of all the Lose* commands was visible in old Per,-    -- but is not visible any more.-    perOld <- getPerFid lid-    perception lid outPer inPer-    perNew <- getPerFid lid-    carriedAssocs <- getsState $ flip getCarriedAssocs-    fid <- getsClient sside-    s <- getState-    -- Wipe out actors that just became invisible due to changed FOV.-    -- Worst case is many actors O(n) in an open room of large diameter O(m).-    -- Then a step reveals many positions. Iterating over them via @posToActors@-    -- takes O(m * n) and so is more cosly than interating over all actors-    -- and for each checking inclusion in a set of positions O(n * log m).-    -- OTOH, m is bounded by sight radius and n is unbounded, so we have-    -- O(n) in both cases, especially with huge levels. To help there,-    -- we'd need to keep a dictionary from positions to actors, which means-    -- @posToActors@ is the right approach for now.-    let seenNew = seenAtomicCli False fid perNew-        seenOld = seenAtomicCli False fid perOld-        outFov = totalVisible perOld ES.\\ totalVisible perNew-        outPrio = concatMap (\p -> posToActors p lid s) $ ES.elems outFov-        fActor (aid, b) =-          let ps = posProjBody b-              -- Verify that we forget only previously seen actors.-              !_A = assert (seenOld ps) ()-          in -- We forget only currently invisible actors.-             if seenNew ps-             then Nothing-             else -- Verify that we forget only previously seen actors.-                  let !_A = assert (seenOld ps) ()-                      ais = carriedAssocs b-                  in Just $ UpdLoseActor aid b ais-        outActor = mapMaybe fActor outPrio-    -- Wipe out remembered items on tiles that now came into view.-    lvl <- getLevel lid-    let inFov = ES.elems $ totalVisible perNew ES.\\ totalVisible perOld-        pMaybe p = maybe Nothing (\x -> Just (p, x))-        inContainer fc itemFloor =-          let inItem = mapMaybe (\p -> pMaybe p $ EM.lookup p itemFloor) inFov-              fItem p (iid, kit) =-                UpdLoseItem 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 lvl))-                        (ES.elems inSmellFov)-        inSmell = if null inSm then [] else [UpdLoseSmell lid inSm]-    let inTileSmell = inFloor ++ inEmbed ++ inSmell-    psItemSmell <- mapM posUpdAtomic inTileSmell-    -- Verify that we forget only previously invisible items and smell.-    let !_A = assert (allB (not . seenOld) psItemSmell) ()-    -- Verify that we forget only currently seen items and smell.-    let !_A = assert (allB seenNew psItemSmell) ()-    return $! cmd : outActor ++ inTileSmell-  _ -> return [cmd]---- | Effect of atomic actions on client state is calculated--- in the global state before the command is executed.-cmdAtomicSemCli :: MonadClient m => UpdAtomic -> m ()-cmdAtomicSemCli cmd = case cmd of-  UpdCreateActor aid body _ -> createActor aid body-  UpdDestroyActor aid b _ -> destroyActor aid b True-  UpdSpotActor aid body _ -> createActor aid body-  UpdLoseActor aid b _ -> destroyActor aid b False-  UpdLeadFaction fid source target -> do-    side <- getsClient sside-    when (side == fid) $ do-      mleader <- getsClient _sleader-      let !_A = assert (mleader == fmap fst source  -- somebody changed the leader for us-                        || mleader == fmap fst target  -- we changed the leader ourselves-                        `blame` "unexpected leader"-                        `twith` (cmd, mleader)) ()-      modifyClient $ \cli -> cli {_sleader = fmap fst target}-      case target of-        Nothing -> return ()-        Just (aid, mtgt) ->-          modifyClient $ \cli ->-            cli {stargetD = EM.alter (const $ (,Nothing) <$> mtgt)-                                     aid (stargetD cli)}-  UpdAutoFaction{} -> do-    -- Clear all targets except the leader's.-    mleader <- getsClient _sleader-    mtgt <- case mleader of-      Nothing -> return Nothing-      Just leader -> getsClient $ EM.lookup leader . stargetD-    modifyClient $ \cli ->-      cli { stargetD = case (mtgt, mleader) of-              (Just tgt, Just leader) -> EM.singleton leader tgt-              _ -> EM.empty }-  UpdDiscover c iid ik seed ldepth -> do-    discoverKind c iid ik-    discoverSeed c iid seed ldepth-  UpdCover c iid ik seed _ldepth -> do-    coverSeed c iid seed-    coverKind c iid ik-  UpdDiscoverKind c iid ik -> discoverKind c iid ik-  UpdCoverKind c iid ik -> coverKind c iid ik-  UpdDiscoverSeed c iid seed  ldepth -> discoverSeed c iid seed ldepth-  UpdCoverSeed c iid seed _ldepth -> coverSeed c iid seed-  UpdPerception lid outPer inPer -> perception lid outPer inPer-  UpdRestart side sdiscoKind sfper _ d sdebugCli -> do-    shistory <- getsClient shistory-    sreport <- getsClient sreport-    isAI <- getsClient sisAI-    snxtDiff <- getsClient snxtDiff-    let cli = defStateClient shistory sreport side isAI-    putClient cli { sdiscoKind-                  , sfper-                  -- , sundo = [UpdAtomic cmd]-                  , scurDiff = d-                  , snxtDiff-                  , sdebugCli }-  UpdResume _fid sfper -> modifyClient $ \cli -> cli {sfper}-  UpdKillExit _fid -> killExit-  UpdWriteSave -> saveClient-  _ -> return ()--createActor :: MonadClient m => ActorId -> Actor -> m ()-createActor aid _b = do-  let affect tgt = case tgt of-        TEnemyPos a _ _ permit | a == aid -> TEnemy a permit-        _ -> tgt-      affect3 (tgt, mpath) = case tgt of-        TEnemyPos a _ _ permit | a == aid -> (TEnemy a permit, Nothing)-        _ -> (tgt, mpath)-  modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}-  modifyClient $ \cli -> cli {scursor = affect $ scursor cli}--destroyActor :: MonadClient m => ActorId -> Actor -> Bool -> m ()-destroyActor aid b destroy = do-  when destroy $ modifyClient $ updateTarget aid (const Nothing)  -- gc-  modifyClient $ \cli -> cli {sbfsD = EM.delete aid $ sbfsD cli}  -- gc-  let affect tgt = case tgt of-        TEnemy a permit | a == aid -> TEnemyPos a (blid b) (bpos b) permit-          -- Don't heed @destroy@, because even if actor dead, it makes-          -- sense to go to last known location to loot or find others.-        _ -> tgt-      affect3 (tgt, mpath) =-        let newMPath = case mpath of-              Just (_, (goal, _)) | goal /= bpos b -> Nothing-              _ -> mpath  -- foe slow enough, so old path good-        in (affect tgt, newMPath)-  modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}-  modifyClient $ \cli -> cli {scursor = affect $ scursor cli}--perception :: MonadClient m => LevelId -> Perception -> Perception -> m ()-perception lid outPer inPer = do-  -- Clients can't compute FOV on their own, because they don't know-  -- if unknown tiles are clear or not. Server would need to send-  -- info about properties of unknown tiles, which complicates-  -- and makes heavier the most bulky data set in the game: tile maps.-  -- Note we assume, but do not check that @outPer@ is contained-  -- in current perception and @inPer@ has no common part with it.-  -- It would make the already very costly operation even more expensive.-  perOld <- getPerFid lid-  -- Check if new perception is already set in @cmdAtomicFilterCli@-  -- or if we are doing undo/redo, which does not involve filtering.-  -- The data structure is strict, so the cheap check can't be any simpler.-  let interAlready per =-        Just $ totalVisible per `ES.intersection` totalVisible perOld-      unset = maybe False ES.null (interAlready inPer)-              || maybe False (not . ES.null) (interAlready outPer)-  when unset $ do-    let adj Nothing = assert `failure` "no perception to alter" `twith` lid-        adj (Just per) = Just $ addPer (diffPer per outPer) inPer-        f = EM.alter adj lid-    modifyClient $ \cli -> cli {sfper = f (sfper cli)}--discoverKind :: MonadClient m-             => Container -> ItemId -> Kind.Id ItemKind -> m ()-discoverKind c iid ik = do-  item <- getsState $ getItemBody iid-  let f Nothing = Just ik-      f Just{} = assert `failure` "already discovered"-                        `twith` (c, iid, ik)-  modifyClient $ \cli -> cli {sdiscoKind = EM.alter f (jkindIx item) (sdiscoKind cli)}--coverKind :: MonadClient m-          => Container -> ItemId -> Kind.Id ItemKind -> m ()-coverKind c iid ik = do-  item <- getsState $ getItemBody iid-  let f Nothing = assert `failure` "already covered" `twith` (c, iid, ik)-      f (Just ik2) = assert (ik == ik2 `blame` "unexpected covered item kind"-                                       `twith` (ik, ik2)) Nothing-  modifyClient $ \cli -> cli {sdiscoKind = EM.alter f (jkindIx item) (sdiscoKind cli)}--discoverSeed :: MonadClient m-             => Container -> ItemId -> ItemSeed -> AbsDepth -> m ()-discoverSeed c iid seed ldepth = do-  Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops-  discoKind <- getsClient sdiscoKind-  item <- getsState $ getItemBody iid-  totalDepth <- getsState stotalDepth-  case EM.lookup (jkindIx item) discoKind of-    Nothing -> assert `failure` "kind not known"-                      `twith` (c, iid, seed)-    Just ik -> do-      let kind = okind ik-          f Nothing = Just $ seedToAspectsEffects seed kind ldepth totalDepth-          f Just{} = assert `failure` "already discovered"-                            `twith` (c, iid, seed)-      modifyClient $ \cli -> cli {sdiscoEffect = EM.alter f iid (sdiscoEffect cli)}--coverSeed :: MonadClient m-          => Container -> ItemId -> ItemSeed -> m ()-coverSeed c iid seed = do-  let f Nothing = assert `failure` "already covered" `twith` (c, iid, seed)-      f Just{} = Nothing  -- checking that old and new agree is too much work-  modifyClient $ \cli -> cli {sdiscoEffect = EM.alter f iid (sdiscoEffect cli)}--killExit :: MonadClient m => m ()-killExit = modifyClient $ \cli -> cli {squit = True}

+ Game/LambdaHack/Client/HandleAtomicM.hs view

@@ -0,0 +1,581 @@+-- | Handle atomic commands received by the client.+module Game.LambdaHack.Client.HandleAtomicM+  ( cmdAtomicSemCli, cmdAtomicFilterCli+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.Map.Strict as M+import Data.Ord+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Atomic+import Game.LambdaHack.Client.Bfs+import Game.LambdaHack.Client.BfsM+import Game.LambdaHack.Client.CommonM+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.Preferences+import Game.LambdaHack.Client.State+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Perception+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Content.ItemKind as IK+import Game.LambdaHack.Content.ModeKind (ModeKind)+import Game.LambdaHack.Content.TileKind (TileKind)+import qualified Game.LambdaHack.Content.TileKind as TK++-- * RespUpdAtomicAI++-- | Clients keep a subset of atomic commands sent by the server+-- and add some of their own. The result of this function is the list+-- of commands kept for each command received.+cmdAtomicFilterCli :: MonadClient m => UpdAtomic -> m [UpdAtomic]+{-# INLINE cmdAtomicFilterCli #-}+cmdAtomicFilterCli cmd = case cmd of+  UpdSpotActor aid _ _ -> do+    -- Needed, e.g., when we teleport and so see our actor at the new+    -- location, but also the location is part of new perception,+    -- so @UpdSpotActor@ is sent.+    alreadyAdded <- getsState $ EM.member aid . sactorD+    return $! if alreadyAdded then [] else [cmd]+  UpdAlterTile lid p fromTile toTile -> do+    Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops+    lvl <- getLevel lid+    let t = lvl `at` p+    if t == fromTile+      then return [cmd]+      else do+        -- From @UpdAlterTile@ we know @t == freshClientTile@,+        -- which is uncanny, so we produce a message.+        -- It happens when a client thinks the tile is @t@,+        -- but it's @fromTile@, and @UpdAlterTile@ changes it+        -- to @toTile@. See @updAlterTile@.+        let subject = ""  -- a hack, we we don't handle adverbs well+            verb = "turn into"+            msg = makeSentence [ "the", MU.Text $ TK.tname $ okind t+                               , "at position", MU.Text $ tshow p+                               , "suddenly"  -- adverb+                               , MU.SubjectVerbSg subject verb+                               , MU.AW $ MU.Text $ TK.tname $ okind toTile ]+        return [ cmd  -- reveal the tile+               , UpdMsgAll msg  -- show the message+               ]+  UpdSearchTile aid p toTile -> do+    Kind.COps{cotile} <- getsState scops+    b <- getsState $ getActorBody aid+    lvl <- getLevel $ blid b+    let t = lvl `at` p+        fromTile = Tile.hideAs cotile toTile+    return $!+      if t == fromTile+      then -- Fully ignorant. (No intermediate knowledge possible.)+           [ cmd  -- show the message+           , UpdAlterTile (blid b) p fromTile toTile  -- reveal tile+           ]+      else assert (t == toTile `blame` "LoseTile fails to reset memory"+                               `twith` (aid, p, fromTile, toTile, b, t, cmd))+                  [cmd]  -- Already knows the tile fully, only confirm.+  UpdHideTile{} -> return []  -- will be fleshed out when Undo completed+  UpdSpotTile lid ts -> do+    Kind.COps{cotile} <- getsState scops+    lvl <- getLevel lid+    -- We ignore the server resending us hidden versions of the tiles+    -- (and resending us the same data we already got).+    -- If the tiles are changed to other variants of the hidden tile,+    -- we can still verify by searching.+    let notKnown (p, t) = let tClient = lvl `at` p+                          in Tile.hideAs cotile tClient /= t+        newTs = filter notKnown ts+    return $! if null newTs then [] else [UpdSpotTile lid newTs]+  UpdDiscover c iid _ seed -> do+    itemD <- getsState sitemD+    case EM.lookup iid itemD of+      Nothing -> return []+      Just item -> do+        discoKind <- getsClient sdiscoKind+        if jkindIx item `EM.member` discoKind+          then do+            discoAspect <- getsClient sdiscoAspect+            if iid `EM.member` discoAspect+              then return []+              else return [UpdDiscoverSeed c iid seed]+          else return [cmd]+  UpdCover c iid ik _ -> do+    itemD <- getsState sitemD+    case EM.lookup iid itemD of+      Nothing -> return []+      Just item -> do+        discoKind <- getsClient sdiscoKind+        if jkindIx item `EM.notMember` discoKind+          then return []+          else do+            discoAspect <- getsClient sdiscoAspect+            if iid `EM.notMember` discoAspect+              then return [cmd]+              else return [UpdCoverKind c iid ik]+  UpdDiscoverKind _ iid _ -> do+    itemD <- getsState sitemD+    case EM.lookup iid itemD of+      Nothing -> return []+      Just item -> do+        discoKind <- getsClient sdiscoKind+        if jkindIx item `EM.notMember` discoKind+        then return []+        else return [cmd]+  UpdCoverKind _ iid _ -> do+    itemD <- getsState sitemD+    case EM.lookup iid itemD of+      Nothing -> return []+      Just item -> do+        discoKind <- getsClient sdiscoKind+        if jkindIx item `EM.notMember` discoKind+        then return []+        else return [cmd]+  UpdDiscoverSeed _ iid _ -> do+    itemD <- getsState sitemD+    case EM.lookup iid itemD of+      Nothing -> return []+      Just item -> do+        discoKind <- getsClient sdiscoKind+        if jkindIx item `EM.notMember` discoKind+        then return []+        else do+          discoAspect <- getsClient sdiscoAspect+          if iid `EM.member` discoAspect+            then return []+            else return [cmd]+  UpdCoverSeed _ iid _ -> do+    itemD <- getsState sitemD+    case EM.lookup iid itemD of+      Nothing -> return []+      Just item -> do+        discoKind <- getsClient sdiscoKind+        if jkindIx item `EM.notMember` discoKind+        then return []+        else do+          discoAspect <- getsClient sdiscoAspect+          if iid `EM.notMember` discoAspect+            then return []+            else return [cmd]+  UpdPerception lid outPer inPer -> do+    -- Here we cheat by setting a new perception outright instead of+    -- in @cmdAtomicSemCli@, to avoid computing perception twice.+    perOld <- getPerFid lid+    perception lid outPer inPer+    perNew <- getPerFid lid+    carriedAssocs <- getsState $ flip getCarriedAssocs+    fid <- getsClient sside+    s <- getState+    -- Wipe out actors that just became invisible due to changed FOV.+    let seenNew = seenAtomicCli False fid perNew+        seenOld = seenAtomicCli False fid perOld+        outFov = totalVisible outPer+        outPrio = concatMap (\p -> posToAssocs p lid s) $ ES.elems outFov+        fActor (aid, b) =+          let ps = posProjBody b+              -- Verify that we forget only previously seen actors.+              !_A = assert (seenOld ps) ()+          in -- We forget only currently invisible actors.+             if seenNew ps+             then Nothing+             else Just $ UpdLoseActor aid b $ carriedAssocs b+        outActor = mapMaybe fActor outPrio+    -- Wipe out remembered items on tiles that now came into view.+    lvl <- getLevel lid+    let inFov = ES.elems $ totalVisible inPer+        pMaybe p = maybe Nothing (\x -> Just (p, x))+        inContainer fc itemFloor =+          let inItem = mapMaybe (\p -> pMaybe p $ EM.lookup p itemFloor) inFov+              fItem p (iid, kit) =+                UpdLoseItem True iid (getItemBody iid s) kit (fc lid p)+              fBag (p, bag) = map (fItem p) $ EM.assocs bag+          in concatMap fBag inItem+        inFloor = inContainer CFloor (lfloor lvl)+        inEmbed = inContainer CEmbed (lembed lvl)+    -- Remembered map tiles not wiped out, due to optimization in @updSpotTile@.+    -- Wipe out remembered smell on tiles that now came into smell Fov.+    let inSmellFov = totalSmelled inPer+        inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p (lsmell lvl))+                        (ES.elems inSmellFov)+        inSmell = if null inSm then [] else [UpdLoseSmell lid inSm]+    let inTileSmell = inFloor ++ inEmbed ++ inSmell+    psItemSmell <- mapM posUpdAtomic inTileSmell+    -- Verify that we forget only previously invisible items and smell.+    let !_A = assert (allB (not . seenOld) psItemSmell) ()+    -- Verify that we forget only currently seen items and smell.+    let !_A = assert (allB seenNew psItemSmell) ()+    return $! cmd : outActor ++ inTileSmell+  _ -> return [cmd]++-- | Effect of atomic actions on client state is calculated+-- with the global state from before the command is executed.+cmdAtomicSemCli :: MonadClientSetup m => UpdAtomic -> m ()+{-# INLINE cmdAtomicSemCli #-}+cmdAtomicSemCli cmd = case cmd of+  UpdCreateActor aid b ais -> createActor aid b ais+  UpdDestroyActor aid b _ -> destroyActor aid b True+  UpdCreateItem iid itemBase (k, _) (CActor aid store) -> do+    wipeBfsIfItemAffectsSkills [store] aid+    when (store `elem` [CEqp, COrgan]) $ addItemToActor iid itemBase k aid+    addItemToDiscoBenefit iid itemBase+  UpdCreateItem iid itemBase _ _ -> addItemToDiscoBenefit iid itemBase+  UpdDestroyItem iid itemBase (k, _) (CActor aid store) -> do+    wipeBfsIfItemAffectsSkills [store] aid+    when (store `elem` [CEqp, COrgan]) $ addItemToActor iid itemBase (-k) aid+  UpdSpotActor aid b ais -> createActor aid b ais+  UpdLoseActor aid b _ -> destroyActor aid b False+  UpdSpotItem _ iid itemBase (k, _) (CActor aid store) -> do+    wipeBfsIfItemAffectsSkills [store] aid+    when (store `elem` [CEqp, COrgan]) $ addItemToActor iid itemBase k aid+    addItemToDiscoBenefit iid itemBase+  UpdSpotItem _ iid itemBase _ _ -> addItemToDiscoBenefit iid itemBase+  UpdLoseItem _ iid itemBase (k, _) (CActor aid store) -> do+    wipeBfsIfItemAffectsSkills [store] aid+    when (store `elem` [CEqp, COrgan]) $ addItemToActor iid itemBase (-k) aid+  UpdMoveActor aid _ _ -> invalidateBfsAid aid+  UpdDisplaceActor source target -> do+    invalidateBfsAid source+    invalidateBfsAid target+  UpdMoveItem iid k aid s1 s2 -> do+    wipeBfsIfItemAffectsSkills [s1, s2] aid+    case s1 of+      CEqp -> case s2 of+        COrgan -> return ()+        _ -> do+          itemBase <- getsState $ getItemBody iid+          addItemToActor iid itemBase (-k) aid+      COrgan -> case s2 of+        CEqp -> return ()+        _ -> do+          itemBase <- getsState $ getItemBody iid+          addItemToActor iid itemBase (-k) aid+      _ ->+        when (s2 `elem` [CEqp, COrgan]) $ do+          itemBase <- getsState $ getItemBody iid+          addItemToActor iid itemBase k aid+  UpdLeadFaction fid source target -> do+    side <- getsClient sside+    when (side == fid) $ do+      mleader <- getsClient _sleader+      let !_A = assert (mleader == source+                          -- somebody changed the leader for us+                        || mleader == target+                          -- we changed the leader ourselves+                        `blame` "unexpected leader"+                        `twith` (cmd, mleader)) ()+      modifyClient $ \cli -> cli {_sleader = target}+  UpdAutoFaction{} ->+    -- @condBFS@ depends on the setting we change here (e.g., smarkSuspect).+    invalidateBfsAll+  UpdTacticFaction{} -> do+    -- Clear all targets except the leader's.+    mleader <- getsClient _sleader+    mtgt <- case mleader of+      Nothing -> return Nothing+      Just leader -> getsClient $ EM.lookup leader . stargetD+    modifyClient $ \cli ->+      cli { stargetD = case (mtgt, mleader) of+              (Just tgt, Just leader) -> EM.singleton leader tgt+              _ -> EM.empty }+  UpdAlterTile lid pos _fromTile toTile -> do+    updateSalter lid [(pos, toTile)]+    cops <- getsState scops+    lvl <- getLevel lid+    let assumedTile = lvl `at` pos+    when (tileChangeAffectsBfs cops assumedTile toTile) $+      invalidateBfsLid lid+  UpdSpotTile lid ts -> do+    updateSalter lid ts+    cops <- getsState scops+    lvl <- getLevel lid+    let affects (pos, toTile) =+          let fromTile = lvl `at` pos+          in tileChangeAffectsBfs cops fromTile toTile+        bs = map affects ts+    when (or bs) $ invalidateBfsLid lid+  UpdLoseTile lid ts -> do+    updateSalter lid ts+    invalidateBfsLid lid  -- from known to unknown tiles+  UpdAgeGame arenas ->+    -- This tweak is only needed in AI client, but it's fairly cheap.+    modifyClient $ \cli ->+      let g !em !lid = EM.adjust (const Nothing) lid em+      in cli {scondInMelee = foldl' g (scondInMelee cli) arenas}+  UpdDiscover c iid ik seed -> do+    discoverKind c iid ik+    discoverSeed c iid seed+  UpdCover c iid ik seed -> do+    coverSeed c iid seed+    coverKind c iid ik+  UpdDiscoverKind c iid ik -> discoverKind c iid ik+  UpdCoverKind c iid ik -> coverKind c iid ik+  UpdDiscoverSeed c iid seed -> discoverSeed c iid seed+  UpdCoverSeed c iid seed -> coverSeed c iid seed+  -- UpdPerception lid outPer inPer -> perception lid outPer inPer+  UpdRestart side sdiscoKind sfper s scurChal sdebugCli -> do+    Kind.COps{comode=Kind.Ops{ofoldlGroup'}} <- getsState scops+    snxtChal <- getsClient snxtChal+    svictories <- getsClient svictories+    let f acc _p i _a = i : acc+        modes = zip [0..] $ ofoldlGroup' "campaign scenario" f []+        g :: (Int, Kind.Id ModeKind) -> Int+        g (_, mode) = case EM.lookup mode svictories of+          Nothing -> 0+          Just cm -> fromMaybe 0 (M.lookup snxtChal cm)+        (snxtScenario, _) = minimumBy (comparing g) modes+        cli = emptyStateClient side+    putClient cli { sdiscoKind+                  , sfper+                  -- , sundo = [UpdAtomic cmd]+                  , scurChal+                  , snxtChal+                  , snxtScenario+                  , scondInMelee = EM.map (const Nothing) (sdungeon s)+                  , svictories+                  , sdebugCli }+    modifyClient $ \cli1 -> cli1 {salter = createSalter s}+    -- Currently always void, because no actors yet:+    sactorAspect <- createSactorAspect s+    modifyClient $ \cli1 -> cli1 {sactorAspect}+    restartClient+  UpdResume _fid sfperNew -> do+#ifdef WITH_EXPENSIVE_ASSERTIONS+    sfperOld <- getsClient sfper+    let !_A = assert (sfperNew == sfperOld `blame` (sfperNew, sfperOld)) ()+#endif+    modifyClient $ \cli -> cli {sfper=sfperNew}+    s <- getState+    modifyClient $ \cli -> cli {salter = createSalter s}+    sactorAspect <- createSactorAspect s+    modifyClient $ \cli -> cli {sactorAspect}+  UpdKillExit _fid -> killExit+  UpdWriteSave -> saveClient+  _ -> return ()++-- For now, only checking the stores.+wipeBfsIfItemAffectsSkills :: MonadClient m => [CStore] -> ActorId -> m ()+wipeBfsIfItemAffectsSkills stores aid =+  unless (null $ intersect stores [CEqp, COrgan]) $ invalidateBfsAid aid++tileChangeAffectsBfs :: Kind.COps+                     -> Kind.Id TileKind -> Kind.Id TileKind+                     -> Bool+tileChangeAffectsBfs Kind.COps{coTileSpeedup} fromTile toTile =+  Tile.alterMinWalk coTileSpeedup fromTile+  /= Tile.alterMinWalk coTileSpeedup toTile++createActor :: MonadClient m => ActorId -> Actor -> [(ItemId, Item)] -> m ()+createActor aid b ais = do+  let affect3 tap@TgtAndPath{..} = case tapTgt of+        TPoint (TEnemyPos a permit) _ _ | a == aid ->+          TgtAndPath (TEnemy a permit) NoPath+        _ -> tap+  modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}+  aspectRecord <- aspectRecordFromActorClient b ais+  let f = EM.insert aid aspectRecord+  modifyClient $ \cli -> cli {sactorAspect = f $ sactorAspect cli}+  mapM_ (uncurry addItemToDiscoBenefit) ais++destroyActor :: MonadClient m => ActorId -> Actor -> Bool -> m ()+destroyActor aid b destroy = do+  when destroy $ modifyClient $ updateTarget aid (const Nothing)  -- gc+  modifyClient $ \cli -> cli {sbfsD = EM.delete aid $ sbfsD cli}  -- gc+  let affect tgt = case tgt of+        TEnemy a permit | a == aid ->+          if destroy then+            -- If *really* nothing more interesting, the actor will+            -- go to last known location to perhaps find other foes.+            TPoint TAny (blid b) (bpos b)+          else+            -- If enemy only hides (or we stepped behind obstacle) find him.+            TPoint (TEnemyPos a permit) (blid b) (bpos b)+        _ -> tgt+      affect3 TgtAndPath{..} =+        let newMPath = case tapPath of+              AndPath{pathGoal} | pathGoal /= bpos b -> NoPath+              _ -> tapPath  -- foe slow enough, so old path good+        in TgtAndPath (affect tapTgt) newMPath+  modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}+  let f = EM.delete aid+  modifyClient $ \cli -> cli {sactorAspect = f $ sactorAspect cli}++addItemToActor :: MonadClient m => ItemId -> Item -> Int -> ActorId -> m ()+addItemToActor iid itemBase k aid = do+  arItem <- aspectRecordFromItemClient iid itemBase+  let g arActor = sumAspectRecord [(arActor, 1), (arItem, k)]+      f = EM.adjust g aid+  modifyClient $ \cli -> cli {sactorAspect = f $ sactorAspect cli}++addItemToDiscoBenefit :: MonadClient m => ItemId -> Item -> m ()+addItemToDiscoBenefit iid item = do+  cops@Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops+  discoBenefit <- getsClient sdiscoBenefit+  case EM.lookup iid discoBenefit of+    Just{} -> return ()  -- already there+    Nothing -> do+      discoKind <- getsClient sdiscoKind+      case EM.lookup (jkindIx item) discoKind of+        Nothing -> return ()+        Just KindMean{..} -> do  -- possible, if the kind sent in @UpdRestart@+          side <- getsClient sside+          fact <- getsState $ (EM.! side) . sfactionD+          let effects = IK.ieffects $ okind kmKind+              benefit = totalUsefulness cops fact effects kmMean item+          modifyClient $ \cli ->+            cli {sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli)}++perception :: MonadClient m => LevelId -> Perception -> Perception -> m ()+perception lid outPer inPer = do+  -- Clients can't compute FOV on their own, because they don't know+  -- if unknown tiles are clear or not. Server would need to send+  -- info about properties of unknown tiles, which complicates+  -- and makes heavier the most bulky data set in the game: tile maps.+  -- Note we assume, but do not check that @outPer@ is contained+  -- in current perception and @inPer@ has no common part with it.+  -- It would make the already very costly operation even more expensive.+{-+  perOld <- getPerFid lid+  -- Check if new perception is already set in @cmdAtomicFilterCli@+  -- or if we are doing undo/redo, which does not involve filtering.+  -- The data structure is strict, so the cheap check can't be any simpler.+  let interAlready per =+        Just $ totalVisible per `ES.intersection` totalVisible perOld+      unset = maybe False ES.null (interAlready inPer)+              || maybe False (not . ES.null) (interAlready outPer)+  when unset $ do+-}+    let adj Nothing = assert `failure` "no perception to alter" `twith` lid+        adj (Just per) = Just $ addPer (diffPer per outPer) inPer+        f = EM.alter adj lid+    modifyClient $ \cli -> cli {sfper = f (sfper cli)}++discoverKind :: MonadClient m => Container -> ItemId -> Kind.Id ItemKind -> m ()+discoverKind c iid kmKind = do+  cops@Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops+  -- Wipe out BFS, because the player could potentially learn that his items+  -- affect his actors' skills relevant to BFS.+  invalidateBfsAll+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  item <- getsState $ getItemBody iid+  let kind = okind kmKind+      kmMean = meanAspect kind+      benefit = totalUsefulness cops fact (IK.ieffects kind) kmMean item+      f Nothing = Just KindMean{..}+      f Just{} = assert `failure` "already discovered"+                        `twith` (c, iid, kmKind)+  modifyClient $ \cli ->+    cli { sdiscoKind = EM.alter f (jkindIx item) (sdiscoKind cli)+        , sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli) }+  -- Each actor's equipment and organs would need to be inspected,+  -- the iid looked up, e.g., if it wasn't in old discoKind, but is in new,+  -- and then aspect record updated, so it's simpler and not much more+  -- expensive to generate new sactorAspect. Optimize only after profiling.+  s <- getState+  sactorAspect <- createSactorAspect s+  modifyClient $ \cli -> cli {sactorAspect}++coverKind :: MonadClient m => Container -> ItemId -> Kind.Id ItemKind -> m ()+coverKind c iid ik = do+  item <- getsState $ getItemBody iid+  let f Nothing = assert `failure` "already covered" `twith` (c, iid, ik)+      f (Just KindMean{kmKind}) =+        assert (ik == kmKind `blame` "unexpected covered item kind"+                             `twith` (ik, kmKind)) Nothing+  -- For now, undoing @sdiscoBenefit@ is too much work.+  modifyClient $ \cli ->+    cli {sdiscoKind = EM.alter f (jkindIx item) (sdiscoKind cli)}+  s <- getState+  sactorAspect <- createSactorAspect s+  modifyClient $ \cli -> cli {sactorAspect}++discoverSeed :: MonadClient m => Container -> ItemId -> ItemSeed -> m ()+discoverSeed c iid seed = do+  cops@Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops+  -- Wipe out BFS, because the player could potentially learn that his items+  -- affect his actors' skills relevant to BFS.+  invalidateBfsAll+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  discoKind <- getsClient sdiscoKind+  item <- getsState $ getItemBody iid+  totalDepth <- getsState stotalDepth+  case EM.lookup (jkindIx item) discoKind of+    Nothing -> assert `failure` "kind not known"+                      `twith` (c, iid, seed)+    Just KindMean{kmKind} -> do+      Level{ldepth} <- getLevel $ jlid item+      let kind = okind kmKind+          aspects = seedToAspect seed kind ldepth totalDepth+          benefit = totalUsefulness cops fact (IK.ieffects kind) aspects item+          f Nothing = Just aspects+          f Just{} = assert `failure` "already discovered"+                            `twith` (c, iid, seed)+      modifyClient $ \cli ->+        cli { sdiscoAspect = EM.alter f iid (sdiscoAspect cli)+            , sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli) }+  s <- getState+  sactorAspect <- createSactorAspect s+  modifyClient $ \cli -> cli {sactorAspect}++coverSeed :: MonadClient m => Container -> ItemId -> ItemSeed -> m ()+coverSeed c iid seed = do+  let f Nothing = assert `failure` "already covered" `twith` (c, iid, seed)+      f Just{} = Nothing  -- checking that old and new agree is too much work+  -- For now, undoing @sdiscoBenefit@ is too much work.+  modifyClient $ \cli -> cli {sdiscoAspect = EM.alter f iid (sdiscoAspect cli)}+  s <- getState+  sactorAspect <- createSactorAspect s+  modifyClient $ \cli -> cli {sactorAspect}++killExit :: MonadClient m => m ()+killExit = do+  side <- getsClient sside+  debugPossiblyPrint $ "Client" <+> tshow side <+> "quitting."+  modifyClient $ \cli -> cli {squit = True}+  -- Verify that the not saved caches are equal to future reconstructed.+  -- Otherwise, save/restore would change game state.+  sactorAspect <- getsClient sactorAspect+  salter <- getsClient salter+  sbfsD <- getsClient sbfsD+  s <- getState+  let alter = createSalter s+  actorAspect <- createSactorAspect s+  let f aid = do+        (canMove, alterSkill) <- condBFS aid+        bfsArr <- createBfs canMove alterSkill aid+        let bfsPath = EM.empty+        return (aid, BfsAndPath{..})+  actorD <- getsState sactorD+  lbfsD <- mapM f $ EM.keys actorD+  -- Some freshly generated bfses are not used for comparison, but at least+  -- we check they don't violate internal assertions themselves. Hence the bang.+  let bfsD = EM.fromDistinctAscList lbfsD+      g BfsInvalid !_ = True+      g _ BfsInvalid = False+      g bap1 bap2 = bfsArr bap1 == bfsArr bap2+      subBfs = EM.isSubmapOfBy g+  let !_A1 = assert (salter == alter+                     `blame` ("wrong accumulated salter on" <+> tshow side)+                     `twith` (salter, alter)) ()+      !_A2 = assert (sactorAspect == actorAspect+                     `blame` ("wrong accumulated sactorAspect on"+                              <+> tshow side)+                     `twith` (sactorAspect, actorAspect)) ()+      !_A3 = assert (sbfsD `subBfs` bfsD+                     `blame` ("wrong accumulated sbfsD on" <+> tshow side)+                     `twith` (sbfsD, bfsD)) ()+  return ()

− Game/LambdaHack/Client/HandleResponseClient.hs

@@ -1,61 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--- | Semantics of client commands.-module Game.LambdaHack.Client.HandleResponseClient-  ( handleResponseAI, handleResponseUI-  ) where--import Game.LambdaHack.Atomic-import Game.LambdaHack.Client.AI-import Game.LambdaHack.Client.HandleAtomicClient-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.ProtocolClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.Response--storeUndo :: MonadClient m => CmdAtomic -> m ()-storeUndo _atomic =-  maybe (return ()) (\a -> modifyClient $ \cli -> cli {sundo = a : sundo cli})-    Nothing   -- TODO: undoCmdAtomic atomic--handleResponseAI :: (MonadAtomic m, MonadClientWriteRequest RequestAI m)-                 => ResponseAI -> m ()-handleResponseAI cmd = case cmd of-  RespUpdAtomicAI cmdA -> do-    cmds <- cmdAtomicFilterCli cmdA-    mapM_ (\c -> cmdAtomicSemCli c-                 >> execUpdAtomic c) cmds-    mapM_ (storeUndo . UpdAtomic) cmds-  RespQueryAI aid -> do-    cmdC <- queryAI aid-    sendRequest cmdC-  RespPingAI -> do-    pong <- pongAI-    sendRequest pong--handleResponseUI :: ( MonadClientUI m-                    , MonadAtomic m-                    , MonadClientWriteRequest RequestUI m )-                 => ResponseUI -> m ()-handleResponseUI cmd = case cmd of-  RespUpdAtomicUI cmdA -> do-    cmds <- cmdAtomicFilterCli cmdA-    let handle c = do-          oldState <- getState-          oldStateClient <- getClient-          cmdAtomicSemCli c-          execUpdAtomic c-          displayRespUpdAtomicUI False oldState oldStateClient c-    mapM_ handle cmds-    mapM_ (storeUndo . UpdAtomic) cmds  -- TODO: only store cmdA?-  RespSfxAtomicUI sfx -> do-    displayRespSfxAtomicUI False sfx-    storeUndo $ SfxAtomic sfx-  RespQueryUI -> do-    cmdH <- queryUI-    sendRequest cmdH-  RespPingUI -> do-    pong <- pongUI-    sendRequest pong

+ Game/LambdaHack/Client/HandleResponseM.hs view

@@ -0,0 +1,50 @@+{-# LANGUAGE FlexibleContexts #-}+-- | Semantics of client commands.+module Game.LambdaHack.Client.HandleResponseM+  ( MonadClientReadResponse(..), MonadClientWriteRequest(..)+  , handleResponse+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Game.LambdaHack.Atomic+import Game.LambdaHack.Client.AI+import Game.LambdaHack.Client.HandleAtomicM+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.UI+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.Response++class MonadClient m => MonadClientReadResponse m where+  receiveResponse :: m Response++class MonadClient m => MonadClientWriteRequest m where+  sendRequestAI :: RequestAI -> m ()+  sendRequestUI :: RequestUI -> m ()+  clientHasUI   :: m Bool++handleResponse :: ( MonadClientSetup m+                  , MonadClientUI m+                  , MonadAtomic m+                  , MonadClientWriteRequest m )+               => Response -> m ()+handleResponse cmd = case cmd of+  RespUpdAtomic cmdA -> do+    hasUI <- clientHasUI+    cmds <- cmdAtomicFilterCli cmdA+    let handle !c = do+          cli <- getClient+          cmdAtomicSemCli c+          execUpdAtomic c+          when hasUI $ displayRespUpdAtomicUI False cli c+    mapM_ handle cmds+  RespQueryAI aid -> do+    cmdC <- queryAI aid+    sendRequestAI cmdC+  RespSfxAtomic sfx ->+    displayRespSfxAtomicUI False sfx+  RespQueryUI -> do+    cmdH <- queryUI+    sendRequestUI cmdH

− Game/LambdaHack/Client/ItemSlot.hs

@@ -1,107 +0,0 @@--- | Item slots for UI and AI item collections.--- TODO: document-module Game.LambdaHack.Client.ItemSlot-  ( ItemSlots, SlotChar(..)-  , allSlots, slotLabel, slotRange, assignSlot-  ) where--import Control.Exception.Assert.Sugar-import Data.Binary-import Data.Bits (shiftL, shiftR)-import Data.Char-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.List-import Data.Monoid-import Data.Ord (comparing)-import Data.Text (Text)-import qualified Data.Text as T-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.State--data SlotChar = SlotChar {slotPrefix :: Int, slotChar :: Char}-  deriving (Show, Eq)--instance Ord SlotChar where-  compare = comparing fromEnum--instance Binary SlotChar where-  put = put . fromEnum-  get = fmap toEnum get--instance Enum SlotChar where-  fromEnum (SlotChar n c) =-    ord c + (if isUpper c then 100 else 0) + shiftL n 8-  toEnum e =-    let n = shiftR e 8-        c0 = e - shiftL n 8-        c100 = c0 - if c0 > 150 then 100 else 0-    in SlotChar n (chr c100)--type ItemSlots = ( EM.EnumMap SlotChar ItemId-                 , EM.EnumMap SlotChar ItemId )--slotRange :: [SlotChar] -> Text-slotRange ls =-  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)-  sectionBy (x:xs) Nothing       = sectionBy xs (Just (x, x))-  sectionBy (x:xs) (Just (c, d))-    | succSlot d x               = sectionBy xs (Just (c, x))-    | otherwise                  = finish (c,d) <> sectionBy xs (Just (x, x))--  finish (c, d) | c == d         = T.pack [slotChar c]-                | succSlot c d   = T.pack [slotChar c, slotChar d]-                | succ2Slot c d  = T.pack [ slotChar c-                                          , chr (1 + ord (slotChar c))-                                          , slotChar d ]-                | otherwise      = T.pack [slotChar c, '-', slotChar d]--allSlots :: Int -> [SlotChar]-allSlots n = map (SlotChar n) $ ['a'..'z'] ++ ['A'..'Z']--allZeroSlots :: [SlotChar]-allZeroSlots = allSlots 0---- | Assigns a slot to an item, for inclusion in the inventory or equipment--- of a hero. Tries to to use the requested slot, if any.-assignSlot :: CStore -> Item -> FactionId -> Maybe Actor -> ItemSlots-           -> SlotChar -> State-           -> SlotChar-assignSlot store item fid mbody (itemSlots, organSlots) lastSlot s =-  assert (maybe True (\b -> bfid b == fid) mbody)-  $ if jsymbol item == '$'-    then SlotChar 0 '$'-    else head $ fresh ++ free- where-  offset = maybe 0 (+1) (elemIndex lastSlot allZeroSlots)-  onlyOrgans = store == COrgan-  len0 = length allZeroSlots-  candidatesZero = take len0 $ drop offset $ cycle allZeroSlots-  candidates = candidatesZero ++ concat [allSlots n | n <- [1..]]-  onPerson = sharedAllOwnedFid onlyOrgans fid s-  onGround = maybe EM.empty  -- consider floor only under the acting actor-                   (\b -> getCBag (CFloor (blid b) (bpos b)) s)-                   mbody-  inBags = ES.unions $ map EM.keysSet $ onPerson : [ onGround | not onlyOrgans]-  lSlots = if onlyOrgans  then organSlots else itemSlots-  f l = maybe True (`ES.notMember` inBags) $ EM.lookup l lSlots-  free = filter f candidates-  g l = l `EM.notMember` lSlots-  fresh = filter g $ take ((slotPrefix lastSlot + 1) * len0) candidates--slotLabel :: SlotChar -> MU.Part-slotLabel x = MU.String-              $ (if slotPrefix x == 0 then [] else show $ slotPrefix x)-                ++ [slotChar x]

− Game/LambdaHack/Client/Key.hs

@@ -1,295 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--- | Frontend-independent keyboard input operations.-module Game.LambdaHack.Client.Key-  ( Key(..), showKey, handleDir, dirAllKey-  , moveBinding, mkKM, keyTranslate-  , Modifier(..), KM(..), toKM, showKM-  , escKM, spaceKM, returnKM, pgupKM, pgdnKM, leftButtonKM, rightButtonKM-  ) where--import Control.DeepSeq-import Control.Exception.Assert.Sugar-import Data.Binary-import qualified Data.Char as Char-import Data.Text (Text)-import qualified Data.Text as T-import GHC.Generics (Generic)-import Prelude hiding (Left, Right)--import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Vector---- | Frontend-independent datatype to represent keys.-data Key =-    Esc-  | Return-  | Space-  | Tab-  | BackTab-  | BackSpace-  | PgUp-  | PgDn-  | Left-  | Right-  | Up-  | Down-  | End-  | Begin-  | Insert-  | Delete-  | Home-  | KP !Char      -- ^ a keypad key for a character (digits and operators)-  | Char !Char    -- ^ a single printable character-  | LeftButtonPress    -- ^ left mouse button pressed-  | MiddleButtonPress  -- ^ middle mouse button pressed-  | RightButtonPress   -- ^ right mouse button pressed-  | Unknown !Text -- ^ an unknown key, registered to warn the user-  deriving (Read, Ord, Eq, Generic)--instance Binary Key--instance NFData Key---- | Our own encoding of modifiers. Incomplete.-data Modifier =-    NoModifier-  | Shift-  | Control-  | Alt-  deriving (Read, Ord, Eq, Generic)--instance Binary Modifier--instance NFData Modifier--data KM = KM { key      :: !Key-             , modifier :: !Modifier-             , pointer  :: !(Maybe Point) }-  deriving (Read, Ord, Eq, Generic)--instance NFData KM--instance Show KM where-  show = T.unpack . showKM--instance Binary KM--toKM :: Modifier -> Key -> KM-toKM modifier key = KM{pointer=Nothing, ..}---- Common and terse names for keys.-showKey :: Key -> Text-showKey Esc      = "ESC"-showKey Return   = "RET"-showKey Space    = "SPACE"-showKey Tab      = "TAB"-showKey BackTab  = "SHIFT-TAB"-showKey BackSpace = "BACKSPACE"-showKey Up       = "UP"-showKey Down     = "DOWN"-showKey Left     = "LEFT"-showKey Right    = "RIGHT"-showKey Home     = "HOME"-showKey End      = "END"-showKey PgUp     = "PGUP"-showKey PgDn     = "PGDOWN"-showKey Begin    = "BEGIN"-showKey Insert   = "INSERT"-showKey Delete   = "DELETE"-showKey (KP c)   = "KEYPAD_" <> T.singleton c-showKey (Char c) = T.singleton c-showKey LeftButtonPress = "LEFT-BUTTON"-showKey MiddleButtonPress = "MIDDLE-BUTTON"-showKey RightButtonPress = "RIGHT-BUTTON"-showKey (Unknown s) = s---- | Show a key with a modifier, if any.-showKM :: KM -> Text-showKM KM{modifier=Shift, key} = "SHIFT-" <> showKey key-showKM KM{modifier=Control, key} = "CTRL-" <> showKey key-showKM KM{modifier=Alt, key} = "ALT-" <> showKey key-showKM KM{modifier=NoModifier, key} = showKey key--escKM :: KM-escKM = toKM NoModifier Esc--spaceKM :: KM-spaceKM = toKM NoModifier Space--returnKM :: KM-returnKM = toKM NoModifier Return--pgupKM :: KM-pgupKM = toKM NoModifier PgUp--pgdnKM :: KM-pgdnKM = toKM NoModifier PgDn--leftButtonKM :: KM-leftButtonKM = toKM NoModifier LeftButtonPress--rightButtonKM :: KM-rightButtonKM = toKM NoModifier RightButtonPress--dirKeypadKey :: [Key]-dirKeypadKey = [Home, Up, PgUp, Right, PgDn, Down, End, Left]--dirKeypadShiftChar :: [Char]-dirKeypadShiftChar = ['7', '8', '9', '6', '3', '2', '1', '4']--dirKeypadShiftKey :: [Key]-dirKeypadShiftKey = map KP dirKeypadShiftChar--dirLaptopKey :: [Key]-dirLaptopKey = map Char ['7', '8', '9', 'o', 'l', 'k', 'j', 'u']--dirLaptopShiftKey :: [Key]-dirLaptopShiftKey = map Char ['&', '*', '(', 'O', 'L', 'K', 'J', 'U']--dirViChar :: [Char]-dirViChar = ['y', 'k', 'u', 'l', 'n', 'j', 'b', 'h']--dirViKey :: [Key]-dirViKey = map Char dirViChar--dirViShiftKey :: [Key]-dirViShiftKey = map (Char . Char.toUpper) dirViChar--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--dirRunShift :: [Key]-dirRunShift = dirRunControl--dirAllKey :: Bool -> Bool -> [Key]-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) $ cycle moves-  in maybe k h (lookup key assocs)-handleDir _ _ _ _ k = k---- | Binding of both sets of movement keys.-moveBinding :: Bool -> Bool -> (Vector -> a) -> (Vector -> a)-            -> [(KM, a)]-moveBinding configVi configLaptop move run =-  let assign f (km, dir) = (km, f dir)-      mapMove modifier keys =-        map (assign move) (zip (map (toKM modifier) keys) $ cycle moves)-      mapRun modifier keys =-        map (assign run) (zip (map (toKM modifier) keys) $ cycle moves)-  in mapMove NoModifier (dirMoveNoModifier configVi configLaptop)-     ++ mapRun NoModifier (dirRunNoModifier configVi configLaptop)-     ++ mapRun Control dirRunControl-     ++ mapRun Shift dirRunShift--mkKM :: String -> KM-mkKM s = let mkKey sk =-               case keyTranslate sk of-                 Unknown _ -> assert `failure` "unknown key" `twith` s-                 key -> key-         in case s of-           ('S':'H':'I':'F':'T':'-':rest) -> toKM Shift (mkKey rest)-           ('C':'T':'R':'L':'-':rest) -> toKM Control (mkKey rest)-           ('A':'L':'T':'-':rest) -> toKM Alt (mkKey rest)-           _ -> toKM NoModifier (mkKey s)---- | Translate key from a GTK string description to our internal key type.--- To be used, in particular, for the command bindings and macros--- in the config file.-keyTranslate :: String -> Key-keyTranslate "less"          = Char '<'-keyTranslate "greater"       = Char '>'-keyTranslate "period"        = Char '.'-keyTranslate "colon"         = Char ':'-keyTranslate "semicolon"     = Char ';'-keyTranslate "comma"         = Char ','-keyTranslate "question"      = Char '?'-keyTranslate "dollar"        = Char '$'-keyTranslate "parenleft"     = Char '('-keyTranslate "parenright"    = Char ')'-keyTranslate "asterisk"      = Char '*'-keyTranslate "KP_Multiply"   = KP '*'-keyTranslate "slash"         = Char '/'-keyTranslate "KP_Divide"     = KP '/'-keyTranslate "bar"           = Char '|'-keyTranslate "backslash"     = Char '\\'-keyTranslate "underscore"    = Char '_'-keyTranslate "minus"         = Char '-'-keyTranslate "KP_Subtract"   = Char '-'-keyTranslate "plus"          = Char '+'-keyTranslate "KP_Add"        = Char '+'-keyTranslate "equal"         = Char '='-keyTranslate "bracketleft"   = Char '['-keyTranslate "bracketright"  = Char ']'-keyTranslate "braceleft"     = Char '{'-keyTranslate "braceright"    = Char '}'-keyTranslate "ampersand"     = Char '&'-keyTranslate "at"            = Char '@'-keyTranslate "asciitilde"    = Char '~'-keyTranslate "exclam"        = Char '!'-keyTranslate "apostrophe"    = Char '\''-keyTranslate "Escape"        = Esc-keyTranslate "Return"        = Return-keyTranslate "space"         = Space-keyTranslate "Tab"           = Tab-keyTranslate "ISO_Left_Tab"  = BackTab-keyTranslate "BackSpace"     = BackSpace-keyTranslate "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 "LeftButtonPress" = LeftButtonPress-keyTranslate "MiddleButtonPress" = MiddleButtonPress-keyTranslate "RightButtonPress" = RightButtonPress-keyTranslate ['K','P','_',c] = KP c-keyTranslate [c]             = Char c-keyTranslate s               = Unknown $ T.pack s

− Game/LambdaHack/Client/LoopClient.hs

@@ -1,124 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--- | The main loop of the client, processing human and computer player--- moves turn by turn.-module Game.LambdaHack.Client.LoopClient (loopAI, loopUI) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.Text as T--import Game.LambdaHack.Atomic-import Game.LambdaHack.Client.HandleResponseClient-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.ProtocolClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI-import Game.LambdaHack.Common.ClientOptions-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.Response-import Game.LambdaHack.Common.State-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.RuleKind--initCli :: MonadClient m => DebugModeCli -> (State -> m ()) -> m Bool-initCli sdebugCli putSt = do-  -- Warning: state and client state are invalid here, e.g., sdungeon-  -- and sper are empty.-  cops <- getsState scops-  modifyClient $ \cli -> cli {sdebugCli}-  restored <- restoreGame-  case restored of-    Just (s, cli) | not $ snewGameCli sdebugCli -> do  -- Restore the game.-      let sCops = updateCOps (const cops) s-      putSt sCops-      putClient cli {sdebugCli}-      return True-    _ -> do  -- First visit ever, use the initial state.-      -- But preserve the previous history, if any (--newGame).-      case restored of-        Just (_, cliR) -> modifyClient $ \cli -> cli {shistory = shistory cliR}-        Nothing -> return ()-      return False---- | The main game loop for an AI client.-loopAI :: ( MonadAtomic m-          , MonadClientReadResponse ResponseAI m-          , MonadClientWriteRequest RequestAI m )-       => DebugModeCli -> m ()-loopAI sdebugCli = do-  side <- getsClient sside-  restored <- initCli sdebugCli-              $ \s -> handleResponseAI $ RespUpdAtomicAI $ UpdResumeServer s-  cmd1 <- receiveResponse-  case (restored, cmd1) of-    (True, RespUpdAtomicAI UpdResume{}) -> return ()-    (True, RespUpdAtomicAI UpdRestart{}) -> return ()-    (False, RespUpdAtomicAI UpdResume{}) -> do-      removeServerSave-      error $ T.unpack $-        "Savefile of client" <+> tshow side-        <+> "not usable. Removing server savefile. Please restart now."-    (False, RespUpdAtomicAI UpdRestart{}) -> return ()-    _ -> assert `failure` "unexpected command" `twith` (side, restored, cmd1)-  handleResponseAI cmd1-  -- State and client state now valid.-  debugPrint $ "AI client" <+> tshow side <+> "started."-  loop-  debugPrint $ "AI client" <+> tshow side <+> "stopped."- where-  loop = do-    cmd <- receiveResponse-    handleResponseAI cmd-    quit <- getsClient squit-    unless quit loop---- | The main game loop for a UI client.-loopUI :: ( MonadClientUI m-          , MonadAtomic m-          , MonadClientReadResponse ResponseUI m-          , MonadClientWriteRequest RequestUI m )-       => DebugModeCli -> m ()-loopUI sdebugCli = do-  Kind.COps{corule} <- getsState scops-  let title = rtitle $ Kind.stdRuleset corule-  side <- getsClient sside-  restored <- initCli sdebugCli-              $ \s -> handleResponseUI $ RespUpdAtomicUI $ UpdResumeServer s-  cmd1 <- receiveResponse-  case (restored, cmd1) of-    (True, RespUpdAtomicUI UpdResume{}) -> do-      mode <- getGameMode-      msgAdd $ mdesc mode-      handleResponseUI cmd1-    (True, RespUpdAtomicUI UpdRestart{}) -> do-      msgAdd $-        "Ignoring an old savefile and starting a new" <+> title <+> "game."-      handleResponseUI cmd1-    (False, RespUpdAtomicUI UpdResume{}) -> do-      removeServerSave-      error $ T.unpack $-        "Savefile of client" <+> tshow side-        <+> "not usable. Removing server savefile. Please restart now."-    (False, RespUpdAtomicUI UpdRestart{}) -> do-      msgAdd $ "Welcome to" <+> title <> "!"-      handleResponseUI cmd1-    _ -> assert `failure` "unexpected command" `twith` (side, restored, cmd1)-  fact <- getsState $ (EM.! side) . sfactionD-  when (isAIFact fact) $-    -- Prod the frontend to flush frames and start showing then continuously.-    void $ displayMore ColorFull "The team is under AI control (ESC to stop)."-  -- State and client state now valid.-  debugPrint $ "UI client" <+> tshow side <+> "started."-  loop-  debugPrint $ "UI client" <+> tshow side <+> "stopped."- where-  loop = do-    cmd <- receiveResponse-    handleResponseUI cmd-    quit <- getsClient squit-    unless quit loop

+ Game/LambdaHack/Client/LoopM.hs view

@@ -0,0 +1,98 @@+{-# LANGUAGE FlexibleContexts #-}+-- | The main loop of the client, processing human and computer player+-- moves turn by turn.+module Game.LambdaHack.Client.LoopM+  ( loopCli+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.Text as T++import Game.LambdaHack.Atomic+import Game.LambdaHack.Client.HandleResponseM+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Client.UI+import Game.LambdaHack.Common.ClientOptions+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Response+import Game.LambdaHack.Common.State+import Game.LambdaHack.Common.Vector++initAI :: MonadClient m => DebugModeCli -> m ()+initAI sdebugCli = do+  modifyClient $ \cli -> cli {sdebugCli}+  side <- getsClient sside+  debugPossiblyPrint $ "AI client" <+> tshow side <+> "initializing."++initUI :: MonadClientUI m => KeyKind -> Config -> DebugModeCli -> m ()+initUI copsClient sconfig sdebugCli = do+  modifyClient $ \cli -> cli {sdebugCli}+  side <- getsClient sside+  debugPossiblyPrint $ "UI client" <+> tshow side <+> "initializing."+  -- Start the frontend.+  schanF <- chanFrontend sdebugCli+  let !sbinding = stdBinding copsClient sconfig  -- evaluate to check for errors+      sess = emptySessionUI sconfig+  putSession sess { schanF+                  , sbinding+                  , sxhair = TVector $ Vector 1 1 }+                      -- a step south-east, less alarming++-- | The main game loop for an AI or UI client.+loopCli :: ( MonadClientSetup m+           , MonadClientUI m+           , MonadAtomic m+           , MonadClientReadResponse m+           , MonadClientWriteRequest m )+        => KeyKind -> Config -> DebugModeCli -> m ()+loopCli copsClient sconfig sdebugCli = do+  hasUI <- clientHasUI+  if not hasUI then initAI sdebugCli else initUI copsClient sconfig sdebugCli+  -- Warning: state and client state are invalid here, e.g., sdungeon+  -- and sper are empty.+  cops <- getsState scops+  restoredG <- tryRestore+  restored <- case restoredG of+    Just (s, cli, msess) | not $ snewGameCli sdebugCli -> do+      -- Restore game.+      let sCops = updateCOps (const cops) s+      handleResponse $ RespUpdAtomic $ UpdResumeServer sCops+      schanF <- getsSession schanF+      sbinding <- getsSession sbinding+      maybe (return ()) (\sess ->+        putSession sess {schanF, sbinding, sconfig}) msess+      putClient cli {sdebugCli}+      return True+    Just (_, _, msessR) -> do+      -- Preserve previous history, if any (--newGame).+      maybe (return ()) (\sessR -> modifySession $ \sess ->+        sess {shistory = shistory sessR}) msessR+      return False+    _ -> return False+  side <- getsClient sside+  cmd1 <- receiveResponse+  case (restored, cmd1) of+    (True, RespUpdAtomic UpdResume{}) -> return ()+    (True, RespUpdAtomic UpdRestart{}) ->+      when hasUI $ msgAdd "Ignoring an old savefile and starting a new game."+    (False, RespUpdAtomic UpdResume{}) ->+      assert `failure`+        T.unpack ("Savefile of client" <+> tshow side <+> "not usable.")+    (False, RespUpdAtomic UpdRestart{}) -> return ()+    _ -> assert `failure` "unexpected command" `twith` (side, restored, cmd1)+  handleResponse cmd1+  -- State and client state now valid.+  debugPossiblyPrint $ "UI client" <+> tshow side <+> "started."+  loop+  debugPossiblyPrint $ "UI client" <+> tshow side <+> "stopped."+ where+  loop = do+    cmd <- receiveResponse+    handleResponse cmd+    quit <- getsClient squit+    unless quit loop

Game/LambdaHack/Client/MonadClient.hs view

@@ -1,98 +1,65 @@ -- | Basic client monad and related operations. module Game.LambdaHack.Client.MonadClient   ( -- * Basic client monad-    MonadClient( getClient, getsClient, modifyClient, putClient-               , saveChanClient  -- exposed only to be implemented, not used+    MonadClient( getsClient, modifyClient                , liftIO  -- exposed only to be implemented, not used                )+  , MonadClientSetup( saveClient+                    , restartClient+                    )     -- * Assorted primitives-  , debugPrint, saveClient, saveName, restoreGame, removeServerSave, rndToAction+  , getClient, putClient+  , debugPossiblyPrint, rndToAction, rndToActionForget   ) where -import Control.Monad-import qualified Control.Monad.State as St-import Data.Maybe-import Data.Text (Text)-import System.Directory-import System.FilePath+import Prelude () +import Game.LambdaHack.Common.Prelude++import qualified Control.Monad.Trans.State.Strict as St+import qualified Data.Text.IO as T+import System.IO (hFlush, stdout)+import qualified System.Random as R+ import Game.LambdaHack.Client.State import Game.LambdaHack.Common.ClientOptions-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.File-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Random-import qualified Game.LambdaHack.Common.Save as Save-import Game.LambdaHack.Common.State-import Game.LambdaHack.Content.RuleKind  class MonadStateRead m => MonadClient m where-  getClient      :: m StateClient-  getsClient     :: (StateClient -> a) -> m a-  modifyClient   :: (StateClient -> StateClient) -> m ()-  putClient      :: StateClient -> m ()-  -- We do not provide a MonadIO instance, so that outside of Action/+  getsClient    :: (StateClient -> a) -> m a+  modifyClient  :: (StateClient -> StateClient) -> m ()+  -- We do not provide a MonadIO instance, so that outside   -- nobody can subvert the action monads by invoking arbitrary IO.-  liftIO         :: IO a -> m a-  saveChanClient :: m (Save.ChanSave (State, StateClient))--debugPrint :: MonadClient m => Text -> m ()-debugPrint t = do-  sdbgMsgCli <- getsClient $ sdbgMsgCli . sdebugCli-  when sdbgMsgCli $ liftIO $ Save.delayPrint t+  liftIO        :: IO a -> m a -saveClient :: MonadClient m => m ()-saveClient = do-  s <- getState-  cli <- getClient-  toSave <- saveChanClient-  liftIO $ Save.saveToChan toSave (s, cli)+class MonadClient m => MonadClientSetup m where+  saveClient    :: m ()+  restartClient :: m () -saveName :: FactionId -> Bool -> String-saveName side isAI =-  let n = fromEnum side  -- we depend on the numbering hack to number saves-  in (if n > 0-      then "human_" ++ show n-      else "computer_" ++ show (-n))-     ++ if isAI then ".ai.sav" else ".ui.sav"+getClient :: MonadClient m => m StateClient+getClient = getsClient id -restoreGame :: MonadClient m => m (Maybe (State, StateClient))-restoreGame = do-  bench <- getsClient $ sbenchmark . sdebugCli-  if bench then return Nothing-  else do-    Kind.COps{corule} <- getsState scops-    let stdRuleset = Kind.stdRuleset corule-        pathsDataFile = rpathsDataFile stdRuleset-        cfgUIName = rcfgUIName stdRuleset-    side <- getsClient sside-    isAI <- getsClient sisAI-    prefix <- getsClient $ ssavePrefixCli . sdebugCli-    let copies = [( "GameDefinition" </> cfgUIName <.> "default"-                  , cfgUIName <.> "ini" )]-        name = fromMaybe "save" prefix <.> saveName side isAI-    liftIO $ Save.restoreGame name copies pathsDataFile+putClient :: MonadClient m => StateClient -> m ()+putClient s = modifyClient (const s) --- | Assuming the client runs on the same machine and for the same--- user as the server, move the server savegame out of the way.-removeServerSave :: MonadClient m => m ()-removeServerSave = do-  -- Hack: assume the same prefix for client as for the server.-  prefix <- getsClient $ ssavePrefixCli . sdebugCli-  dataDir <- liftIO appDataDir-  let serverSaveFile = dataDir-                       </> "saves"-                       </> fromMaybe "save" prefix-                       <.> serverSaveName-  bSer <- liftIO $ doesFileExist serverSaveFile-  when bSer $ liftIO $ renameFile serverSaveFile (serverSaveFile <.> "bkp")+debugPossiblyPrint :: MonadClient m => Text -> m ()+debugPossiblyPrint t = do+  sdbgMsgCli <- getsClient $ sdbgMsgCli . sdebugCli+  when sdbgMsgCli $ liftIO $  do+    T.hPutStrLn stdout t+    hFlush stdout  -- | Invoke pseudo-random computation with the generator kept in the state. rndToAction :: MonadClient m => Rnd a -> m a rndToAction r = do-  g <- getsClient srandom-  let (a, ng) = St.runState r g-  modifyClient $ \cli -> cli {srandom = ng}-  return a+  gen <- getsClient srandom+  let (gen1, gen2) = R.split gen+  modifyClient $ \ser -> ser {srandom = gen1}+  return $! St.evalState r gen2++-- | Invoke pseudo-random computation, don't change generator kept in state.+rndToActionForget :: MonadClient m => Rnd a -> m a+rndToActionForget r = do+  gen <- getsClient srandom+  return $! St.evalState r gen

+ Game/LambdaHack/Client/Preferences.hs view

@@ -0,0 +1,406 @@+-- | Actor preferences for targets and actions based on actor attributes.+module Game.LambdaHack.Client.Preferences+  ( totalUsefulness+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , effectToBenefit, organBenefit, aspectToBenefit, recordToBenefit+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Game.LambdaHack.Common.Dice as Dice+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Flavour+import Game.LambdaHack.Common.Frequency+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.ItemStrongest+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Content.ItemKind as IK+import Game.LambdaHack.Content.ModeKind++-- | How much AI benefits from applying the effect.+-- The first component is benefit when applied to self, the second+-- is benefit (preferably negative) when applied to enemy.+-- This represents benefit from using the effect every @avgItemDelay@ turns,+-- so if the item is not durable, the value is adjusted down elsewhere.+-- The benefit includes the drawback of having to use the actor's turn,+-- except when there is battle and item is a weapon and so there is usually+-- nothing better to do than to melee, or when the actor is stuck or idle+-- or laying in wait or luring an enemy from a safe distance.+-- So there is less than @averageTurnValue@ included in each benefit,+-- so in case when turn is not spent, e.g, periodic or temporary effects,+-- the difference in value is only slight.+effectToBenefit :: Kind.COps -> Faction -> IK.Effect -> (Int, Int)+effectToBenefit cops fact eff =+  let delta x = (x, x)+  in case eff of+    IK.ELabel _ -> delta 0+    IK.EqpSlot _ -> delta 0+    IK.Burn d -> delta $ -(min 1500 $ 15 * Dice.meanDice d)+      -- often splash damage, armor doesn't block (but HurtMelee doesn't boost)+    IK.Explode _ -> delta 1  -- depends on explosion, but usually good,+                             -- unless under OnSmash, but they are ignored+    IK.RefillHP p ->+      delta $ if p > 0 then min 2000 (20 * p) else max (-1000) (10 * p)+        -- one HP healed is worth a bit more than one HP dealed to enemy,+        -- because if the actor survives, he may deal damage many times;+        -- however, AI is mostly for non-heroes that fight in suicidal crowds,+        -- so the two values are kept close enough to maintain berserk approach+    IK.RefillCalm p -> delta $ if p > 0 then min 9 p else max (-9) p+    IK.Dominate -> (0, -300)  -- I obtained an actor with, say 10HP,+                              -- worth 200, and enemy lost him, another 100+    IK.Impress -> (5, -50)  -- usually has no effect on self, hence low value+    IK.Summon grp d ->  -- contrived by not taking into account alliances+                        -- and not checking if enemies also control that group+      let ben = Dice.meanDice d * 200  -- the new actor can have, say, 10HP+      in if grp `elem` fgroups (gplayer fact) then (ben, -ben) else (-ben, ben)+    IK.Ascend{} -> (-99, 99)  -- note the reversed values:+                              -- only change levels sensibly, in teams,+                              -- and don't remove enemy too far, he may be+                              -- easy to kill and may have loot+    IK.Escape{} -> (-9999, 9999)  -- even if can escape, loots first and then+                                  -- handles escape as a special case+    -- The following two are expensive, because they ofen activate+    -- while in melee, in which case each turn is worth x HP, where x+    -- is the average effective weapon damage in the game, which would+    -- be ~5. (Plus a huge risk factor for any non-spawner faction.)+    -- So, each turn in battle is worth ~100. And on average, in and out+    -- of battle, let's say each turn is worth ~10.+    IK.Paralyze d -> delta $ -20 * Dice.meanDice d  -- clips+    IK.InsertMove d -> delta $ 100 * Dice.meanDice d  -- turns+    IK.Teleport d -> if Dice.meanDice d <= 8+                     then (1, 0)   -- blink to shoot at foes+                     else (-9, -1)  -- for self, don't derail exploration+                                    -- for foes, fight with one less at a time+    IK.CreateItem COrgan "temporary condition" _ ->+      (1, -1)  -- varied, big bunch, but try to create it anyway+    IK.CreateItem COrgan grp timer ->  -- assumed temporary+      let turnTimer = case timer of+            IK.TimerNone -> averageTurnValue + 1  -- copy count used instead+            IK.TimerGameTurn n -> Dice.meanDice n+            IK.TimerActorTurn n -> Dice.meanDice n+          (total, count) = organBenefit turnTimer grp cops fact+      in delta $ total `divUp` count  -- the same when created in me and in foe+        -- average over all matching grps; simplified: rarities ignored+    IK.CreateItem _ "treasure" _ -> (100, 0)  -- assumed not temporary+    IK.CreateItem _ "useful" _ -> (70, 0)+    IK.CreateItem _ "any scroll" _ -> (50, 0)+    IK.CreateItem _ "any vial" _ -> (50, 0)+    IK.CreateItem _ "potion" _ -> (50, 0)+    IK.CreateItem _ "flask" _ -> (50, 0)+    IK.CreateItem _ grp _ ->  -- assumed not temporary and @grp@ tiny+      let (total, count) = recBenefit grp cops fact+      in (total `divUp` count, 0)+    IK.DropItem _ _ COrgan "temporary condition" ->+      (1, -1)  -- varied, big bunch, but try to nullify it anyway+    IK.DropItem ngroup kcopy COrgan grp ->  -- assumed temporary+      -- Simplified: we assume actor has an average number of copies+      -- (and none have yet run out, e.g., prompt curing of poisoning)+      -- of a single kind of organ (and so @ngroup@ doesn't matter)+      -- of average benefit and that @kcopy@ is such that all copies+      -- are dropped. Separately we add bonuses for @ngroup@ and @kcopy@.+      -- Remaining time of the organ is arbitrarily assumed to be 20 turns.+      let turnTimer = 20+          (total, count) = organBenefit turnTimer grp cops fact+          boundBonus n = if n == maxBound then 10 else 0+      in delta $ boundBonus ngroup + boundBonus kcopy+                 - total `divUp` count  -- the same when dropped from me and foe+    IK.DropItem{} -> delta (-10)  -- depends a lot on what is dropped+    IK.PolyItem -> delta 0  -- AI can't estimate item desirability vs average+    IK.Identify -> delta 0  -- AI doesn't know how to use+    IK.Detect radius -> (radius * 2, 0)+    IK.DetectActor radius -> (radius, 0)+    IK.DetectItem radius -> (radius, 0)+    IK.DetectExit radius -> (radius, 0)+    IK.DetectHidden radius -> (radius, 0)+    IK.SendFlying _ -> (1, -10)  -- very context dependent, but it's better+    IK.PushActor _ -> (1, -10)   -- to be the one that decides and not the one+    IK.PullActor _ -> (1, -10)   -- that is interrupted in the middle of fleeing+    IK.DropBestWeapon -> delta $ -50  -- often a whole turn wasted == InsertMove+    IK.ActivateInv ' ' -> delta $ -200  -- brutal and deadly+    IK.ActivateInv _ -> delta $ -50  -- depends on the items+    IK.ApplyPerfume -> delta 0  -- depends on smell sense of friends and foes+    IK.OneOf efs ->+      let bs = map (effectToBenefit cops fact) efs+          f (self, foe) (accSelf, accFoe) = (self + accSelf, foe + accFoe)+          (effSelf, effFoe) = foldr f (0, 0) bs+      in (effSelf `divUp` length bs, effFoe `divUp` length bs)+    IK.OnSmash _ -> delta 0+      -- can be beneficial; we'd need to analyze explosions, range, etc.+    IK.Recharging _ -> delta 0  -- taken into account separately+    IK.Temporary _ -> delta 0  -- assumed for created organs only+    IK.Unique -> delta 0+    IK.Periodic -> delta 0  -- considered in totalUsefulness++-- See the comment for @Paralyze@.+averageTurnValue :: Int+averageTurnValue = 10++-- Average delay between desired item uses. Some items are best activated+-- every turn, e.g., healing (but still, on average, the activation would be+-- useless some of the time, namely when HP is at max, which is rare,+-- or when some combat boost is already lasting, which is probably also rare).+-- However, e.g., for detection, activating every few turns is enough.+-- Also, sometimes actor has many activable items, so he doesn't want to use+-- the less powerful ones as often as when they are alone.+-- For weapons, it depends. Sometimes a weapon with disorienting effect+-- should be used once every couple of turns and stronger raw damage+-- weapons all the remaining time. In other cases a single weapon+-- with a devastating effect would ideally be available each turn.+-- We don't want to undervalue rarely used items with long timeouts+-- and we think that most interesting gameplay comes from alternating+-- item use, so we arbitrarily set the full value timeout to 3.+avgItemDelay :: Int+avgItemDelay = 3++-- The average time between item being found (and enough skill obtained+-- to use it) and item not being used any more. We specifically ignore+-- item not being used any more, because it is not durable and is consumed.+-- However we do consider actor mortality (especially common for spawners)+-- and item contending with many other very different but valuable items+-- that all vie for the same turn needed to activate them (especially common+-- for non-spawners). Another reason is item getting obsolete or duplicated,+-- by finding a strictly better item or an identical item.+-- The @avgItemLife@ constant only makes sense for items with non-periodic+-- effects, because the effects' benefit is not cumulative+-- by just placing them in equipment and they cost a turn to activate.+-- We set the value to 30, assuming if the actor finds an item, then he is+-- most likely at an unlooted level, so he will find more loot soon,+-- or he is in a battle, so he will die soon (or win even more loot).+avgItemLife :: Int+avgItemLife = 30++-- The value of durable item is this many times higher than non-durable,+-- because the item will on average be activated this many times+-- before it stops being used.+durabilityMult :: Int+durabilityMult = avgItemLife `div` avgItemDelay++-- We assume the organ is temporary (@Temporary@, @Periodic@, @Timeout 0@)+-- and also that it doesn't provide any functionality, e.g., detection+-- or burning or raw damage. However, we take into account recharging+-- effects, knowing in some temporary organs, e.g., poison or regeneration,+-- they are triggered at each item copy destruction. They are applied to self,+-- hence we take the self component of valuation. We multiply by the count+-- of created/dropped organs, because for temporary effects it determines+-- how many times the effect is applied, before the last copy expires.+--+-- The organs are not durable nor in infnite copies, so to give+-- continous benefit, organ has to be recreated each @turnTimer@ turns.+-- Creation takes a turn, so incurs @averageTurnValue@ cost.+-- That's how the lack of durability impacts their value, not via+-- @durabilityMult@, which however may be applied to organ creating item.+-- So, on average, maintaining the organ costs @averageTurnValue/turnTimer@.+-- So, if an item lasts @averageTurnValue@ and it can be created at will,+-- it's as valuable as permanent. This makes sense even if the item creating+-- the organ is not durable, but the timer is huge. One may think the lack+-- of durability should be offset by the timer, but remember that average+-- item life @avgItemLife@ is rather low, so either a new item will be found+-- soon and so the long timer doesn't matter or the actor will die+-- or the gameplay context will change (e.g., out of battle) and so the effect+-- will no longer be useful.+--+-- When considering the effects, we just use their standard valuation,+-- despite them not using up actor's turn to be applied each turn,+-- because, similarly as for periodic items, we don't control when they+-- are applied and we can't stop/restart them.+--+-- We assume, only one of timer and count mechanisms is present at once.+organBenefit :: Int -> GroupName ItemKind -> Kind.COps -> Faction -> (Int, Int)+organBenefit turnTimer grp cops@Kind.COps{coitem=Kind.Ops{ofoldlGroup'}} fact =+  let f (!sacc, !pacc) !p _ !kind =+        let paspect asp = p * aspectToBenefit asp+            peffect eff = p * fst (effectToBenefit cops fact eff)+        in ( sacc + Dice.meanDice (IK.icount kind)+                    * (sum (map paspect $ IK.iaspects kind)+                       + sum (map peffect $ stripRecharging $ IK.ieffects kind))+                  - averageTurnValue `div` turnTimer+           , pacc + p )+  in ofoldlGroup' grp f (0, 0)++recBenefit :: GroupName ItemKind -> Kind.COps -> Faction -> (Int, Int)+recBenefit grp cops@Kind.COps{coitem=Kind.Ops{ofoldlGroup'}} fact =+  let f (!sacc, !pacc) !p _ !kind =+        let recPickup = benPickup $+              totalUsefulness cops fact (IK.ieffects kind)+                                        (meanAspect kind) (fakeItem kind)+        in ( sacc + Dice.meanDice (IK.icount kind) * recPickup+           , pacc + p )+  in ofoldlGroup' grp f (0, 0)++fakeItem :: IK.ItemKind -> Item+fakeItem kind =+  let jkindIx  = toEnum (-1)  -- dummy+      jlid     = toEnum 0  -- dummy+      jfid     = Nothing  -- the default+      jsymbol  = IK.isymbol kind+      jname    = IK.iname kind+      jflavour = head stdFlav  -- dummy+      jfeature = IK.ifeature kind+      jweight  = IK.iweight kind+      jdamage  = fromJust $ mostFreq $ toFreq "fakeItem" $ IK.idamage kind+  in Item{..}++-- Value of aspects and effects is linked by some deep economic principles+-- which I'm unfortunately ignorant of. E.g., average weapon hits for 5HP,+-- so it's worth 50 per turn, so that should also be the worth per turn+-- of equpping a sword oil that doubles damage via @AddHurtMelee@.+-- Which almost matches up, since 100% effective oil is worth 100.+-- Perhaps oil is worth double (despite cap, etc.), because it's addictive+-- and raw weapon damage is not; so oil stays and old weapons get trashed.+-- However, using the weapon in combat costs 100 (the value of extra+-- battle turn). However, one turn per turn is almost free, because something+-- has to be done to move the time forward. If the oil required wasting a turn+-- to affect next strike, then we'd have two turns per turn, so the cost+-- would be real and 100% oil would not have any significant good or bad effect+-- any more, but 200% oil (if not for the cap) would still be worth it.+--+-- Anyway, that suggests that the current scaling of effect vs aspect values+-- is reasonable. What is even more important is consistency among aspects+-- so that, e.g., a shield or a torch is neven equipped, but oil lamp is.+-- Valuation of effects, and more precisely, more the signs than absolute+-- values, ensures that both shield and torch get picked up so that+-- the (human) actor can nevertheless equip them in very special cases.+aspectToBenefit :: IK.Aspect -> Int+aspectToBenefit asp =+  case asp of+    IK.Timeout{} -> 0+    IK.AddHurtMelee p -> Dice.meanDice p  -- offence favoured+    IK.AddArmorMelee p -> Dice.meanDice p `divUp` 4  -- only partial protection+    IK.AddArmorRanged p -> Dice.meanDice p `divUp` 8+    IK.AddMaxHP p -> Dice.meanDice p+    IK.AddMaxCalm p -> Dice.meanDice p `divUp` 5+    IK.AddSpeed p -> Dice.meanDice p * 25+      -- 1 speed ~ 5% melee; times 5 for no caps, escape, pillar-dancing, etc.;+      -- also, it's 1 extra turn each 20 turns, so 100/20, so 5; figures+    IK.AddSight p -> Dice.meanDice p * 5+    IK.AddSmell p -> Dice.meanDice p+    IK.AddShine p -> Dice.meanDice p * 2+    IK.AddNocto p -> Dice.meanDice p * 10  -- > sight + light; stealth, slots+    IK.AddAggression{} -> 0+    IK.AddAbility _ p -> Dice.meanDice p * 5++recordToBenefit :: AspectRecord -> [Int]+recordToBenefit aspects = map aspectToBenefit $ aspectRecordToList aspects++-- Result has non-strict fields, so arguments are forced to avoid leaks.+-- When AI looks at items (including organs) more often, force the fields.+totalUsefulness :: Kind.COps -> Faction -> [IK.Effect] -> AspectRecord -> Item+                -> Benefit+totalUsefulness !cops !fact !effects !aspects !item =+  let effPairs = map (effectToBenefit cops fact) effects+      effDice = - damageUsefulness item+      f (self, foe) (accSelf, accFoe) = (self + accSelf, foe + accFoe)+      (effSelf, effFoe) = foldr f (0, 0) effPairs+      -- Timeout between 0 and 1 means item usable each turn, so we consider+      -- it equivalent to a permanent item --- without timeout restriction.+      -- Timeout 2 means two such items are needed to use the effect each turn,+      -- so a single such item may be worth half of the permanet value.+      -- Hence, we multiply item value by the proportion of the average desired+      -- delay between item uses @avgItemDelay@ and the actual timeout.+      timeout = aTimeout aspects+      (chargeSelf, chargeFoe) =+        let scaleChargeBens bens+              | timeout <= 3 = bens+              | otherwise = map (\eff ->+                  min eff (eff * avgItemDelay `divUp` timeout)) bens+            (cself, cfoe) = unzip $ map (effectToBenefit cops fact)+                                        (stripRecharging effects)+        in (scaleChargeBens cself, scaleChargeBens cfoe)+      -- If the item is periodic, we add charging effects to equipment benefit,+      -- but we don't assign periodic bonus or malus, because periodic items+      -- are bad in that one can't activate them at will and they take+      -- equipment space, and good in that one saves a turn, not having+      -- to manually activate them. Additionally, no weapon can be periodic,+      -- because damage would be applied to the fighter, so a large class+      -- of items with timeout is excluded from the consideration.+      -- Generally, periodic seems more helpful on items with low timeout+      -- and obviously beneficial effects, e.g., frequent periodic healing+      -- or nearby detection is better, but infrequent periodic teleportation+      -- or harmful explosion is worse. But the rule is not strict and also+      -- dependent on gameplay context of the moment, hence no numerical value.+      periodic = IK.Periodic `elem` effects+      -- Durability doesn't have any numerical impact to @eqpSum,+      -- because item is never consumed by just being stored in equipment.+      -- Also no numerical impact for flinging, because we can't fling it again+      -- in the same skirmish and also enemy can pick up and fling back.+      -- Only @benMelee@ and @benApply@ are affected, regardless if the item+      -- is in equipment or not. As summands of @benPickup@ they should be+      -- impacted by durability, because picking an item to be used+      -- only once is less advantageous than when the item is durable.+      -- For deciding which item to apply or melee with, they should be+      -- impacted, because it makes more sense to use an item that is durable+      -- and save the option for using non-durable item for the future, e.g.,+      -- when both items have timeouts, starting with durable is beneficial,+      -- because it recharges while the non-durable is prepared and used.+      durable = IK.Durable `elem` jfeature item+      -- If recharging effects not periodic, we add the self part,+      -- because they are applied to self. If they are periodic we can't+      -- effectively apply them, becasue they are never recharged,+      -- because they activate as soon as recharged.+      benApply = (effSelf + effDice  -- hits self with dice too, when applying+                  + if periodic then 0 else sum chargeSelf)+                 `divUp` if durable then 1 else durabilityMult+      -- For melee, we add the foe part.+      benMelee = (effFoe + effDice  -- @AddHurtMelee@ already in @eqpSum@+                  + if periodic then 0 else sum chargeFoe)+                 `divUp` if durable then 1 else durabilityMult+      -- The periodic effects, if any, are activated when projectile flies,+      -- but not when it hits, so they are not added to @benFling@.+      -- However, if item is not periodic, the recharging effects+      -- are activated at projectile impact, hence their value is added.+      benFling = effFoe + benFlingDice -- nothing in @eqpSum@; normally not worn+                 + if periodic then 0 else sum chargeFoe+      benFlingDice | jdamage item <= 0 = 0  -- speedup+                   | otherwise = min 0 $+        let hurtMult = 100 + min 99 (max (-99) (aHurtMelee aspects))+              -- assumes no enemy armor and no block+            dmg = Dice.meanDice (jdamage item)+            rawDeltaHP = fromIntegral hurtMult * xM dmg `divUp` 100+            -- For simplicity, we ignore range bonus/malus and @Lobable@.+            IK.ThrowMod{IK.throwVelocity} = strengthToThrow item+            speed = speedFromWeight (jweight item) throwVelocity+        in fromEnum $ - modifyDamageBySpeed rawDeltaHP speed * 10 `div` oneM+             -- 1 damage valued at 10, just as in @damageUsefulness@+      -- For equipment benefit, we take into account only the self+      -- value of the recharging effects, because they applied to self.+      -- We don't add a bonus @averageTurnValue@ to the value of periodic+      -- effects, even though they save a turn, by being auto-applied,+      -- because on the flip side, player is not in control of the precise+      -- timing of their activation and also occasionally needs to spend a turn+      -- unequipping them to prevent activation. Note also that periodic+      -- activations don't consume the item, whether it's durable or not.+      eqpBens = recordToBenefit aspects+                ++ if periodic then chargeSelf else []+      sumBens = sum eqpBens+      -- Equipped items may incur crippling maluses via aspects and periodic+      -- effects. Examples of crippling maluses are, e.g., such that make melee+      -- impossible or moving impossible. AI can't live with those and can't+      -- value those competently against bonuses the item provides.+      cripplingDrawback = not (null eqpBens) && minimum eqpBens < -20+      eqpSum = sumBens - if cripplingDrawback then 100 else 0+      -- If a weapon heals enemy at impact, it won't be used for melee+      -- (but can be equipped anyway). If it harms wearer too much,+      -- won't be worn but still may be flung, etc.+      (benInEqp, benPickup)+        | isMelee item && benMelee < 0 && eqpSum >= -20 =+          ( True  -- equip, melee crucial, and only weapons in eqp can be used+          , if durable+            then eqpSum+                 + max 0 (max benApply (- benMelee))  -- apply or melee or not+            else max 0 (- benMelee))  -- melee is predominant+        | goesIntoEqp item && eqpSum > 0 =  -- weapon or other equippable+          ( True  -- equip; long time bonus usually outweighs fling or apply+          , eqpSum  -- possibly spent turn equipping, so reap the benefits+            + if durable+              then max 0 benApply  -- apply or not but don't fling+              else 0)  -- don't remove from equipment by using up+        | otherwise =+          (False, max 0 (max benApply (- benFling)))  -- apply or fling+  in Benefit{..}

− Game/LambdaHack/Client/ProtocolClient.hs

@@ -1,14 +0,0 @@-{-# LANGUAGE FlexibleContexts, FunctionalDependencies, RankNTypes, TupleSections-             #-}--- | The client-server communication monads.-module Game.LambdaHack.Client.ProtocolClient-  ( MonadClientReadResponse(..), MonadClientWriteRequest(..)-  ) where--import Game.LambdaHack.Client.MonadClient--class MonadClient m => MonadClientReadResponse resp m | m -> resp where-  receiveResponse  :: m resp--class MonadClient m => MonadClientWriteRequest req m | m -> req where-  sendRequest  :: req -> m ()

Game/LambdaHack/Client/State.hs view

@@ -1,185 +1,140 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveGeneric #-} -- | Server and client game state types and operations. module Game.LambdaHack.Client.State-  ( StateClient(..), defStateClient, defaultHistory+  ( StateClient(..), emptyStateClient+  , AlterLid   , updateTarget, getTarget, updateLeader, sside-  , PathEtc, TgtMode(..), RunParams(..), LastRecord, EscAI(..)-  , toggleMarkVision, toggleMarkSmell, toggleMarkSuspect+  , BfsAndPath(..), TgtAndPath(..), cycleMarkSuspect   ) where -import Control.Exception.Assert.Sugar+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES-import Data.Text (Text)-import qualified Data.Text as T-import qualified NLP.Miniutter.English as MU+import qualified Data.Map.Strict as M+import GHC.Generics (Generic) import qualified System.Random as R-import System.Time  import Game.LambdaHack.Atomic import Game.LambdaHack.Client.Bfs-import Game.LambdaHack.Client.ItemSlot-import qualified Game.LambdaHack.Client.Key as K import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.ClientOptions import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.State-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.ModeKind (ModeKind)  -- | Client state, belonging to a single faction. -- Some of the data, e.g, the history, carries over -- from game to game, even across playing sessions.+--+-- When many actors want to fling at the same target, they set+-- their personal targets to follow the common xhair.+-- When each wants to kill a fleeing enemy they recently meleed,+-- they keep the enemies as their personal targets.+-- -- Data invariant: if @_sleader@ is @Nothing@ then so is @srunning@. data StateClient = StateClient-  { stgtMode     :: !(Maybe TgtMode)-                                   -- ^ targeting mode-  , scursor      :: !Target        -- ^ the common, cursor target-  , seps         :: !Int           -- ^ a parameter of the tgt digital line-  , stargetD     :: !(EM.EnumMap ActorId (Target, Maybe PathEtc))+  { seps          :: !Int           -- ^ a parameter of the aiming digital line+  , stargetD      :: !(EM.EnumMap ActorId TgtAndPath)                                    -- ^ targets of our actors in the dungeon-  , sexplored    :: !(ES.EnumSet LevelId)+  , sexplored     :: !(ES.EnumSet LevelId)                                    -- ^ the set of fully explored levels-  , sbfsD        :: !(EM.EnumMap ActorId-                        ( Bool, PointArray.Array BfsDistance-                        , Point, Int, Maybe [Point]) )+  , sbfsD         :: !(EM.EnumMap ActorId BfsAndPath)                                    -- ^ pathfinding distances for our actors                                    --   and paths to their targets, if any-  , sselected    :: !(ES.EnumSet ActorId)-                                   -- ^ the set of currently selected actors-  , srunning     :: !(Maybe RunParams)-                                   -- ^ parameters of the current run, if any-  , sreport      :: !Report        -- ^ current messages-  , shistory     :: !History       -- ^ history of messages-  , sdisplayed   :: !(EM.EnumMap LevelId Time)-                                   -- ^ moves are displayed up to this time-  , sundo        :: ![CmdAtomic]   -- ^ atomic commands performed to date-  , sdiscoKind   :: !DiscoveryKind    -- ^ remembered item discoveries-  , sdiscoEffect :: !DiscoveryEffect  -- ^ remembered effects&Co of items-  , sfper        :: !FactionPers   -- ^ faction perception indexed by levels-  , srandom      :: !R.StdGen      -- ^ current random generator-  , slastKM      :: !K.KM          -- ^ last issued key command-  , slastRecord  :: !LastRecord    -- ^ state of key sequence recording-  , slastPlay    :: ![K.KM]        -- ^ state of key sequence playback-  , slastLost    :: !(ES.EnumSet ActorId)-                                   -- ^ actors that just got out of sight-  , swaitTimes   :: !Int           -- ^ player just waited this many times-  , _sleader     :: !(Maybe ActorId)-                                   -- ^ current picked party leader-  , _sside       :: !FactionId     -- ^ faction controlled by the client-  , squit        :: !Bool          -- ^ exit the game loop-  , sisAI        :: !Bool          -- ^ whether it's an AI client-  , smarkVision  :: !Bool          -- ^ mark leader and party FOV-  , smarkSmell   :: !Bool          -- ^ mark smell, if the leader can smell-  , smarkSuspect :: !Bool          -- ^ mark suspect features-  , scurDiff     :: !Int           -- ^ current game difficulty level-  , snxtDiff     :: !Int           -- ^ next game difficulty level-  , sslots       :: !ItemSlots     -- ^ map from slots to items-  , slastSlot    :: !SlotChar      -- ^ last used slot-  , slastStore   :: !CStore        -- ^ last used store-  , sescAI       :: !EscAI         -- ^ just canceled AI control with ESC-  , sdebugCli    :: !DebugModeCli  -- ^ client debugging mode+  , sundo         :: ![CmdAtomic]   -- ^ atomic commands performed to date+  , sdiscoKind    :: !DiscoveryKind    -- ^ remembered item discoveries+  , sdiscoAspect  :: !DiscoveryAspect  -- ^ remembered aspects of items+  , sdiscoBenefit :: !DiscoveryBenefit  -- ^ remembered AI benefits of items+  , sactorAspect  :: !ActorAspect   -- ^ best known actor aspect data+  , sfper         :: !PerLid        -- ^ faction perception indexed by levels+  , salter        :: !AlterLid      -- ^ cached alter ability data for positions+  , srandom       :: !R.StdGen      -- ^ current random generator+  , _sleader      :: !(Maybe ActorId)+                                   -- ^ candidate new leader of the faction;+                                   --   Faction._gleader is the old leader+  , _sside        :: !FactionId     -- ^ faction controlled by the client+  , squit         :: !Bool          -- ^ exit the game loop+  , scurChal      :: !Challenge     -- ^ current game challenge setup+  , snxtChal      :: !Challenge     -- ^ next game challenge setup+  , snxtScenario  :: !Int           -- ^ next game scenario number+  , smarkSuspect  :: !Int           -- ^ mark suspect features+  , scondInMelee  :: !(EM.EnumMap LevelId (Maybe Bool))+                                    -- ^ condInMelee value, unless invalidated+  , svictories    :: !(EM.EnumMap (Kind.Id ModeKind) (M.Map Challenge Int))+      -- ^ won games at particular difficulty levels+  , sdebugCli     :: !DebugModeCli  -- ^ client debugging mode   }   deriving Show -type PathEtc = ([Point], (Point, Int))---- | Current targeting mode of a client.-newtype TgtMode = TgtMode { tgtLevelId :: LevelId }-  deriving (Show, Eq, Binary)+data BfsAndPath =+    BfsInvalid+  | BfsAndPath { bfsArr  :: !(PointArray.Array BfsDistance)+               , bfsPath :: !(EM.EnumMap Point AndPath)+               }+  deriving Show --- | Parameters of the current run.-data RunParams = RunParams-  { runLeader  :: !ActorId         -- ^ the original leader from run start-  , runMembers :: ![ActorId]       -- ^ the list of actors that take part-  , runInitial :: !Bool            -- ^ initial run continuation by any-                                   --   run participant, including run leader-  , runStopMsg :: !(Maybe Text)    -- ^ message with the next stop reason-  , runWaiting :: !Int             -- ^ waiting for others to move out of the way-  }-  deriving (Show)+data TgtAndPath = TgtAndPath {tapTgt :: !Target, tapPath :: !AndPath}+  deriving (Show, Generic) -type LastRecord = ( [K.KM]  -- accumulated keys of the current command-                  , [K.KM]  -- keys of the rest of the recorded command batch-                  , Int     -- commands left to record for this batch-                  )+instance Binary TgtAndPath -data EscAI = EscAINothing | EscAIStarted | EscAIMenu | EscAIExited-  deriving (Show, Eq)+type AlterLid = EM.EnumMap LevelId (PointArray.Array Word8) --- | Initial game client state.-defStateClient :: History -> Report -> FactionId -> Bool -> StateClient-defStateClient shistory sreport _sside sisAI =+-- | Initial empty game client state.+emptyStateClient :: FactionId -> StateClient+emptyStateClient _sside =   StateClient-    { stgtMode = Nothing-    , scursor = if sisAI-                then TVector $ Vector 30000 30000  -- invalid-                else TVector $ Vector 1 1  -- a step south-east-    , seps = fromEnum _sside+    { seps = fromEnum _sside     , stargetD = EM.empty     , sexplored = ES.empty     , sbfsD = EM.empty-    , sselected = ES.empty-    , srunning = Nothing-    , sreport-    , shistory-    , sdisplayed = EM.empty     , sundo = []     , sdiscoKind = EM.empty-    , sdiscoEffect = EM.empty+    , sdiscoAspect = EM.empty+    , sdiscoBenefit = EM.empty+    , sactorAspect = EM.empty     , sfper = EM.empty-    , srandom = R.mkStdGen 42  -- will be set later-    , slastKM = K.escKM-    , slastRecord = ([], [], 0)-    , slastPlay = []-    , slastLost = ES.empty-    , swaitTimes = 0+    , salter = EM.empty+    , srandom = R.mkStdGen 42  -- will get modified in this and future games     , _sleader = Nothing  -- no heroes yet alive     , _sside     , squit = False-    , sisAI-    , smarkVision = False-    , smarkSmell = True-    , smarkSuspect = False-    , scurDiff = difficultyDefault-    , snxtDiff = difficultyDefault-    , sslots = (EM.empty, EM.empty)-    , slastSlot = SlotChar 0 'Z'-    , slastStore = CInv-    , sescAI = EscAINothing+    , scurChal = defaultChallenge+    , snxtChal = defaultChallenge+    , snxtScenario = 0+    , smarkSuspect = 1+    , scondInMelee = EM.empty+    , svictories = EM.empty     , sdebugCli = defDebugModeCli     } -defaultHistory :: Int -> IO History-defaultHistory configHistoryMax = do-  dateTime <- getClockTime-  let curDate = MU.Text $ T.pack $ calendarTimeToString $ toUTCTime dateTime-  let emptyHist = emptyHistory configHistoryMax-  return $! addReport emptyHist timeZero-         $! singletonReport-         $! makeSentence ["Human history log started on", curDate]+cycleMarkSuspect :: StateClient -> StateClient+cycleMarkSuspect s@StateClient{smarkSuspect} =+  s {smarkSuspect = (smarkSuspect + 1) `mod` 3}  -- | Update target parameters within client state. updateTarget :: ActorId -> (Maybe Target -> Maybe Target) -> StateClient              -> StateClient updateTarget aid f cli =-  let f2 tp = case f $ fmap fst tp of+  let f2 tp = case f $ fmap tapTgt tp of         Nothing -> Nothing-        Just tgt -> Just (tgt, Nothing)  -- reset path+        Just tgt -> Just $ TgtAndPath tgt NoPath  -- reset path   in cli {stargetD = EM.alter f2 aid (stargetD cli)}  -- | Get target parameters from client state. getTarget :: ActorId -> StateClient -> Maybe Target-getTarget aid cli = fmap fst $ EM.lookup aid $ stargetD cli+getTarget aid cli = fmap tapTgt $ EM.lookup aid $ stargetD cli  -- | Update picked leader within state. Verify actor's faction. updateLeader :: ActorId -> State -> StateClient -> StateClient@@ -193,94 +148,54 @@ sside :: StateClient -> FactionId sside = _sside -toggleMarkVision :: StateClient -> StateClient-toggleMarkVision s@StateClient{smarkVision} = s {smarkVision = not smarkVision}--toggleMarkSmell :: StateClient -> StateClient-toggleMarkSmell s@StateClient{smarkSmell} = s {smarkSmell = not smarkSmell}--toggleMarkSuspect :: StateClient -> StateClient-toggleMarkSuspect s@StateClient{smarkSuspect} =-  s {smarkSuspect = not smarkSuspect}- instance Binary StateClient where   put StateClient{..} = do-    put stgtMode-    put scursor     put seps     put stargetD     put sexplored-    put sselected-    put srunning-    put sreport-    put shistory     put sundo-    put sdisplayed     put sdiscoKind-    put sdiscoEffect+    put sdiscoAspect+    put sdiscoBenefit     put (show srandom)     put _sleader     put _sside-    put sisAI-    put smarkVision-    put smarkSmell+    put scurChal+    put snxtChal+    put snxtScenario     put smarkSuspect-    put scurDiff-    put snxtDiff-    put sslots-    put slastSlot-    put slastStore-    put sdebugCli  -- TODO: this is overwritten at once+    put scondInMelee+    put svictories+    put sdebugCli+#ifdef WITH_EXPENSIVE_ASSERTIONS+    put sfper+#endif   get = do-    stgtMode <- get-    scursor <- get     seps <- get     stargetD <- get     sexplored <- get-    sselected <- get-    srunning <- get-    sreport <- get-    shistory <- get     sundo <- get-    sdisplayed <- get     sdiscoKind <- get-    sdiscoEffect <- get+    sdiscoAspect <- get+    sdiscoBenefit <- get     g <- get     _sleader <- get     _sside <- get-    sisAI <- get-    smarkVision <- get-    smarkSmell <- get+    scurChal <- get+    snxtChal <- get+    snxtScenario <- get     smarkSuspect <- get-    scurDiff <- get-    snxtDiff <- get-    sslots <- get-    slastSlot <- get-    slastStore <- get+    scondInMelee <- get+    svictories <- get     sdebugCli <- get     let sbfsD = EM.empty-        sfper = EM.empty+        sactorAspect = EM.empty+        salter = EM.empty         srandom = read g-        slastKM = K.escKM-        slastRecord = ([], [], 0)-        slastPlay = []-        slastLost = ES.empty-        swaitTimes = 0         squit = False-        sescAI = EscAINothing+#ifndef WITH_EXPENSIVE_ASSERTIONS+        sfper = EM.empty+#else+    sfper <- get+#endif     return $! StateClient{..}--instance Binary RunParams where-  put RunParams{..} = do-    put runLeader-    put runMembers-    put runInitial-    put runStopMsg-    put runWaiting-  get = do-    runLeader <- get-    runMembers <- get-    runInitial <- get-    runStopMsg <- get-    runWaiting <- get-    return $! RunParams{..}

Game/LambdaHack/Client/UI.hs view

@@ -1,47 +1,58 @@-{-# LANGUAGE CPP #-} -- | Ways for the client to use player input via UI to produce server -- requests, based on the client's view (visualized for the player) -- of the game state. module Game.LambdaHack.Client.UI   ( -- * Client UI monad-    MonadClientUI+    MonadClientUI(..)     -- * Assorted UI operations-  , queryUI, pongUI+  , putSession, queryUI   , displayRespUpdAtomicUI, displayRespSfxAtomicUI     -- * Startup-  , srtFrontend, KeyKind, SessionUI+  , KeyKind, SessionUI(..), emptySessionUI, Config+  , ChanFrontend, chanFrontend, frontendShutdown     -- * Operations exposed for LoopClient-  , ColorMode(..), displayMore, msgAdd+  , ColorMode(..)+  , reportToSlideshow, getConfirms, msgAdd, promptAdd, addPressedEsc+  , tryRestore, stdBinding #ifdef EXPOSE_INTERNAL     -- * Internal operations   , humanCommand #endif   ) where -import Control.Exception.Assert.Sugar-import Control.Monad+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.Map.Strict as M-import Data.Maybe+import qualified Data.Text as T -import Game.LambdaHack.Atomic-import qualified Game.LambdaHack.Client.Key as K import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.State+import Game.LambdaHack.Client.UI.Config import Game.LambdaHack.Client.UI.Content.KeyKind-import Game.LambdaHack.Client.UI.DisplayAtomicClient-import Game.LambdaHack.Client.UI.HandleHumanClient-import Game.LambdaHack.Client.UI.HumanCmd+import Game.LambdaHack.Client.UI.DisplayAtomicM+import Game.LambdaHack.Client.UI.FrameM+import Game.LambdaHack.Client.UI.Frontend+import Game.LambdaHack.Client.UI.HandleHelperM+import Game.LambdaHack.Client.UI.HandleHumanM+import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.KeyBindings import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Client.UI.MsgClient-import Game.LambdaHack.Client.UI.StartupFrontendClient-import Game.LambdaHack.Client.UI.WidgetClient+import Game.LambdaHack.Client.UI.Msg+import Game.LambdaHack.Client.UI.MsgM+import Game.LambdaHack.Client.UI.Overlay+import Game.LambdaHack.Client.UI.OverlayM+import Game.LambdaHack.Client.UI.SessionUI+import Game.LambdaHack.Client.UI.Slideshow+import Game.LambdaHack.Client.UI.SlideshowM+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.ClientOptions import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Request import Game.LambdaHack.Common.State import Game.LambdaHack.Content.ModeKind@@ -51,115 +62,111 @@ queryUI = do   side <- getsClient sside   fact <- getsState $ (EM.! side) . sfactionD-  let (leader, mtgt) = fromMaybe (assert `failure` fact) $ gleader fact-  req <- humanCommand-  leader2 <- getLeaderUI-  mtgt2 <- getsClient $ fmap fst . EM.lookup leader2 . stargetD-  if (leader2, mtgt2) /= (leader, mtgt)-    then return $! ReqUILeader leader2 mtgt2 req-    else return $! req+  if isAIFact fact then do+    recordHistory+    keyPressed <- anyKeyPressed+    if keyPressed && fleaderMode (gplayer fact) /= LeaderNull then do+      discardPressedKey+      addPressedEsc+      -- Regaining control of faction cancels --stopAfter*.+      modifyClient $ \cli ->+        cli {sdebugCli = (sdebugCli cli) { sstopAfterSeconds = Nothing+                                         , sstopAfterFrames = Nothing }}+      return (ReqUIAutomate, Nothing)  -- stop AI+    else do+      -- As long as UI faction is under AI control, check, once per move,+      -- for benchmark game stop.+      stopAfterFrames <- getsClient $ sstopAfterFrames . sdebugCli+      case stopAfterFrames of+        Nothing -> do+          stopAfterSeconds <- getsClient $ sstopAfterSeconds . sdebugCli+          case stopAfterSeconds of+            Nothing -> return (ReqUINop, Nothing)+            Just stopS -> do+              exit <- elapsedSessionTimeGT stopS+              if exit then do+                tellAllClipPS+                return (ReqUIGameExit, Nothing)  -- ask server to exit+              else return (ReqUINop, Nothing)+        Just stopF -> do+          allNframes <- getsSession sallNframes+          gnframes <- getsSession snframes+          if allNframes + gnframes >= stopF then do+            tellAllClipPS+            return (ReqUIGameExit, Nothing)  -- ask server to exit+          else return (ReqUINop, Nothing)+  else do+    let mleader = _gleader fact+        !_A = assert (isJust mleader) ()+    req <- humanCommand+    leader2 <- getLeaderUI+    return (req, if mleader /= Just leader2 then Just leader2 else Nothing)  -- | Let the human player issue commands until any command takes time.-humanCommand :: forall m. MonadClientUI m => m RequestUI+humanCommand :: forall m. MonadClientUI m => m ReqUI humanCommand = do-  -- For human UI we invalidate whole @sbfsD@ at the start of each-  -- UI player input that start a player move, which is an overkill,-  -- but doesn't slow screensavers, because they are UI,-  -- but not human.-  modifyClient $ \cli -> cli {sbfsD = EM.empty, slastLost = ES.empty}-  let loop :: Either Bool (Maybe Bool, Overlay) -> m RequestUI-      loop mover = do-        (lastBlank, over) <- case mover of-          Left b -> do-            -- Display current state and keys if no slideshow or if interrupted.-            keys <- if b then describeMainKeys else return ""-            sli <- promptToSlideshow keys-            return (Nothing, head . snd $! slideshow sli)-          Right bLast ->-            -- (Re-)display the last slide while waiting for the next key.-            return bLast-        (seqCurrent, seqPrevious, k) <- getsClient slastRecord-        case k of-          0 -> do-            let slastRecord = ([], seqCurrent, 0)-            modifyClient $ \cli -> cli {slastRecord}-          _ -> do-            let slastRecord = ([], seqCurrent ++ seqPrevious, k - 1)-            modifyClient $ \cli -> cli {slastRecord}-        lastPlay <- getsClient slastPlay-        km <- getKeyOverlayCommand lastBlank over+  modifySession $ \sess -> sess {slastLost = ES.empty}+  modifySession $ \sess -> sess {skeysHintMode = KeysHintAbsent}+  let loop :: m ReqUI+      loop = do+        report <- getsSession _sreport+        if nullReport report then do+          -- Display keys sometimes, alternating with empty screen.+          keysHintMode <- getsSession skeysHintMode+          case keysHintMode of+            KeysHintPresent -> describeMainKeys >>= promptAdd+            KeysHintBlocked ->+              modifySession $ \sess -> sess {skeysHintMode = KeysHintAbsent}+            _ -> return ()+        else modifySession $ \sess -> sess {skeysHintMode = KeysHintBlocked}+        slidesRaw <- reportToSlideshowKeep []+        over <- case unsnoc slidesRaw of+          Nothing -> return []+          Just (allButLast, (ov, _)) ->+            if allButLast == emptySlideshow+            then+              -- Display the only generated slide while waiting for next key.+              -- Strip the "--end-" prompt from it.+              return $! init ov+            else do+              -- Show, one by one, all slides, awaiting confirmation for each.+              void $ getConfirms ColorFull [K.spaceKM, K.escKM] slidesRaw+              -- Display base frame at the end.+              return []+        (seqCurrent, seqPrevious, k) <- getsSession slastRecord+        let slastRecord | k == 0 = ([], seqCurrent, 0)+                        | otherwise = ([], seqCurrent ++ seqPrevious, k - 1)+        modifySession $ \sess -> sess {slastRecord}+        lastPlay <- getsSession slastPlay+        leader <- getLeaderUI+        b <- getsState $ getActorBody leader+        when (bhp b <= 0) $ displayMore ColorBW+          "If you move, the exertion will kill you. Consider asking for first aid instead."+        km <- promptGetKey ColorFull over False []         -- Messages shown, so update history and reset current report.         when (null lastPlay) recordHistory         abortOrCmd <- do           -- Look up the key.-          Binding{bcmdMap} <- askBinding-          case M.lookup km{K.pointer=Nothing} bcmdMap of+          Binding{bcmdMap} <- getsSession sbinding+          case km `M.lookup` bcmdMap of             Just (_, _, cmd) -> do-              -- Query and clear the last command key.-              modifyClient $ \cli -> cli-                {swaitTimes = if swaitTimes cli > 0-                              then - swaitTimes cli+              modifySession $ \sess -> sess+                {swaitTimes = if swaitTimes sess > 0+                              then - swaitTimes sess                               else 0}-              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}-                  stgtMode <- getsClient stgtMode-                  if km == K.escKM && isNothing stgtMode && isRight mover-                  then cmdHumanSem Clear-                  else cmdHumanSem cmd-            Nothing -> let msgKey = "unknown command <" <> K.showKM km <> ">"-                       in failWith msgKey+              cmdHumanSem cmd+            _ -> let msgKey = "unknown command <" <> K.showKM km <> ">"+                 in weaveJust <$> failWith (T.pack msgKey)         -- The command was failed or successful and if the latter,         -- possibly took some time.         case abortOrCmd of           Right cmdS ->             -- Exit the loop and let other actors act. No next key needed-            -- and no slides could have been generated.+            -- and no report could have been generated.             return cmdS-          Left slides -> do-            -- If no time taken, rinse and repeat.-            -- Analyse the obtained slides.-            let (onBlank, sli) = slideshow slides-            mLast <- case sli of-              [] -> do-                stgtMode <- getsClient stgtMode-                return $ Left $ isJust stgtMode || km == K.escKM-              [sLast] ->-                -- Avoid displaying the single slide twice.-                return $ Right (onBlank, sLast)-              _ -> do-                -- Show, one by one, all slides, awaiting confirmation-                -- for all but the last one (which is displayed twice, BTW).-                -- Note: the code that generates the slides is responsible-                -- for inserting the @more@ prompt.-                go <- getInitConfirms ColorFull [km] slides-                return $! if go then Right (onBlank, last sli) else Left True-            loop mLast-  loop $ Left False---- | Client signals to the server that it's still online, flushes frames--- (if needed) and sends some extra info.-pongUI :: MonadClientUI m => m RequestUI-pongUI = do-  escPressed <- tryTakeMVarSescMVar-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  let pong ats = return $ ReqUIPong ats-      underAI = 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]-  else do-    -- Respond to the server normally, perhaps pinging the frontend, too.-    when underAI syncFrames-    pong []+          Left Nothing -> loop+          Left (Just err) -> do+            stopPlayBack+            promptAdd $ showFailError err+            loop+  loop

+ Game/LambdaHack/Client/UI/ActorUI.hs view

@@ -0,0 +1,103 @@+{-# LANGUAGE DeriveGeneric #-}+-- | UI aspects of actors.+module Game.LambdaHack.Client.UI.ActorUI+  ( ActorUI(..), ActorDictUI+  , keySelected, partActor, partPronoun+  , ppContainer, ppCStore, ppCStoreIn, ppCStoreWownW+  , ppContainerWownW, verbCStore, tryFindHeroK+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Data.Binary+import qualified Data.Char as Char+import qualified Data.EnumMap.Strict as EM+import GHC.Generics (Generic)+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Common.Actor+import qualified Game.LambdaHack.Common.Color as Color+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.State++data ActorUI = ActorUI+  { bsymbol  :: !Char         -- ^ individual map symbol+  , bname    :: !Text         -- ^ individual name+  , bpronoun :: !Text         -- ^ individual pronoun+  , bcolor   :: !Color.Color  -- ^ individual map color+  }+  deriving (Show, Eq, Generic)++instance Binary ActorUI++type ActorDictUI = EM.EnumMap ActorId ActorUI++keySelected :: (ActorId, Actor, ActorUI)+            -> (Bool, Bool, Char, Color.Color, ActorId)+keySelected (aid, Actor{bhp}, ActorUI{bsymbol, bcolor}) =+  (bhp > 0, bsymbol /= '@', bsymbol, bcolor, aid)++-- | The part of speech describing the actor.+partActor :: ActorUI -> MU.Part+partActor b = MU.Text $ bname b++-- | The part of speech containing the actor pronoun.+partPronoun :: ActorUI -> MU.Part+partPronoun b = MU.Text $ bpronoun b++ppContainer :: Container -> Text+ppContainer CFloor{} = "nearby"+ppContainer CEmbed{} = "embedded nearby"+ppContainer (CActor _ cstore) = ppCStoreIn cstore+ppContainer c@CTrunk{} = assert `failure` c++ppCStore :: CStore -> (Text, Text)+ppCStore CGround = ("on", "the ground")+ppCStore COrgan = ("among", "organs")+ppCStore CEqp = ("in", "equipment")+ppCStore CInv = ("in", "pack")+ppCStore CSha = ("in", "shared stash")++ppCStoreIn :: CStore -> Text+ppCStoreIn c = let (tIn, t) = ppCStore c in tIn <+> t++ppCStoreWownW :: Bool -> CStore -> MU.Part -> [MU.Part]+ppCStoreWownW addPrepositions store owner =+  let (preposition, noun) = ppCStore store+      prep = [MU.Text preposition | addPrepositions]+  in prep ++ case store of+    CGround -> [MU.Text noun, "under", owner]+    CSha -> [MU.Text noun]+    _ -> [MU.WownW owner (MU.Text noun) ]++ppContainerWownW :: (ActorId -> MU.Part) -> Bool -> Container -> [MU.Part]+ppContainerWownW ownerFun addPrepositions c = case c of+  CFloor{} -> ["nearby"]+  CEmbed{} -> ["embedded nearby"]+  CActor aid store -> let owner = ownerFun aid+                      in ppCStoreWownW addPrepositions store owner+  CTrunk{} -> assert `failure` c++verbCStore :: CStore -> Text+verbCStore CGround = "drop"+verbCStore COrgan = "implant"+verbCStore CEqp = "equip"+verbCStore CInv = "pack"+verbCStore CSha = "stash"++-- | Tries to finds an actor body satisfying a predicate on any level.+tryFindActor :: State -> (ActorId -> Actor -> Bool) -> Maybe (ActorId, Actor)+tryFindActor s p = find (uncurry p) $ EM.assocs $ sactorD s++tryFindHeroK :: ActorDictUI -> FactionId -> Int -> State+             -> Maybe (ActorId, Actor)+tryFindHeroK d fid k s =+  let c | k == 0          = '@'+        | k > 0 && k < 10 = Char.intToDigit k+        | otherwise       = ' '  -- no hero with such symbol+  in tryFindActor s (\aid body ->+       maybe False ((== c) . bsymbol) (EM.lookup aid d)+       && bfid body == fid)

Game/LambdaHack/Client/UI/Animation.hs view

@@ -1,137 +1,80 @@-{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} -- | Screen frames and animations. module Game.LambdaHack.Client.UI.Animation-  ( SingleFrame(..), decodeLine, encodeLine-  , overlayOverlay-  , Animation, Frames, renderAnim, restrictAnim-  , twirlSplash, blockHit, blockMiss, deathBody, actorX-  , swapPlaces, moveProj, fadeout+  ( Animation, renderAnim+  , pushAndDelay, blinkColorActor, twirlSplash, blockHit, blockMiss+  , deathBody, shortDeathBody, actorX, swapPlaces, teleport, fadeout   ) where -import Control.Exception.Assert.Sugar-import Data.Binary+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Data.Bits import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.List-import Data.Maybe-import Data.Monoid-import qualified Data.Vector.Generic as G-import GHC.Generics (Generic) +import Game.LambdaHack.Client.UI.Frame+import Game.LambdaHack.Client.UI.Overlay import Game.LambdaHack.Common.Color-import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random -decodeLine :: ScreenLine -> [AttrChar]-decodeLine v = map (toEnum . fromIntegral) $ G.toList v---- | The data sufficent to draw a single game screen frame.-data SingleFrame = SingleFrame-  { sfLevel  :: ![ScreenLine]  -- ^ screen, from top to bottom, line by line-  , sfTop    :: !Overlay       -- ^ some extra lines to show over the top-  , sfBottom :: ![ScreenLine]  -- ^ some extra lines to show at the bottom-  , sfBlank  :: !Bool          -- ^ display only @sfTop@, on blank screen-  }-  deriving (Eq, Show, Generic)--instance Binary SingleFrame---- | Overlays the @sfTop@ and @sfBottom@ fields onto the @sfLevel@ field.--- The resulting frame has empty @sfTop@ and @sfBottom@.--- To be used by simple frontends that don't display overlays--- in separate windows/panes/scrolled views.-overlayOverlay :: SingleFrame -> SingleFrame-overlayOverlay SingleFrame{..} =-  let lxsize = fst normalLevelBound + 1  -- TODO-      lysize = snd normalLevelBound + 1-      emptyLine = encodeLine-                  $ replicate lxsize (Color.AttrChar Color.defAttr ' ')-      canvasLength = if sfBlank then lysize + 3 else lysize + 1-      canvas | sfBlank = replicate canvasLength emptyLine-             | otherwise = emptyLine : sfLevel-      topTrunc = overlay sfTop-      topLayer = if length topTrunc <= canvasLength-                 then topTrunc-                 else take (canvasLength - 1) topTrunc-                      ++ [toScreenLine "--a portion of the text trimmed--"]-      f layerLine canvasLine =-        layerLine G.++ G.drop (G.length layerLine) canvasLine-      picture = zipWith f topLayer canvas-      bottomLines = if sfBlank then [] else sfBottom-      newLevel = picture ++ drop (length picture) canvas ++ bottomLines-  in SingleFrame { sfLevel = newLevel-                 , sfTop = emptyOverlay-                 , sfBottom = []-                 , sfBlank }- -- | Animation is a list of frame modifications to play one by one, -- where each modification if a map from positions to level map symbols.-newtype Animation = Animation [EM.EnumMap Point AttrChar]-  deriving (Eq, Show, Monoid)---- | Sequences of screen frames, including delays.-type Frames = [Maybe SingleFrame]+newtype Animation = Animation [Overlay]+  deriving (Eq, Show)  -- | Render animations on top of a screen frame.-renderAnim :: X -> Y -> SingleFrame -> Animation -> Frames-renderAnim lxsize lysize basicFrame (Animation anim) =-  let modifyFrame SingleFrame{sfLevel = []} _ =-        assert `failure` (lxsize, lysize, basicFrame, anim)-      modifyFrame SingleFrame{sfLevel = levelOld, ..} am =-        let fLine y lineOld =-              let f l (x, acOld) =-                    let pos = Point x y-                        !ac = EM.findWithDefault acOld pos am-                    in ac : l-              in foldl' f [] (zip [lxsize-1,lxsize-2..0] (reverse lineOld))-            sfLevel =  -- fully evaluated inside-              let f l (y, lineOld) = let !line = fLine y lineOld in line : l-              in map encodeLine-                 $ foldl' f [] (zip [lysize-1,lysize-2..0]-                                $ reverse $ map decodeLine levelOld)-        in Just SingleFrame{..}  -- a thunk within Just-  in map (modifyFrame basicFrame) anim+renderAnim :: FrameForall -> Animation -> Frames+renderAnim basicFrame (Animation anim) =+  let modifyFrame :: Overlay -> FrameForall+      modifyFrame am = overlayFrame am basicFrame+      modifyFrames :: (Overlay, Overlay) -> Maybe FrameForall+      modifyFrames (am, amPrevious) =+        if am == amPrevious then Nothing else Just $ modifyFrame am+  in Just basicFrame : map modifyFrames (zip anim ([] : anim)) -blank :: Maybe AttrChar+blank :: Maybe AttrCharW32 blank = Nothing -cSym :: Color -> Char -> Maybe AttrChar-cSym color symbol = Just $ AttrChar (Attr color defBG) symbol+cSym :: Color -> Char -> Maybe AttrCharW32+cSym color symbol = Just $ attrChar2ToW32 color symbol -mzipPairs :: (Point, Point) -> (Maybe AttrChar, Maybe AttrChar)-          -> [(Point, AttrChar)]-mzipPairs (p1, p2) (mattr1, mattr2) =-  let mzip (pos, mattr) = fmap (\x -> (pos, x)) mattr+mapPosToOffset :: (Point, AttrCharW32) -> (Int, [AttrCharW32])+mapPosToOffset (Point{..}, attr) =+  let lxsize = fst normalLevelBound + 1+  in ((py + 1) * lxsize + px, [attr])++mzipSingleton :: Point -> Maybe AttrCharW32 -> Overlay+mzipSingleton p1 mattr1 = map mapPosToOffset $+  let mzip (pos, mattr) = fmap (\attr -> (pos, attr)) mattr+  in catMaybes [mzip (p1, mattr1)]++mzipPairs :: (Point, Point) -> (Maybe AttrCharW32, Maybe AttrCharW32)+          -> Overlay+mzipPairs (p1, p2) (mattr1, mattr2) = map mapPosToOffset $+  let mzip (pos, mattr) = fmap (\attr -> (pos, attr)) mattr   in catMaybes $ if p1 /= p2                  then [mzip (p1, mattr1), mzip (p2, mattr2)]                  else -- If actor affects himself, show only the effect,                       -- not the action.                       [mzip (p1, mattr1)] -mzipTriples :: (Point, Point, Point)-            -> (Maybe AttrChar, Maybe AttrChar, Maybe AttrChar)-            -> [(Point, AttrChar)]-mzipTriples (p1, p2, p3) (mattr1, mattr2, mattr3) =-  let mzip (pos, mattr) = fmap (\x -> (pos, x)) mattr-  in catMaybes [mzip (p1, mattr1), mzip (p2, mattr2), mzip (p3, mattr3)]--restrictAnim :: ES.EnumSet Point -> Animation -> Animation-restrictAnim vis (Animation as) =-  let f imap =-        let common = EM.intersection imap $ EM.fromSet (const ()) vis-          in if EM.null common then Nothing else Just common-  in Animation $ mapMaybe f as+pushAndDelay :: Animation+pushAndDelay = Animation [[]] --- TODO: in all but moveProj duplicate first and/or last frame, if required,--- since they are no longer duplicated in renderAnim+blinkColorActor :: Point -> Char -> Color -> Color -> Animation+blinkColorActor pos symbol fromCol toCol =+  Animation $ map (mzipSingleton pos)+  [ cSym toCol symbol+  , cSym toCol symbol+  , cSym fromCol symbol+  , cSym fromCol symbol+  ]  -- | Attack animation. A part of it also reused for self-damage and healing. twirlSplash :: (Point, Point) -> Color -> Color -> Animation-twirlSplash poss c1 c2 = Animation $ map (EM.fromList . mzipPairs poss)+twirlSplash poss c1 c2 = Animation $ map (mzipPairs poss)   [ (blank           , cSym BrCyan '\'')   , (blank           , cSym BrYellow '\'')   , (blank           , cSym BrYellow '^')@@ -143,13 +86,11 @@   , (cSym c1      '\\',blank)   , (cSym c2      '|', blank)   , (cSym c2      '%', blank)-  , (cSym c2      '%', blank)-  , (cSym c2      '/', blank)   ]  -- | Attack that hits through a block. blockHit :: (Point, Point) -> Color -> Color -> Animation-blockHit poss c1 c2 = Animation $ map (EM.fromList . mzipPairs poss)+blockHit poss c1 c2 = Animation $ map (mzipPairs poss)   [ (blank           , cSym BrCyan '\'')   , (blank           , cSym BrYellow '\'')   , (blank           , cSym BrYellow '^')@@ -171,7 +112,7 @@  -- | Attack that is blocked. blockMiss :: (Point, Point) -> Animation-blockMiss poss = Animation $ map (EM.fromList . mzipPairs poss)+blockMiss poss = Animation $ map (mzipPairs poss)   [ (blank           , cSym BrCyan '\'')   , (blank           , cSym BrYellow '^')   , (cSym BrBlue  '{', cSym BrYellow '\'')@@ -185,46 +126,60 @@  -- | Death animation for an organic body. deathBody :: Point -> Animation-deathBody pos = Animation $ map (maybe EM.empty (EM.singleton pos))-  [ cSym BrRed '\\'-  , cSym BrRed '\\'-  , cSym BrRed '|'-  , cSym BrRed '|'-  , cSym BrRed '%'-  , cSym BrRed '%'-  , cSym BrRed '-'-  , cSym BrRed '-'-  , cSym BrRed '\\'-  , cSym BrRed '\\'-  , cSym BrRed '|'-  , cSym BrRed '|'-  , cSym BrRed '%'-  , cSym BrRed '%'-  , cSym BrRed '%'-  , cSym Red   '%'-  , cSym Red   '%'-  , cSym Red   '%'-  , cSym Red   '%'-  , cSym Red   ';'-  , cSym Red   ';'-  , cSym Red   ','+deathBody pos = Animation $ map (mzipSingleton pos)+  [ cSym Red '%'+  , cSym Red '-'+  , cSym Red '-'+  , cSym Red '\\'+  , cSym Red '\\'+  , cSym Red '|'+  , cSym Red '|'+  , cSym Red '%'+  , cSym Red '%'+  , cSym Red '%'+  , cSym Red '%'+  , cSym Red ';'+  , cSym Red ';'   ] +-- | Death animation for an organic body, short version (e.g., for enemies).+shortDeathBody :: Point -> Animation+shortDeathBody pos = Animation $ map (mzipSingleton pos)+  [ cSym Red '%'+  , cSym Red '-'+  , cSym Red '\\'+  , cSym Red '|'+  , cSym Red '%'+  , cSym Red '%'+  , cSym Red '%'+  , cSym Red ';'+  , cSym Red ','+  ]+ -- | Mark actor location animation.-actorX :: Point -> Char -> Color.Color -> Animation-actorX pos symbol color = Animation $ map (maybe EM.empty (EM.singleton pos))+actorX :: Point -> Animation+actorX pos = Animation $ map (mzipSingleton pos)   [ cSym BrRed 'X'   , cSym BrRed 'X'-  , cSym BrRed symbol-  , cSym color symbol-  , cSym color symbol-  , cSym color symbol-  , cSym color symbol+  , blank+  , blank   ] +-- | Actor teleport animation.+teleport :: (Point, Point) -> Animation+teleport poss = Animation $ map (mzipPairs poss)+  [ (cSym BrMagenta 'o', cSym Magenta   '.')+  , (cSym BrMagenta 'O', cSym Magenta   '.')+  , (cSym Magenta   'o', cSym Magenta   'o')+  , (cSym Magenta   '.', cSym BrMagenta 'O')+  , (cSym Magenta   '.', cSym BrMagenta 'o')+  , (cSym Magenta   '.', blank)+  , (blank             , blank)+  ]+ -- | Swap-places animation, both hostile and friendly. swapPlaces :: (Point, Point) -> Animation-swapPlaces poss = Animation $ map (EM.fromList . mzipPairs poss)+swapPlaces poss = Animation $ map (mzipPairs poss)   [ (cSym BrMagenta 'o', cSym Magenta   'o')   , (cSym BrMagenta 'd', cSym Magenta   'p')   , (cSym BrMagenta '.', cSym Magenta   'p')@@ -232,22 +187,15 @@   , (cSym Magenta   'p', cSym BrMagenta 'd')   , (cSym Magenta   'p', cSym BrMagenta 'd')   , (cSym Magenta   'o', blank)-  ]--moveProj :: (Point, Point, Point) -> Char -> Color.Color -> Animation-moveProj poss symbol color = Animation $ map (EM.fromList . mzipTriples poss)-  [ (cSym BrBlack '.', cSym color symbol  , cSym color '.')---  , (cSym BrBlack '.', cSym BrBlack symbol, cSym color symbol)-  , (cSym BrBlack '.', cSym BrBlack '.'   , cSym color symbol)-  , (blank           , cSym BrBlack '.'   , cSym color symbol)+  , (blank             , blank)   ] -fadeout :: Bool -> Bool -> Int -> X -> Y -> Rnd Animation-fadeout out topRight step lxsize lysize = do+fadeout :: Bool -> Int -> X -> Y -> Rnd Animation+fadeout out step lxsize lysize = do   let xbound = lxsize - 1-      ybound = lysize - 1+      ybound = lysize + 2       edge = EM.fromDistinctAscList $ zip [1..] ".%&%;:,."-      fadeChar r n x y =+      fadeChar !r !n !x !y =         let d = x - 2 * y             ndy = n - d - 2 * ybound             ndx = n + d - xbound - 1  -- @-1@ for asymmetry@@ -261,16 +209,19 @@               | (x + 3 * y + v3) `mod` 30 < 19 = mnx + 1               | otherwise = mnx         in EM.findWithDefault ' ' k edge-      rollFrame n = do+      rollFrame !n = do         r <- random-        let l = [ ( Point (if topRight then x else xbound - x) y-                  , AttrChar defAttr $ fadeChar r n x y )-                | x <- [0..xbound]-                , y <- [max 0 (ybound - (n - x) `div` 2)..ybound]-                    ++ [0..min ybound ((n - xbound + x) `div` 2)]-                ]-        return $! EM.fromList l-      startN = if out then 3 else 1-      fs = [startN, startN + step .. 3 * lxsize `divUp` 4 + 2]-  as <- mapM rollFrame fs-  return $! Animation $ if out then as else reverse (EM.empty : as)+        let fadeAttr !y !x = attrChar1ToW32 $ fadeChar r n x y+            fadeLine !y =+              let x1 :: Int+                  {-# INLINE x1 #-}+                  x1 = min xbound (n - 2 * (ybound - y))+                  x2 :: Int+                  {-# INLINE x2 #-}+                  x2 = max 0 (xbound - (n - 2 * y))+              in [ (y * lxsize, map (fadeAttr y) [0..x1])+                 , (y * lxsize + x2, map (fadeAttr y) [x2..xbound]) ]+        return $! concatMap fadeLine [0..ybound]+      fs | out = [3, 3 + step .. lxsize - 14]+         | otherwise = [lxsize - 14, lxsize - 14 - step .. 1]+  Animation <$> mapM rollFrame fs

Game/LambdaHack/Client/UI/Config.hs view

@@ -4,59 +4,65 @@   ( Config(..), mkConfig, applyConfigToDebug   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Control.DeepSeq-import Control.Exception.Assert.Sugar-import Control.Monad+import Data.Binary import qualified Data.Ini as Ini import qualified Data.Ini.Reader as Ini import qualified Data.Ini.Types as Ini-import Data.List import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Text (Text) import qualified Data.Text as T import Game.LambdaHack.Common.ClientOptions import GHC.Generics (Generic)-import System.Directory import System.FilePath import Text.Read -import qualified Game.LambdaHack.Client.Key as K import Game.LambdaHack.Client.UI.HumanCmd+import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Common.File import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.RuleKind  -- | Fully typed contents of the UI config file. This config -- is a part of a game client. data Config = Config   { -- commands-    configCommands    :: ![(K.KM, ([CmdCategory], HumanCmd))]+    configCommands      :: ![(K.KM, CmdTriple)]     -- hero names-  , configHeroNames   :: ![(Int, (Text, Text))]+  , configHeroNames     :: ![(Int, (Text, Text))]     -- ui-  , configVi          :: !Bool  -- ^ the option for Vi keys takes precendence-  , configLaptop      :: !Bool  -- ^ because the laptop keys are the default-  , configFont        :: !String-  , configColorIsBold :: !Bool-  , configHistoryMax  :: !Int-  , configMaxFps      :: !Int-  , configNoAnim      :: !Bool-  , configRunStopMsgs :: !Bool+  , configVi            :: !Bool  -- ^ the option for Vi keys takes precendence+  , configLaptop        :: !Bool  -- ^ because the laptop keys are the default+  , configGtkFontFamily :: !Text+  , configSdlFontFile   :: !Text+  , configSdlTtfSizeAdd :: !Int+  , configSdlFonSizeAdd :: !Int+  , configFontSize      :: !Int+  , configColorIsBold   :: !Bool+  , configHistoryMax    :: !Int+  , configMaxFps        :: !Int+  , configNoAnim        :: !Bool+  , configRunStopMsgs   :: !Bool+  , configCmdline       :: ![String]   }   deriving (Show, Generic)  instance NFData Config +instance Binary Config+ parseConfig :: Ini.Config -> Config parseConfig cfg =   let configCommands =         let mkCommand (ident, keydef) =-              case stripPrefix "Macro_" ident of+              case stripPrefix "Cmd_" ident of                 Just _ ->                   let (key, def) = read keydef-                  in (K.mkKM key, def :: ([CmdCategory], HumanCmd))+                  in (K.mkKM key, def :: CmdTriple)                 Nothing -> assert `failure` "wrong macro id" `twith` ident             section = Ini.allItems "extra_commands" cfg         in map mkCommand section@@ -79,24 +85,29 @@       -- The option for Vi keys takes precendence,       -- because the laptop keys are the default.       configLaptop = not configVi && getOption "movementLaptopKeys_uk8o79jl"-      configFont = getOption "font"+      configGtkFontFamily = getOption "gtkFontFamily"+      configSdlFontFile = getOption "sdlFontFile"+      configSdlTtfSizeAdd = getOption "sdlTtfSizeAdd"+      configSdlFonSizeAdd = getOption "sdlFonSizeAdd"+      configFontSize = getOption "fontSize"       configColorIsBold = getOption "colorIsBold"       configHistoryMax = getOption "historyMax"       configMaxFps = max 1 $ getOption "maxFps"       configNoAnim = getOption "noAnim"       configRunStopMsgs = getOption "runStopMsgs"+      configCmdline = words $ getOption "overrideCmdline"   in Config{..}  -- | Read and parse UI config file.-mkConfig :: Kind.COps -> IO Config-mkConfig Kind.COps{corule} = do+mkConfig :: Kind.COps -> Bool -> IO Config+mkConfig Kind.COps{corule} benchmark = do   let stdRuleset = Kind.stdRuleset corule       cfgUIName = rcfgUIName stdRuleset       sUIDefault = rcfgUIDefault stdRuleset       cfgUIDefault = either (assert `failure`) id $ Ini.parse sUIDefault   dataDir <- appDataDir-  let userPath = dataDir </> cfgUIName <.> "ini"-  cfgUser <- do+  let userPath = dataDir </> cfgUIName+  cfgUser <- if benchmark then return Ini.emptyConfig else do     cpExists <- doesFileExist userPath     if not cpExists       then return Ini.emptyConfig@@ -108,18 +119,25 @@   -- Catch syntax errors in complex expressions ASAP,   return $! deepseq conf conf -applyConfigToDebug :: Config -> DebugModeCli -> Kind.COps-                   -> DebugModeCli-applyConfigToDebug sconfig sdebugCli Kind.COps{corule} =+applyConfigToDebug :: Kind.COps -> Config -> DebugModeCli -> DebugModeCli+applyConfigToDebug Kind.COps{corule} sconfig sdebugCli =   let stdRuleset = Kind.stdRuleset corule-  in (\dbg -> dbg {sfont =-        sfont dbg `mplus` Just (configFont sconfig)}) .+  in (\dbg -> dbg {sgtkFontFamily =+        sgtkFontFamily dbg `mplus` Just (configGtkFontFamily sconfig)}) .+     (\dbg -> dbg {sdlFontFile =+        sdlFontFile dbg `mplus` Just (configSdlFontFile sconfig)}) .+     (\dbg -> dbg {sdlTtfSizeAdd =+        sdlTtfSizeAdd dbg `mplus` Just (configSdlTtfSizeAdd sconfig)}) .+     (\dbg -> dbg {sdlFonSizeAdd =+        sdlFonSizeAdd dbg `mplus` Just (configSdlFonSizeAdd sconfig)}) .+     (\dbg -> dbg {sfontSize =+        sfontSize dbg `mplus` Just (configFontSize sconfig)}) .      (\dbg -> dbg {scolorIsBold =         scolorIsBold dbg `mplus` Just (configColorIsBold sconfig)}) .      (\dbg -> dbg {smaxFps =         smaxFps dbg `mplus` Just (configMaxFps sconfig)}) .      (\dbg -> dbg {snoAnim =         snoAnim dbg `mplus` Just (configNoAnim sconfig)}) .-     (\dbg -> dbg {ssavePrefixCli =-        ssavePrefixCli dbg `mplus` Just (rsavePrefix stdRuleset)})+     (\dbg -> dbg {stitle =+        stitle dbg `mplus` Just (rtitle stdRuleset)})      $ sdebugCli

Game/LambdaHack/Client/UI/Content/KeyKind.hs view

@@ -1,28 +1,179 @@ -- | The type of key-command mappings to be used for the UI. module Game.LambdaHack.Client.UI.Content.KeyKind-  ( KeyKind(..)-  , macroLeftButtonPress, macroShiftLeftButtonPress+  ( KeyKind(..), evalKeyDef+  , addCmdCategory, replaceDesc, moveItemTriple, repeatTriple+  , mouseLMB, mouseMMB, mouseRMB+  , goToCmd, runToAllCmd, autoexploreCmd, autoexplore25Cmd+  , aimFlingCmd, projectI, projectA, flingTs, applyI, applyIK+  , grabItems, dropItems, descTs, defaultHeroSelect   ) where -import qualified Game.LambdaHack.Client.Key as K+import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.Char as Char+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Client.UI.ActorUI (verbCStore) import Game.LambdaHack.Client.UI.HumanCmd+import qualified Game.LambdaHack.Client.UI.Key as K+import Game.LambdaHack.Common.Misc  -- | Key-command mappings to be used for the UI.-data KeyKind = KeyKind-  { rhumanCommands :: ![(K.KM, ([CmdCategory], HumanCmd))]-                                   -- ^ default client UI commands+newtype KeyKind = KeyKind+  { rhumanCommands :: [(K.KM, CmdTriple)]  -- ^ default client UI commands   } -macroLeftButtonPress :: HumanCmd-macroLeftButtonPress =-  Macro "go to pointer for 100 steps"-        [ "ALT-space", "ALT-minus"-        , "SHIFT-MiddleButtonPress", "CTRL-semicolon"-        , "CTRL-period", "V" ]+evalKeyDef :: (String, CmdTriple) -> (K.KM, CmdTriple)+evalKeyDef (t, triple@(cats, _, _)) =+  let km = if CmdInternal `elem` cats+           then K.KM K.NoModifier $ K.Unknown t+           else K.mkKM t+  in (km, triple) -macroShiftLeftButtonPress :: HumanCmd-macroShiftLeftButtonPress =-  Macro "run collectively to pointer for 100 steps"-        [ "ALT-space"-        , "SHIFT-MiddleButtonPress", "CTRL-colon"-        , "CTRL-period", "V" ]+addCmdCategory :: CmdCategory -> CmdTriple -> CmdTriple+addCmdCategory cat (cats, desc, cmd) = (cat : cats, desc, cmd)++replaceDesc :: Text -> CmdTriple -> CmdTriple+replaceDesc desc (cats, _, cmd) = (cats, desc, cmd)++replaceCmd :: HumanCmd -> CmdTriple -> CmdTriple+replaceCmd cmd (cats, desc, _) = (cats, desc, cmd)++moveItemTriple :: [CStore] -> CStore -> MU.Part -> Bool -> CmdTriple+moveItemTriple stores1 store2 object auto =+  let verb = MU.Text $ verbCStore store2+      desc = makePhrase [verb, object]+  in ([CmdItemMenu], desc, MoveItem stores1 store2 Nothing auto)++repeatTriple :: Int -> CmdTriple+repeatTriple n = ( [CmdMeta]+                 , "voice recorded commands" <+> tshow n <+> "times"+                 , Repeat n )++-- @AimFloor@ is not there, but @AimEnemy@ and @AimItem@ almost make up for it.+mouseLMB :: CmdTriple+mouseLMB =+  ( [CmdMouse]+  , "set x-hair to enemy/go to pointer for 25 steps"+  , ByAimMode+      { exploration = ByArea $ common ++  -- exploration mode+          [ (CaMapLeader, grabCmd)+          , (CaMapParty, PickLeaderWithPointer)+          , (CaMap, goToCmd)+          , (CaArenaName, Help)+          , (CaPercentSeen, autoexploreCmd) ]+      , aiming = ByArea $ common ++  -- aiming mode+          [ (CaMap, AimPointerEnemy)+          , (CaArenaName, Accept)+          , (CaPercentSeen, XhairStair True) ] } )+ where+  common =+    [ (CaMessage, Clear)+    , (CaLevelNumber, AimAscend 1)+    , (CaXhairDesc, AimEnemy)  -- inits aiming and then cycles enemies+    , (CaSelected, PickLeaderWithPointer)+    , (CaCalmGauge, Macro ["KP_5", "C-V"])+    , (CaHPGauge, Wait)+    , (CaTargetDesc, ChooseItemMenu $ MStore CInv) ]++mouseMMB :: CmdTriple+mouseMMB = ( [CmdMouse]+           , "snap x-hair to floor under pointer"+           , XhairPointerFloor )++mouseRMB :: CmdTriple+mouseRMB =+  ( [CmdMouse]+  , "fling at enemy/run to pointer collectively for 25 steps"+  , ByAimMode+      { exploration = ByArea $ common +++          [ (CaMapLeader, dropCmd)+          , (CaMapParty, SelectWithPointer)+          , (CaMap, runToAllCmd)+          , (CaArenaName, MainMenu)+          , (CaPercentSeen, autoexplore25Cmd)+          , (CaTargetDesc, projectICmd flingTs) ]+      , aiming = ByArea $ common +++          [ (CaMap, aimFlingCmd)+          , (CaArenaName, Cancel)+          , (CaPercentSeen, XhairStair False)+          , (CaTargetDesc, ComposeUnlessError ItemClear TgtClear) ] } )+ where+  common =+    [ (CaMessage, ChooseItemMenu MLoreItem)+    , (CaLevelNumber, AimAscend (-1))+    , (CaXhairDesc, AimItem)+    , (CaSelected, SelectWithPointer)+    , (CaCalmGauge, Macro ["C-KP_5", "V"])+    , (CaHPGauge, Wait10) ]++goToCmd :: HumanCmd+goToCmd = Macro ["MiddleButtonRelease", "C-semicolon", "C-/", "C-V"]++runToAllCmd :: HumanCmd+runToAllCmd = Macro ["MiddleButtonRelease", "C-colon", "C-/", "C-V"]++autoexploreCmd :: HumanCmd+autoexploreCmd = Macro ["C-?", "C-/", "C-V"]++autoexplore25Cmd :: HumanCmd+autoexplore25Cmd = Macro ["'", "C-?", "C-/", "'", "C-V"]++aimFlingCmd :: HumanCmd+aimFlingCmd = ComposeIfLocal AimPointerEnemy (projectICmd flingTs)++projectICmd :: [Trigger] -> HumanCmd+projectICmd ts = ByItemMode+  { ts+  , notChosen = ComposeUnlessError (ChooseItemProject ts) (Project ts)+  , chosen = Project ts }++projectI :: [Trigger] -> CmdTriple+projectI ts = ([], descTs ts, projectICmd ts)++projectA :: [Trigger] -> CmdTriple+projectA ts = replaceCmd ByAimMode { exploration = AimTgt+                                   , aiming = projectICmd ts } (projectI ts)++flingTs :: [Trigger]+flingTs = [ApplyItem { verb = "fling"+                     , object = "projectile"+                     , symbol = ' ' }]++applyIK :: [Trigger] -> CmdTriple+applyIK ts =+  let apply = Apply ts+  in ([], descTs ts, ByItemMode+       { ts+       , notChosen = ComposeUnlessError (ChooseItemApply ts) apply+       , chosen = apply })++applyI :: [Trigger] -> CmdTriple+applyI ts =+  let apply = Compose2ndLocal (Apply ts) ItemClear+  in ([], descTs ts, ByItemMode+       { ts+       , notChosen = ComposeUnlessError (ChooseItemApply ts) apply+       , chosen = apply })++grabCmd :: HumanCmd+grabCmd = MoveItem [CGround] CEqp (Just "grab") True+            -- @CEqp@ is the implicit default; refined in HandleHumanGlobalM++grabItems :: Text -> CmdTriple+grabItems t = ([CmdMove, CmdItemMenu], t, grabCmd)++dropCmd :: HumanCmd+dropCmd = MoveItem [CEqp, CInv, CSha] CGround Nothing False++dropItems :: Text -> CmdTriple+dropItems t = ([CmdMove, CmdItemMenu], t, dropCmd)++descTs :: [Trigger] -> Text+descTs [] = "trigger a thing"+descTs (t : _) = makePhrase [verb t, object t]++defaultHeroSelect :: Int -> (String, CmdTriple)+defaultHeroSelect k = ([Char.intToDigit k], ([CmdMeta], "", PickLeader k))

− Game/LambdaHack/Client/UI/DisplayAtomicClient.hs

@@ -1,926 +0,0 @@--- | Display atomic commands received by the client.-module Game.LambdaHack.Client.UI.DisplayAtomicClient-  ( displayRespUpdAtomicUI, displayRespSfxAtomicUI-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Maybe-import Data.Monoid-import Data.Tuple-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Atomic-import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.ItemSlot-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.Animation-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Client.UI.MsgClient-import Game.LambdaHack.Client.UI.WidgetClient-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Dice as Dice-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemDescription-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.State-import Game.LambdaHack.Common.Time-import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.RuleKind-import qualified Game.LambdaHack.Content.TileKind as TK---- * RespUpdAtomicUI---- TODO: let user configure which messages are not created, which are--- slightly hidden, which are shown and which flash and center screen--- and perhaps highligh the related location/actor. Perhaps even--- switch to the actor, changing HP displayed on screen, etc.--- but it's too short a clip to read the numbers, so probably--- highlighing should be enough.--- TODO: for a start, flesh out the verbose variant and then add--- a single client debug option that flips verbosity------ | Visualize atomic actions sent to the client. This is done--- in the global state after the command is executed and after--- the client state is modified by the command.-displayRespUpdAtomicUI :: MonadClientUI m-                       => Bool -> State -> StateClient -> UpdAtomic -> m ()-displayRespUpdAtomicUI verbose oldState oldStateClient cmd = case cmd of-  -- Create/destroy actors and items.-  UpdCreateActor aid body _ -> do-    side <- getsClient sside-    let verb = "appear" <+> if bfid body == side then "" else "suddenly"-    createActorUI aid body verbose (MU.Text verb)-  UpdDestroyActor aid body _ -> do-    destroyActorUI aid body "die" "be destroyed" verbose-    side <- getsClient sside-    when (bfid body == side && not (bproj body)) stopPlayBack-  UpdCreateItem iid _ kit c -> do-    case c of-      CActor aid store -> do-        l <- updateItemSlotSide store aid iid-        case store of-          COrgan -> do-            let verb =-                  MU.Text $ "become" <+> case fst kit of-                                           1 -> ""-                                           k -> tshow k <> "-fold"-            -- This describes all such items already among organs,-            -- which is useful, because it shows "charging".-            itemAidVerbMU aid verb iid (Left Nothing) COrgan-          _ -> do-            itemVerbMU iid kit (MU.Text $ "appear" <+> ppContainer c) c-            mleader <- getsClient _sleader-            when (Just aid == mleader) $-              modifyClient $ \cli -> cli { slastSlot = l-                                         , slastStore = store }-      CEmbed{} -> return ()-      CFloor{} -> do-        -- If you want an item to be assigned to @slastSlot@, create it-        -- in @CActor aid CGround@, not in @CFloor@.-        void $ updateItemSlot CGround Nothing iid-        itemVerbMU iid kit (MU.Text $ "appear" <+> ppContainer c) c-      CTrunk{} -> assert `failure` c-    stopPlayBack-  UpdDestroyItem iid _ kit c -> itemVerbMU iid kit "disappear" c-  UpdSpotActor aid body _ -> createActorUI aid body verbose "be spotted"-  UpdLoseActor aid body _ ->-    destroyActorUI aid body "be missing in action" "be lost" verbose-  UpdSpotItem iid _ kit c -> do-    (itemSlots, _) <- getsClient sslots-    case lookup iid $ map swap $ EM.assocs itemSlots of-      Nothing ->  -- never seen or would have a slot-        case c of-          CActor aid store ->-            -- Enemy actor fetching an item from shared stash, most probably.-            void $ updateItemSlotSide store aid iid-          CEmbed{} -> return ()-          CFloor lid p -> do-            void $ updateItemSlot CGround 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 kit "be spotted" c-            stopPlayBack-          CTrunk{} -> return ()-      _ -> return ()  -- seen already (has a slot assigned)-  UpdLoseItem{} -> return ()-  -- Move actors and items.-  UpdMoveActor aid source target -> moveActor oldState aid source target-  UpdWaitActor aid _ -> when verbose $ aidVerbMU aid "wait"-  UpdDisplaceActor source target -> displaceActorUI source target-  UpdMoveItem iid k aid c1 c2 -> moveItemUI iid k aid c1 c2-  -- Change actor attributes.-  UpdAgeActor{} -> return ()-  UpdRefillHP _ 0 -> return ()-  UpdRefillHP aid n -> do-    when verbose $-      aidVerbMU aid $ MU.Text $ (if n > 0 then "heal" else "lose")-                                <+> tshow (abs $ n `divUp` oneM) <> "HP"-    mleader <- getsClient _sleader-    when (Just aid == mleader) $ do-      b <- getsState $ getActorBody aid-      hpMax <- sumOrganEqpClient IK.EqpSlotAddMaxHP aid-      when (bhp b >= xM hpMax && hpMax > 0-            && resCurrentTurn (bhpDelta b) > 0) $ do-        actorVerbMU aid b "recover your health fully"-        stopPlayBack-  UpdRefillCalm aid calmDelta ->-    when (calmDelta == minusM) $ do  -- lower deltas come from hits; obvious-      side <- getsClient sside-      b <- getsState $ getActorBody aid-      when (bfid b == side) $ do-        fact <- getsState $ (EM.! bfid b) . sfactionD-        allFoes <- getsState $ actorRegularList (isAtWar fact) (blid b)-        let closeFoes = filter ((<= 3) . chessDist (bpos b) . bpos) allFoes-        when (null closeFoes) $ do  -- obvious where the feeling comes from-          aidVerbMU aid "hear something"-          msgDuplicateScrap-          stopPlayBack-  UpdFidImpressedActor aid _fidOld fidNew -> do-    b <- getsState $ getActorBody aid-    actorVerbMU aid b $-      if fidNew == bfid b then-        "get calmed and refocused"--- TODO: only show for liquids; for others say 'flash', etc.---              "get refocused by the fragrant moisture"-      else if fidNew == bfidOriginal b then-        "remember forgone allegiance suddenly"-      else-        "experience anxiety that weakens resolve and erodes loyalty"--- TODO     "inhale the sweet smell that weakens resolve and erodes loyalty"-  UpdTrajectory{} -> return ()-  UpdColorActor{} -> return ()-  -- Change faction attributes.-  UpdQuitFaction fid mbody _ toSt -> quitFactionUI fid mbody toSt-  UpdLeadFaction fid (Just (source, _)) (Just (target, _)) -> do-    side <- getsClient sside-    when (fid == side) $ do-      fact <- getsState $ (EM.! side) . sfactionD-      -- This faction can't run with multiple actors, so this is not-      -- a leader change while running, but rather server changing-      -- their leader, which the player should be alerted to.-      when (noRunWithMulti fact) stopPlayBack-      actorD <- getsState sactorD-      case EM.lookup source actorD of-        Just sb | bhp sb <= 0 -> assert (not $ bproj sb) $ do-          -- Regardless who the leader is, give proper names here, not 'you'.-          tb <- getsState $ getActorBody target-          let subject = partActor tb-              object  = partActor sb-          msgAdd $ makeSentence [ MU.SubjectVerbSg subject "take command"-                                , "from", object ]-        _ ->-          return ()-          -- TODO: report when server changes spawner's leader;-          -- perhaps don't switch _sleader in HandleAtomicClient,-          -- compare here and switch here? too hacky? fails for AI?-  UpdLeadFaction{} -> return ()-  UpdDiplFaction fid1 fid2 _ toDipl -> do-    name1 <- getsState $ gname . (EM.! fid1) . sfactionD-    name2 <- getsState $ gname . (EM.! fid2) . sfactionD-    let showDipl Unknown = "unknown to each other"-        showDipl Neutral = "in neutral diplomatic relations"-        showDipl Alliance = "allied"-        showDipl War = "at war"-    msgAdd $ name1 <+> "and" <+> name2 <+> "are now" <+> showDipl toDipl <> "."-  UpdTacticFaction{} -> return ()-  UpdAutoFaction fid b -> do-    side <- getsClient sside-    when (fid == side) $ setFrontAutoYes b-  UpdRecordKill{} -> return ()-  -- Alter map.-  UpdAlterTile{} -> when verbose $ return ()  -- TODO: door opens-  UpdAlterClear _ k -> msgAdd $ if k > 0-                                then "You hear grinding noises."-                                else "You hear fizzing noises."-  UpdSearchTile aid p fromTile toTile -> do-    Kind.COps{cotile = Kind.Ops{okind}} <- getsState scops-    b <- getsState $ getActorBody aid-    lvl <- getLevel $ blid b-    subject <- partAidLeader aid-    let t = lvl `at` p-        verb | t == toTile = "confirm"-             | otherwise = "reveal"-        subject2 = MU.Text $ TK.tname $ okind fromTile-        verb2 = "be"-    let msg = makeSentence [ MU.SubjectVerbSg subject verb-                           , "that the"-                           , MU.SubjectVerbSg subject2 verb2-                           , "a hidden"-                           , MU.Text $ TK.tname $ okind toTile ]-    msgAdd msg-  UpdLearnSecrets{} -> return ()-  UpdSpotTile{} -> return ()-  UpdLoseTile{} -> return ()-  UpdAlterSmell{} -> return ()-  UpdSpotSmell{} -> return ()-  UpdLoseSmell{} -> return ()-  -- Assorted.-  UpdTimeItem{} -> return ()-  UpdAgeGame{} -> return ()-  UpdDiscover c iid _ _ _ -> discover c oldStateClient iid-  UpdCover{} -> return ()  -- don't spam when doing undo-  UpdDiscoverKind c iid _ -> discover c oldStateClient iid-  UpdCoverKind{} -> return ()  -- don't spam when doing undo-  UpdDiscoverSeed c iid _ _ -> discover c oldStateClient iid-  UpdCoverSeed{} -> return ()  -- don't spam when doing undo-  UpdPerception{} -> return ()-  UpdRestart fid _ _ _ _ _ -> do-    void tryTakeMVarSescMVar  -- clear ESC-pressed from end of previous game-    mode <- getGameMode-    msgAdd $ "New game started in" <+> mname mode <+> "mode." <+> mdesc mode-    -- TODO: use a vertical animation instead, e.g., roll down,-    -- and reveal the first frame of a new game, not blank screen.-    history <- getsClient shistory-    when (lengthHistory history > 1) $ fadeOutOrIn False-    fact <- getsState $ (EM.! fid) . sfactionD-    setFrontAutoYes $ isAIFact fact-  UpdRestartServer{} -> return ()-  UpdResume fid _ -> do-    fact <- getsState $ (EM.! fid) . sfactionD-    setFrontAutoYes $ isAIFact fact-  UpdResumeServer{} -> return ()-  UpdKillExit{} -> return ()-  UpdWriteSave -> when verbose $ msgAdd "Saving backup."-  UpdMsgAll msg -> msgAdd msg-  UpdRecordHistory _ -> recordHistory--updateItemSlotSide :: MonadClient m-                   => CStore -> ActorId -> ItemId -> m SlotChar-updateItemSlotSide store aid iid = do-  side <- getsClient sside-  b <- getsState $ getActorBody aid-  if bfid b == side-  then updateItemSlot store (Just aid) iid-  else updateItemSlot store Nothing iid--lookAtMove :: MonadClientUI m => ActorId -> m ()-lookAtMove aid = do-  body <- getsState $ getActorBody aid-  side <- getsClient sside-  tgtMode <- getsClient stgtMode-  when (not (bproj body)-        && bfid body == side-        && isNothing tgtMode) $ do  -- targeting does a more extensive look-    lookMsg <- lookAt False "" True (bpos body) aid ""-    msgAdd lookMsg-  fact <- getsState $ (EM.! bfid body) . sfactionD-  if 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-    friends <- getsState $ actorRegularList (== side) (blid body)-    when (any (adjacent (bpos body) . bpos) friends) stopPlayBack---- | Sentences such as \"Dog barks loudly.\".-actorVerbMU :: MonadClientUI m => ActorId -> Actor -> MU.Part -> m ()-actorVerbMU aid b verb = do-  subject <- partActorLeader aid b-  msgAdd $ makeSentence [MU.SubjectVerbSg subject verb]--aidVerbMU :: MonadClientUI m => ActorId -> MU.Part -> m ()-aidVerbMU aid verb = do-  b <- getsState $ getActorBody aid-  actorVerbMU aid b verb--itemVerbMU :: MonadClientUI m-           => 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 (storeFromC c) localTime (itemToF iid kit)-      msg | k > 1 = makeSentence [MU.SubjectVerb MU.PlEtc MU.Yes subject verb]-          | otherwise = makeSentence [MU.SubjectVerbSg subject verb]-  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-  bag <- getsState $ getActorBag aid cstore-  -- The item may no longer be in @c@, but it was-  case iid `EM.lookup` bag of-    Nothing -> assert `failure` (aid, verb, iid, cstore)-    Just kit@(k, _) -> do-      itemToF <- itemToFullClient-      body <- getsState $ getActorBody aid-      let lid = blid body-      localTime <- getsState $ getLocalTime lid-      subject <- partAidLeader aid-      let itemFull = itemToF iid kit-          object = case ek of-            Left (Just n) ->-              assert (n <= k `blame` (aid, verb, iid, cstore))-              $ partItemWs n cstore localTime itemFull-            Left Nothing ->-              let (_, name, stats) = partItem cstore 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 cstore 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-  report <- getsClient sreport-  history <- getsClient shistory-  let (lastMsg, repRest) = lastMsgOfReport report-      lastDup = isJust . findInReport (== lastMsg)-      lastDuplicated = lastDup repRest-                       || maybe False lastDup (lastReportOfHistory history)-  when lastDuplicated $-    modifyClient $ \cli -> cli {sreport = repRest}---- TODO: "XXX spots YYY"? or blink or show the changed cursor?-createActorUI :: MonadClientUI m-              => ActorId -> Actor -> Bool -> MU.Part -> m ()-createActorUI aid body verbose verb = do-  mapM_ (\(iid, store) -> void $ updateItemSlotSide store aid iid)-        (getCarriedIidCStore body)-  side <- getsClient sside-  when (bfid body /= side) $ do-    fact <- getsState $ (EM.! bfid body) . sfactionD-    when (not (bproj body) && isAtWar fact side) $-      -- Target even if nobody can aim at the enemy. Let's home in on him-      -- and then we can aim or melee. We set permit to False, because it's-      -- technically very hard to check aimability here, because we are-      -- in-between turns and, e.g., leader's move has not yet been taken-      -- into account.-      modifyClient $ \cli -> cli {scursor = TEnemy aid False}-    stopPlayBack-  -- Don't spam if the actor was already visible (but, e.g., on a tile that is-  -- invisible this turn (in that case move is broken down to lose+spot)-  -- or on a distant tile, via teleport while the observer teleported, too).-  lastLost <- getsClient slastLost-  when (ES.notMember aid lastLost-        && (not (bproj body) || verbose)) $ do-    actorVerbMU aid body verb-    animFrs <- animate (blid body)-               $ actorX (bpos body) (bsymbol body) (bcolor body)-    displayActorStart body animFrs-  lookAtMove aid--destroyActorUI :: MonadClientUI m-               => ActorId -> Actor -> MU.Part -> MU.Part -> Bool -> m ()-destroyActorUI aid body verb verboseVerb verbose = do-  Kind.COps{corule} <- getsState scops-  side <- getsClient sside-  when (bfid body == side) $ do-    let upd = ES.delete aid-    modifyClient $ \cli -> cli {sselected = upd $ sselected cli}-  if bfid body == side && bhp body <= 0 && not (bproj body) then do-    when verbose $ actorVerbMU aid body verb-    let firstDeathEnds = rfirstDeathEnds $ Kind.stdRuleset corule-        fid = bfid body-    fact <- getsState $ (EM.! fid) . sfactionD-    actorsAlive <- anyActorsAlive fid (Just aid)-    -- TODO: deduplicate wrt Server-    -- TODO; actually show the --more- prompt, but not between fadeout frames-    unless (fneverEmpty (gplayer fact)-            && (not actorsAlive || firstDeathEnds)) $-      void $ displayMore ColorBW ""-  else when verbose $ actorVerbMU aid body verboseVerb-  -- If pushed, animate spotting again, to draw attention to pushing.-  when (isNothing $ btrajectory body) $-    modifyClient $ \cli -> cli {slastLost = ES.insert aid $ slastLost cli}---- TODO: deduplicate wrt Server-anyActorsAlive :: MonadClient m => FactionId -> Maybe ActorId -> m Bool-anyActorsAlive fid maid = do-  fact <- getsState $ (EM.! fid) . sfactionD-  if fleaderMode (gplayer fact) /= LeaderNull-    then return $! isJust $ gleader fact-    else do-      as <- getsState $ fidActorNotProjAssocs fid-      return $! not $ null $ maybe as (\aid -> filter ((/= aid) . fst) as) maid--moveActor :: MonadClientUI m => State -> ActorId -> Point -> Point -> m ()-moveActor oldState aid source target = do-  lookAtMove aid-  body <- getsState $ getActorBody aid-  when (bproj body) $ do-    let oldpos = case EM.lookup aid $ sactorD oldState of-          Nothing -> assert `failure` (sactorD oldState, aid)-          -- If no old position, default to current, which is then overwritten-          -- in the animation.-          Just b -> fromMaybe source $ boldpos b-    let ps = (oldpos, source, target)-    animFrs <- animate (blid body)-               $ moveProj ps (bsymbol body) (bcolor body)-    displayActorStart body animFrs--displaceActorUI :: MonadClientUI m => ActorId -> ActorId -> m ()-displaceActorUI source target = do-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  spart <- partActorLeader source sb-  tpart <- partActorLeader target tb-  let msg = makeSentence [MU.SubjectVerbSg spart "displace", tpart]-  msgAdd msg-  when (bfid sb /= bfid tb) $ do-    lookAtMove source-    lookAtMove target-  let ps = (bpos tb, bpos sb)-  animFrs <- animate (blid sb) $ swapPlaces ps-  displayActorStart sb animFrs--moveItemUI :: MonadClientUI m-           => ItemId -> Int -> ActorId -> CStore -> CStore-           -> m ()-moveItemUI iid k aid cstore1 cstore2 = do-  let verb = verbCStore cstore2-  b <- getsState $ getActorBody aid-  fact <- getsState $ (EM.! bfid b) . sfactionD-  let underAI = isAIFact fact-  mleader <- getsClient _sleader-  bag <- getsState $ getActorBag aid cstore2-  let kit@(n, _) = bag EM.! iid-  itemToF <- itemToFullClient-  (itemSlots, _) <- getsClient sslots-  case lookup iid $ map swap $ EM.assocs itemSlots of-    Just l -> do-      when (Just aid == mleader) $-        modifyClient $ \cli -> cli { slastSlot = l-                                   , slastStore = cstore2 }-      if cstore1 == CGround && Just aid == mleader && not underAI then do-        itemAidVerbMU aid (MU.Text verb) iid (Right k) cstore2-        localTime <- getsState $ getLocalTime (blid b)-        msgAdd $ makePhrase-                   [ "\n"-                   , slotLabel l-                   , "-"-                   , partItemWs n cstore2 localTime (itemToF iid kit)-                   , "\n" ]-      else when (not (bproj b) && bhp b > 0) $  -- don't announce death drops-        itemAidVerbMU aid (MU.Text verb) iid (Left $ Just k) cstore2-    Nothing -> assert `failure` (iid, itemToF iid kit)--quitFactionUI :: MonadClientUI m-              => FactionId -> Maybe Actor -> Maybe Status -> m ()-quitFactionUI fid mbody toSt = do-  Kind.COps{coitem=Kind.Ops{okind, ouniqGroup}} <- getsState scops-  fact <- getsState $ (EM.! fid) . sfactionD-  let fidName = MU.Text $ gname fact-      horror = isHorrorFact fact-  side <- getsClient sside-  let msgIfSide _ | fid /= side = Nothing-      msgIfSide s = Just s-      (startingPart, partingPart) = case toSt of-        _ | horror ->-          (Nothing, Nothing)  -- Ignore summoned actors' factions.-        Just Status{stOutcome=Killed} ->-          ( Just "be eliminated"-          , msgIfSide "Let's hope another party can save the day!" )-        Just Status{stOutcome=Defeated} ->-          ( Just "be decisively defeated"-          , msgIfSide "Let's hope your new overlords let you live." )-        Just Status{stOutcome=Camping} ->-          ( Just "order save and exit"-          , Just $ if fid == side-                   then "See you soon, stronger and braver!"-                   else "See you soon, stalwart warrior!" )-        Just Status{stOutcome=Conquer} ->-          ( Just "vanquish all foes"-          , msgIfSide "Can it be done in a better style, though?" )-        Just Status{stOutcome=Escape} ->-          ( Just "achieve victory"-          , msgIfSide "Can it be done better, though?" )-        Just Status{stOutcome=Restart, stNewGame=Just gn} ->-          ( Just $ MU.Text $ "order mission restart in" <+> tshow gn <+> "mode"-          , Just $ if fid == side-                   then "This time for real."-                   else "Somebody couldn't stand the heat." )-        Just Status{stOutcome=Restart, stNewGame=Nothing} ->-          assert `failure` (fid, mbody, toSt)-        Nothing ->-          (Nothing, Nothing)  -- Wipe out the quit flag for the savegame files.-  case startingPart of-    Nothing -> return ()-    Just sp -> do-      let msg = makeSentence [MU.SubjectVerbSg fidName sp]-      msgAdd msg-  case (toSt, partingPart) of-    (Just status, Just pp) -> do-      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-              io <- itemOverlay CGround (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 (mempty, 0)-          Just (aid, _) -> do-            b <- getsState $ getActorBody aid-            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-      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-         => Container -> StateClient -> ItemId -> m ()-discover c oldcli iid = do-  let cstore = storeFromC c-  lid <- getsState $ lidFromC c-  cops <- getsState scops-  localTime <- getsState $ getLocalTime lid-  itemToF <- itemToFullClient-  bag <- getsState $ getCBag c-  let kit = EM.findWithDefault (1, []) iid bag-      itemFull = itemToF iid kit-      knownName = partItemMediumAW cstore 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 cstore localTime itemSecret-      msg = makeSentence-        [ "the", MU.SubjectVerbSg (MU.Phrase [secretName, secretAEText])-                                  "turn out to be"-        , knownName ]-      oldItemFull =-        itemToFull cops (sdiscoKind oldcli) (sdiscoEffect oldcli)-                   iid (itemBase itemFull) (1, [])-  -- Compare descriptions of all aspects and effects to determine-  -- if the discovery was meaningful to the player.-  when (textAllAE 7 False cstore itemFull-        /= textAllAE 7 False cstore oldItemFull) $-    msgAdd msg---- * RespSfxAtomicUI---- | Display special effects (text, animation) sent to the client.-displayRespSfxAtomicUI :: MonadClientUI m => Bool -> SfxAtomic -> m ()-displayRespSfxAtomicUI verbose sfx = case sfx of-  SfxStrike source target iid cstore b -> strike source target iid cstore b-  SfxRecoil source target _ _ _ -> do-    spart <- partAidLeader source-    tpart <- partAidLeader target-    msgAdd $ makeSentence [MU.SubjectVerbSg spart "shrink away from", tpart]-  SfxProject aid iid cstore -> do-    setLastSlot aid iid cstore-    itemAidVerbMU aid "aim" iid (Left $ Just 1) cstore-  SfxCatch aid iid cstore ->-    itemAidVerbMU aid "catch" iid (Left $ Just 1) cstore-  SfxApply aid iid cstore -> do-    setLastSlot aid iid cstore-    itemAidVerbMU aid "apply" iid (Left $ Just 1) cstore-  SfxCheck aid iid cstore ->-    itemAidVerbMU aid "deapply" iid (Left $ Just 1) cstore-  SfxTrigger aid _p _feat ->-    when verbose $ aidVerbMU aid "trigger"  -- TODO: opens door, etc.-  SfxShun aid _p _ ->-    when verbose $ aidVerbMU aid "shun"  -- TODO: shuns stairs down-  SfxEffect fidSource aid effect -> do-    b <- getsState $ getActorBody aid-    side <- getsClient sside-    let fid = bfid b-    if bhp b <= 0 then do-      -- We assume the effect is the cause of incapacitation, but in case-      -- of projectile, to reduce spam, we verify with @canKill@.-      let firstFall | fid == side && bproj b = "fall apart"-                    | fid == side = "fall down"-                    | bproj b = "break up"-                    | otherwise = "collapse"-          hurtExtra | fid == side && bproj b = "be reduced to dust"-                    | fid == side = "be stomped flat"-                    | bproj b = "be shattered into little pieces"-                    | otherwise = "be reduced to a bloody pulp"-          -- Aspect bonuses ignored, so hurtExtra will add variety sometimes.-          deadPreviousTurn dp = bhp b <= dp-          harm2 dp = if deadPreviousTurn dp-                     then (True, Just hurtExtra)-                     else (False, Just firstFall)-          (deadBefore, mverbDie) =-            case effect of-              IK.Hurt p -> harm2 (- (xM $ Dice.maxDice p))-              IK.RefillHP p | p < 0 -> harm2 (xM p)-              IK.OverfillHP p | p < 0 -> harm2 (xM p)-              IK.Burn p -> harm2 (- (xM $ Dice.maxDice p))-              _ -> (False, Nothing)-      case mverbDie of-        Nothing -> return ()  -- only brutal effects work on dead/dying actor-        Just verbDie -> do-          subject <- partActorLeader aid b-          let msgDie = makeSentence [MU.SubjectVerbSg subject verbDie]-          msgAdd msgDie-          when (fid == side && not (bproj b)) $ do-            animDie <- if deadBefore-                       then animate (blid b)-                            $ twirlSplash (bpos b, bpos b) Color.Red Color.Red-                       else animate (blid b) $ deathBody $ bpos b-            displayActorStart b animDie-    else case effect of-        IK.NoEffect{} -> return ()-        IK.Hurt{} -> return ()  -- avoid spam; SfxStrike just sent-        IK.Burn{} -> do-          if fid == side then-            actorVerbMU aid b "feel burned"-          else-            actorVerbMU aid b "look burned"-          let ps = (bpos b, bpos b)-          animFrs <- animate (blid b) $ twirlSplash ps Color.BrRed Color.Red-          displayActorStart b animFrs-        IK.Explode{} -> return ()  -- lots of visual feedback-        IK.RefillHP p | p == 1 -> return ()  -- no spam from regeneration-        IK.RefillHP p | p > 0 -> do-          if fid == side then-            actorVerbMU aid b "feel healthier"-          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.RefillHP p | p == -1 -> return ()  -- no spam from poison-        IK.RefillHP _ -> do-          if fid == side then-            actorVerbMU aid b "feel wounded"-          else-            actorVerbMU aid b "look wounded"-          let ps = (bpos b, bpos b)-          animFrs <- animate (blid b) $ twirlSplash ps Color.BrRed Color.Red-          displayActorStart b animFrs-        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 -> return ()  -- 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-        IK.RefillCalm _ -> do-          if fid == side then-            actorVerbMU aid b "feel agitated"-          else-            actorVerbMU aid b "look agitated"-          let ps = (bpos b, bpos b)-          animFrs <- animate (blid b) $ twirlSplash ps Color.BrRed Color.Red-          displayActorStart b animFrs-        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  -- sometimes only a coincidence, but nm-              aidVerbMU aid $ MU.Text "yield, under extreme pressure"-            else if fid == side then-              aidVerbMU aid $ MU.Text "black out, dominated by foes"-            else-              aidVerbMU aid $ MU.Text "decide abrubtly to switch allegiance"-            fidName <- getsState $ gname . (EM.! fid) . sfactionD-            let verb = "be no longer controlled by"-            msgAdd $ makeSentence-              [MU.SubjectVerbSg subject verb, MU.Text fidName]-            when (fid == side) $ void $ displayMore ColorFull ""-          else do-            fidSourceName <- getsState $ gname . (EM.! fidSource) . sfactionD-            let verb = "be now under"-            msgAdd $ makeSentence-              [MU.SubjectVerbSg subject verb, MU.Text fidSourceName, "control"]-          stopPlayBack-        IK.Impress -> return ()-        IK.CallFriend{} -> do-          let verb = if bproj b then "attract" else "call forth"-          actorVerbMU aid b $ MU.Text $ verb <+> "friends"-        IK.Summon{} -> do  -- TODO: if a singleton, use the freq?-          let verb = if bproj b then "lure" else "summon"-          actorVerbMU aid b $ MU.Text $ verb <+> "nearby beasts"-        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{} -> return ()-        IK.Paralyze{} -> actorVerbMU aid b "be paralyzed"-        IK.InsertMove{} -> actorVerbMU aid b "act with extreme speed"-        IK.Teleport t | t > 9 -> actorVerbMU aid b "teleport"-        IK.Teleport{} -> actorVerbMU aid b "blink"-        IK.CreateItem{} -> return ()-        IK.DropItem COrgan _ True -> return ()-        IK.DropItem _ _ False -> actorVerbMU aid b "be stripped"  -- TODO-        IK.DropItem _ _ True -> actorVerbMU aid b "be violently stripped"-        IK.PolyItem -> do-          localTime <- getsState $ getLocalTime $ blid b-          allAssocs <- fullAssocsClient aid [CGround]-          case allAssocs of-            [] -> return ()  -- invisible items?-            (_, ItemFull{..}) : _ -> do-              subject <- partActorLeader aid b-              let itemSecret = itemNoDisco (itemBase, itemK)-                  -- TODO: plural form of secretName? only when K > 1?-                  -- At this point we don't easily know how many consumed.-                  (_, secretName, secretAEText) = partItem CGround localTime itemSecret-                  verb = "repurpose"-                  store = MU.Text $ ppCStoreIn CGround-              msgAdd $ makeSentence-                [ MU.SubjectVerbSg subject verb-                , "the", secretName, secretAEText, store ]-        IK.Identify -> do-          allAssocs <- fullAssocsClient aid [CGround]-          case allAssocs of-            [] -> return ()  -- invisible items?-            (_, ItemFull{..}) : _ -> do-              subject <- partActorLeader aid b-              let verb = "inspect"-                  store = MU.Text $ ppCStoreIn CGround-              msgAdd $ makeSentence-                [ MU.SubjectVerbSg subject verb-                , "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{} -> return ()-        IK.ApplyPerfume ->-          msgAdd "The fragrance quells all scents in the vicinity."-        IK.OneOf{} -> return ()-        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-    arena <- getArenaUI-    b <- getsState $ getActorBody aid---    activeItems <- activeItemsClient aid-    when (blid b == arena) $ do-      -- If time clip has passed since any actor advanced @timeCutOff@---TODO      -- or if the actor is so fast that he was capable of already moving---          -- this clip (for simplicity, we don't check if he actually did)-      -- or if the actor is newborn or is about to die,-      -- we end the frame early, before his current move.-      -- In the result, he moves at most once per frame, and thanks to this,-      -- his multiple moves are not collapsed into one frame.-      -- If the actor changes his speed this very clip, the test can faii,-      -- but it's rare and results in a minor UI issue, so we don't care.-      localTime <- getsState $ getLocalTime (blid b)-      timeCutOff <- getsClient $ EM.findWithDefault timeZero arena . sdisplayed-      when (localTime >= timeShift timeCutOff (Delta timeClip)---TODO            || btime b >= timeShiftFromSpeed b activeItems timeCutOff-            || actorNewBorn b-            || actorDying b) $ do-        -- If key will be requested, don't show the frame, because during-        -- the request extra message may be shown, so the other frame is better.-        mleader <- getsClient _sleader-        fact <- getsState $ (EM.! bfid b) . sfactionD-        let underAI = isAIFact fact-        unless (Just aid == mleader && not underAI) $ do-          -- Something new is gonna happen on this level (otherwise we'd send-          -- @UpdAgeLevel@ later on, with a larger time increment),-          -- so show crrent game state, before it changes.-          -- If considerable time passed, show delay. TODO: do this more-          -- accurately --- check if, eg., projectiles generated enough-          -- frames to cover the delay and if not, add here, too.-          -- Right now, if even one projectile flies, the whole 4-clip delay-          -- is skipped.-          let delta = localTime `timeDeltaToFrom` timeCutOff-          when (delta > Delta timeClip && not (bproj b))-            displayDelay-          let ageDisp = EM.insert arena localTime-          modifyClient $ \cli -> cli {sdisplayed = ageDisp $ sdisplayed cli}-          unless (bproj b) $  -- projectiles display animations instead-            displayPush ""--setLastSlot :: MonadClientUI m => ActorId -> ItemId -> CStore -> m ()-setLastSlot aid iid cstore = do-  mleader <- getsClient _sleader-  when (Just aid == mleader) $ do-    (itemSlots, _) <- getsClient sslots-    case lookup iid $ map swap $ EM.assocs itemSlots of-      Just l -> modifyClient $ \cli -> cli { slastSlot = l-                                           , slastStore = cstore }-      Nothing -> assert `failure` (iid, cstore, aid)--strike :: MonadClientUI m-       => ActorId -> ActorId -> ItemId -> CStore -> HitAtomic -> m ()-strike source target iid cstore hitStatus = assert (source /= target) $ do-  itemToF <- itemToFullClient-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  spart <- partActorLeader source sb-  tpart <- partActorLeader target tb-  spronoun <- partPronounLeader source sb-  localTime <- getsState $ getLocalTime (blid sb)-  bag <- getsState $ getActorBag source cstore-  let kit = EM.findWithDefault (1, []) iid bag-      itemFull = itemToF iid kit-      verb = case itemDisco itemFull of-        Nothing -> "hit"  -- not identified-        Just ItemDisco{itemKind} -> IK.iverbHit itemKind-      isOrgan = iid `EM.member` borgan sb-      partItemChoice =-        if isOrgan-        then partItemWownW spronoun COrgan localTime-        else partItemAW cstore localTime-      msg HitClear = makeSentence $-        [MU.SubjectVerbSg spart verb, tpart]-        ++ if bproj sb-           then []-           else ["with", partItemChoice itemFull]-      msg (HitBlock n) =-        -- This sounds funny when the victim falls down immediately,-        -- but there is no easy way to prevent that. And it's consistent.-        -- If/when death blow instead sets HP to 1 and only the next below 1,-        -- we can check here for HP==1; also perhaps actors with HP 1 should-        -- not be able to block.-        let sActs =-              if bproj sb-              then [ MU.SubjectVerbSg spart "connect" ]-              else [ MU.SubjectVerbSg spart "swing"-                   , partItemChoice itemFull ]-        in makeSentence [ MU.Phrase sActs <> ", but"-                        , MU.SubjectVerbSg tpart "block"-                        , if n > 1 then "doggedly" else "partly"-                        ]--- TODO: when other armor is in, etc.:---      msg HitSluggish =---        let adv = MU.Phrase ["sluggishly", verb]---        in makeSentence $ [MU.SubjectVerbSg spart adv, tpart]---                          ++ ["with", partItemChoice itemFull]-  msgAdd $ msg hitStatus-  let ps = (bpos tb, bpos sb)-      anim HitClear = twirlSplash ps Color.BrRed Color.Red-      anim (HitBlock 1) = blockHit ps Color.BrRed Color.Red-      anim (HitBlock _) = blockMiss ps-  animFrs <- animate (blid sb) $ anim hitStatus-  displayActorStart sb animFrs

+ Game/LambdaHack/Client/UI/DisplayAtomicM.hs view

@@ -0,0 +1,1185 @@+-- | Display atomic commands received by the client.+module Game.LambdaHack.Client.UI.DisplayAtomicM+  ( displayRespUpdAtomicUI, displayRespSfxAtomicUI+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.Char as Char+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.Map.Strict as M+import Data.Tuple+import GHC.Exts (inline)+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Atomic+import Game.LambdaHack.Client.CommonM+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Client.UI.ActorUI+import Game.LambdaHack.Client.UI.Animation+import Game.LambdaHack.Client.UI.Config+import Game.LambdaHack.Client.UI.FrameM+import Game.LambdaHack.Client.UI.HandleHelperM+import Game.LambdaHack.Client.UI.ItemDescription+import Game.LambdaHack.Client.UI.ItemSlot+import qualified Game.LambdaHack.Client.UI.Key as K+import Game.LambdaHack.Client.UI.MonadClientUI+import Game.LambdaHack.Client.UI.Msg+import Game.LambdaHack.Client.UI.MsgM+import Game.LambdaHack.Client.UI.Overlay+import Game.LambdaHack.Client.UI.OverlayM+import Game.LambdaHack.Client.UI.SessionUI+import Game.LambdaHack.Client.UI.Slideshow+import Game.LambdaHack.Client.UI.SlideshowM+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import qualified Game.LambdaHack.Common.Color as Color+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Flavour+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import qualified Game.LambdaHack.Content.ItemKind as IK+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Content.RuleKind+import qualified Game.LambdaHack.Content.TileKind as TK++-- * RespUpdAtomicUI++-- | Visualize atomic actions sent to the client. This is done+-- in the global state after the command is executed and after+-- the client state is modified by the command.+displayRespUpdAtomicUI :: MonadClientUI m+                       => Bool -> StateClient -> UpdAtomic -> m ()+{-# INLINE displayRespUpdAtomicUI #-}+displayRespUpdAtomicUI verbose oldCli cmd = case cmd of+  -- Create/destroy actors and items.+  UpdCreateActor aid body _ -> createActorUI True aid body+  UpdDestroyActor aid body _ -> destroyActorUI True aid body+  UpdCreateItem iid _ kit c -> do+    case c of+      CActor aid store -> do+        slastSlot <- updateItemSlotSide store aid iid+        case store of+          COrgan -> do+            bag <- getsState $ getContainerBag c+            let more = case EM.lookup iid bag of+                  Nothing -> False+                  Just kit2 -> fst kit2 /= fst kit+                verb = MU.Text $+                  "become" <+> case fst kit of+                                 1 -> if more then "more" else ""+                                 k -> if more then "additionally" else ""+                                      <+> tshow k <> "-fold"+            -- This describes all such items already among organs,+            -- which is useful, because it shows "charging".+            itemAidVerbMU aid verb iid (Left Nothing) COrgan+          _ -> do+            ownerFun <- partActorLeaderFun+            let wown = ppContainerWownW ownerFun True c+            itemVerbMU iid kit (MU.Text $ makePhrase $ "appear" : wown) c+            mleader <- getsClient _sleader+            when (Just aid == mleader) $+              modifySession $ \sess -> sess {slastSlot}+      CEmbed lid _ -> markDisplayNeeded lid+      CFloor lid _ -> do+        -- If you want an item to be assigned to @slastSlot@, create it+        -- in @CActor aid CGround@, not in @CFloor@.+        void $ updateItemSlot CGround Nothing iid+        itemVerbMU iid kit (MU.Text $ "appear" <+> ppContainer c) c+        markDisplayNeeded lid+      CTrunk{} -> assert `failure` c+    stopPlayBack+  UpdDestroyItem iid _ kit c -> do+    itemVerbMU iid kit "disappear" c+    lid <- getsState $ lidFromC c+    markDisplayNeeded lid+  UpdSpotActor aid body _ -> createActorUI False aid body+  UpdLoseActor aid body _ -> destroyActorUI False aid body+  UpdSpotItem verbose2 iid _ kit c -> do+    -- This is due to a move, or similar, which will be displayed,+    -- so no extra @markDisplayNeeded@ needed here and in similar places.+    ItemSlots itemSlots _ <- getsSession sslots+    case lookup iid $ map swap $ EM.assocs itemSlots of+      Nothing ->  -- never seen or would have a slot+        case c of+          CActor aid store ->+            -- Most probably an actor putting item in or out of shared stash.+            void $ updateItemSlotSide store aid iid+          CEmbed{} -> return ()+          CFloor lid p -> do+            void $ updateItemSlot CGround Nothing iid+            sxhairOld <- getsSession sxhair+            case sxhairOld of+              TEnemy{} -> return ()  -- probably too important to overwrite+              TPoint TEnemyPos{} _ _ -> return ()+              _ -> do+                -- Don't steal xhair if it's only an item on another level.+                -- For enemies, OTOH, capture xhair to alarm player.+                lidV <- viewedLevelUI+                when (lid == lidV) $ do+                  bag <- getsState $ getFloorBag lid p+                  modifySession $ \sess ->+                    sess {sxhair = TPoint (TItem bag) lidV p}+            itemVerbMU iid kit "be spotted" c+            stopPlayBack+          CTrunk{} -> return ()+      _ -> return ()  -- seen already (has a slot assigned)+    when verbose2 $ case c of+      CActor aid store | store `elem` [CEqp, CInv] -> do+        -- Actor fetching an item from shared stash, most probably.+        bUI <- getsSession $ getActorUI aid+        subject <- partActorLeader aid bUI+        let ownW = ppCStoreWownW False store subject+            verb = MU.Text $ makePhrase $ "be added to" : ownW+        itemVerbMU iid kit verb c+      _ -> return ()+  UpdLoseItem False _ _ _ _ -> return ()+  -- The message is rather cryptic, so let's disable it until it's decided+  -- if anemy inventories should be displayed, etc.+  {-+  UpdLoseItem True iid _ kit c@(CActor aid store) | store /= CSha -> do+    -- Actor putting an item into shared stash, most probably.+    side <- getsClient sside+    b <- getsState $ getActorBody aid+    subject <- partActorLeader aid b+    let ownW = ppCStoreWownW store subject+        verb = MU.Text $ makePhrase $ "be removed from" : ownW+    when (bfid b == side) $ itemVerbMU iid kit verb c+  -}+  UpdLoseItem{} -> return ()+  -- Move actors and items.+  UpdMoveActor aid source target -> moveActor aid source target+  UpdWaitActor aid _ -> when verbose $ aidVerbMU aid "wait"+  UpdDisplaceActor source target -> displaceActorUI source target+  UpdMoveItem iid k aid c1 c2 -> moveItemUI iid k aid c1 c2+  -- Change actor attributes.+  UpdRefillHP _ 0 -> return ()+  UpdRefillHP aid n -> do+    when verbose $+      aidVerbMU aid $ MU.Text $ (if n > 0 then "heal" else "lose")+                                <+> tshow (abs n `divUp` oneM) <> "HP"+    b <- getsState $ getActorBody aid+    bUI <- getsSession $ getActorUI aid+    arena <- getArenaUI+    side <- getsClient sside+    if | bproj b && (length (beqp b) == 0 || isNothing (btrajectory b)) ->+           return ()  -- ignore caught proj or one hitting a wall+       | bhp b <= 0 && n < 0+         && (bfid b == side && not (bproj b) || arena == blid b) -> do+         let (firstFall, hurtExtra) = case (bfid b == side, bproj b) of+               (True, True) -> ("drop down", "tumble down")+               (True, False) -> ("fall down", "fall to pieces")+               (False, True) -> ("plummet", "crash")+               (False, False) -> ("collapse", "be reduced to a bloody pulp")+             verbDie = if alreadyDeadBefore then hurtExtra else firstFall+             alreadyDeadBefore = bhp b - n <= 0+         subject <- partActorLeader aid bUI+         let msgDie = makeSentence [MU.SubjectVerbSg subject verbDie]+         msgAdd msgDie+         -- We show death anims only if not dead already before this refill.+         let deathAct | alreadyDeadBefore =+                        twirlSplash (bpos b, bpos b) Color.Red Color.Red+                      | bfid b == side = deathBody (bpos b)+                      | otherwise = shortDeathBody (bpos b)+         unless (bproj b) $ animate (blid b) deathAct+       | otherwise -> do+         when (n >= bhp b && bhp b > 0) $+           actorVerbMU aid bUI "return from the brink of death"+         mleader <- getsClient _sleader+         when (Just aid == mleader) $ do+           actorAspect <- getsClient sactorAspect+           let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect)+           when (bhp b >= xM (aMaxHP ar) && aMaxHP ar > 0 && n > 0) $ do+             actorVerbMU aid bUI "recover your health fully"+             stopPlayBack+  UpdRefillCalm aid calmDelta ->+    when (calmDelta == minusM) $ do  -- lower deltas come from hits; obvious+      side <- getsClient sside+      fact <- getsState $ (EM.! side) . sfactionD+      body <- getsState $ getActorBody aid+      when (bfid body == side) $ do+        let closeFoe b =  -- mimics isHeardFoe+                     blid b == blid body+                     && chessDist (bpos b) (bpos body) <= 3  -- a bit costly+                     && not (waitedLastTurn b)  -- uncommon+                     && inline isAtWar fact (bfid b)  -- costly+        anyCloseFoes <- getsState $ any closeFoe . EM.elems . sactorD+        unless anyCloseFoes $ do  -- obvious where the feeling comes from+          aidVerbMU aid "hear something"+          duplicated <- msgDuplicateScrap+          unless duplicated stopPlayBack+  UpdTrajectory{} -> return ()  -- if projectile dies here, no display+  -- Change faction attributes.+  UpdQuitFaction fid _ toSt -> quitFactionUI fid toSt+  UpdLeadFaction fid (Just source) (Just target) -> do+    side <- getsClient sside+    when (fid == side) $ do+      fact <- getsState $ (EM.! side) . sfactionD+      lidV <- viewedLevelUI+      when (isAIFact fact) $ markDisplayNeeded lidV+      -- This faction can't run with multiple actors, so this is not+      -- a leader change while running, but rather server changing+      -- their leader, which the player should be alerted to.+      when (noRunWithMulti fact) stopPlayBack+      actorD <- getsState sactorD+      case EM.lookup source actorD of+        Just sb | bhp sb <= 0 -> assert (not $ bproj sb) $ do+          -- Regardless who the leader is, give proper names here, not 'you'.+          sbUI <- getsSession $ getActorUI source+          tbUI <- getsSession $ getActorUI target+          let subject = partActor tbUI+              object  = partActor sbUI+          msgAdd $ makeSentence [ MU.SubjectVerbSg subject "take command"+                                , "from", object ]+        _ -> return ()+  UpdLeadFaction{} -> return ()+  UpdDiplFaction fid1 fid2 _ toDipl -> do+    name1 <- getsState $ gname . (EM.! fid1) . sfactionD+    name2 <- getsState $ gname . (EM.! fid2) . sfactionD+    let showDipl Unknown = "unknown to each other"+        showDipl Neutral = "in neutral diplomatic relations"+        showDipl Alliance = "allied"+        showDipl War = "at war"+    msgAdd $ name1 <+> "and" <+> name2 <+> "are now" <+> showDipl toDipl <> "."+  UpdTacticFaction{} -> return ()+  UpdAutoFaction fid b -> do+    side <- getsClient sside+    lidV <- viewedLevelUI+    markDisplayNeeded lidV+    when (fid == side) $ setFrontAutoYes b+  UpdRecordKill{} -> return ()+  -- Alter map.+  UpdAlterTile lid _ _ _ -> markDisplayNeeded lid+  UpdAlterClear{} -> return ()+  UpdSearchTile aid p toTile -> do+    Kind.COps{cotile = cotile@Kind.Ops{okind}} <- getsState scops+    b <- getsState $ getActorBody aid+    lvl <- getLevel $ blid b+    subject <- partAidLeader aid+    let t = lvl `at` p+        fromTile = Tile.hideAs cotile toTile+        verb | t == toTile = "confirm"+             | otherwise = "reveal"+        subject2 = MU.Text $ TK.tname $ okind fromTile+        verb2 = "be"+        object = MU.Text $ TK.tname $ okind toTile+    let msg = makeSentence [ MU.SubjectVerbSg subject verb+                           , "that the"+                           , MU.SubjectVerbSg subject2 verb2+                           , MU.AW object ]+    unless (subject2 == object) $ msgAdd msg+  UpdHideTile{} -> return ()+  UpdSpotTile{} -> return ()+  UpdLoseTile{} -> return ()+  UpdAlterSmell{} -> return ()+  UpdSpotSmell{} -> return ()+  UpdLoseSmell{} -> return ()+  -- Assorted.+  UpdTimeItem{} -> return ()+  UpdAgeGame{} -> do+    sdisplayNeeded <- getsSession sdisplayNeeded+    when sdisplayNeeded $ do+      -- Push the frame depicting the current level to the frame queue.+      -- Only one line of the report is shown, as in animations,+      -- because it may not be our turn, so we can't clear the message+      -- to see what is underneath.+      lidV <- viewedLevelUI+      report <- getReportUI+      let truncRep = [renderReport report]+      frame <- drawOverlay ColorFull False truncRep lidV+      displayFrames lidV [Just frame]+  UpdUnAgeGame{} -> return ()+  UpdDiscover c iid _ _ -> discover c oldCli iid+  UpdCover{} -> return ()  -- don't spam when doing undo+  UpdDiscoverKind c iid _ -> discover c oldCli iid+  UpdCoverKind{} -> return ()  -- don't spam when doing undo+  UpdDiscoverSeed c iid _ -> discover c oldCli iid+  UpdCoverSeed{} -> return ()  -- don't spam when doing undo+  UpdPerception{} -> return ()+  UpdRestart fid _ _ _ _ _ -> do+    sstart <- getsSession sstart+    when (sstart == 0) resetSessionStart+    history <- getsSession shistory+    when (lengthHistory history == 0) $ do+      Kind.COps{corule} <- getsState scops+      let title = rtitle $ Kind.stdRuleset corule+      msgAdd $ "Welcome to" <+> title <> "!"+      -- Generate initial history. Only for UI clients.+      sconfig <- getsSession sconfig+      shistory <- defaultHistory $ configHistoryMax sconfig+      modifySession $ \sess -> sess {shistory}+    mode <- getGameMode+    curChal <- getsClient scurChal+    fact <- getsState $ (EM.! fid) . sfactionD+    let loneMode = case ginitial fact of+          [] -> True+          [(_, 1, _)] -> True+          _ -> False+    msgAdd $ "New game started in" <+> mname mode <+> "mode." <+> mdesc mode+             <+> if cwolf curChal && not loneMode+                 then "Being a lone wolf, you start without companions."+                 else ""+    when (lengthHistory history > 1) $ fadeOutOrIn False+    setFrontAutoYes $ isAIFact fact+    when (isAIFact fact) $ do+      -- Prod the frontend to flush frames and start showing them continuously.+      slides <- reportToSlideshow []+      void $ getConfirms ColorFull [K.spaceKM, K.escKM] slides+  UpdRestartServer{} -> return ()+  UpdResume fid _ -> do+    resetSessionStart+    fact <- getsState $ (EM.! fid) . sfactionD+    setFrontAutoYes $ isAIFact fact+    unless (isAIFact fact) $ do+      mode <- getGameMode+      promptAdd $ mdesc mode <+> "Are you up for the challenge?"+      slides <- reportToSlideshow [K.spaceKM, K.escKM]+      km <- getConfirms ColorFull [K.spaceKM, K.escKM] slides+      if km == K.escKM then addPressedEsc else promptAdd "Prove yourself!"+  UpdResumeServer{} -> return ()+  UpdKillExit{} -> frontendShutdown+  UpdWriteSave -> when verbose $ promptAdd "Saving backup."+  UpdMsgAll "SortSlots" -> do  -- hack+    side <- getsClient sside+    sortSlots side Nothing+  UpdMsgAll msg -> msgAdd msg++updateItemSlot :: MonadClientUI m+               => CStore -> Maybe ActorId -> ItemId -> m SlotChar+updateItemSlot store maid iid = do+  slots@(ItemSlots itemSlots organSlots) <- getsSession sslots+  let onlyOrgans = store == COrgan+      lSlots = if onlyOrgans then organSlots else itemSlots+      incrementPrefix m l iid2 = EM.insert l iid2 $+        case EM.lookup l m of+          Nothing -> m+          Just iidOld ->+            let lNew = SlotChar (slotPrefix l + 1) (slotChar l)+            in incrementPrefix m lNew iidOld+  case lookup iid $ map swap $ EM.assocs lSlots of+    Nothing -> do+      side <- getsClient sside+      item <- getsState $ getItemBody iid+      lastSlot <- getsSession slastSlot+      mb <- maybe (return Nothing) (fmap Just . getsState . getActorBody) maid+      l <- getsState $ assignSlot store item side mb slots lastSlot+      let newSlots | onlyOrgans = ItemSlots+                                    itemSlots+                                    (incrementPrefix organSlots l iid)+                   | otherwise = ItemSlots+                                   (incrementPrefix itemSlots l iid)+                                   organSlots+      modifySession $ \sess -> sess {sslots = newSlots}+      return l+    Just l -> return l  -- slot already assigned; a letter or a number++markDisplayNeeded :: MonadClientUI m => LevelId -> m ()+markDisplayNeeded lid = do+  lidV <- viewedLevelUI+  when (lidV == lid) $+     modifySession $ \sess -> sess {sdisplayNeeded = True}++updateItemSlotSide :: MonadClientUI m+                   => CStore -> ActorId -> ItemId -> m SlotChar+updateItemSlotSide store aid iid = do+  side <- getsClient sside+  b <- getsState $ getActorBody aid+  if bfid b == side+  then updateItemSlot store (Just aid) iid+  else updateItemSlot store Nothing iid++lookAtMove :: MonadClientUI m => ActorId -> m ()+lookAtMove aid = do+  body <- getsState $ getActorBody aid+  side <- getsClient sside+  aimMode <- getsSession saimMode+  when (not (bproj body)+        && bfid body == side+        && isNothing aimMode) $ do  -- aiming does a more extensive look+    lookMsg <- lookAt False "" True (bpos body) aid ""+    msgAdd lookMsg+  fact <- getsState $ (EM.! bfid body) . sfactionD+  adjacentAssocs <- getsState $ actorAdjacentAssocs body+  if not (bproj body) && side == bfid body then do+    let foe (_, b2) = isAtWar fact (bfid b2)+        adjFoes = filter foe adjacentAssocs+    unless (null adjFoes) stopPlayBack+  else when (isAtWar fact side) $ do+    let our (_, b2) = not (bproj b2) && bfid b2 == side+        adjOur = filter our adjacentAssocs+    unless (null adjOur) stopPlayBack++-- | Sentences such as \"Dog barks loudly.\".+actorVerbMU :: MonadClientUI m => ActorId -> ActorUI -> MU.Part -> m ()+actorVerbMU aid bUI verb = do+  subject <- partActorLeader aid bUI+  msgAdd $ makeSentence [MU.SubjectVerbSg subject verb]++aidVerbMU :: MonadClientUI m => ActorId -> MU.Part -> m ()+aidVerbMU aid verb = do+  bUI <- getsSession $ getActorUI aid+  actorVerbMU aid bUI verb++itemVerbMU :: MonadClientUI m+           => 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+  side <- getsClient sside+  factionD <- getsState sfactionD+  let subject = partItemWs side factionD+                                k (storeFromC c) localTime (itemToF iid kit)+      msg | k > 1 = makeSentence [MU.SubjectVerb MU.PlEtc MU.Yes subject verb]+          | otherwise = makeSentence [MU.SubjectVerbSg subject verb]+  msgAdd msg++-- 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+  body <- getsState $ getActorBody aid+  bag <- getsState $ getBodyStoreBag body cstore+  side <- getsClient sside+  factionD <- getsState sfactionD+  -- 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+      let lid = blid body+      localTime <- getsState $ getLocalTime lid+      subject <- partAidLeader aid+      let itemFull = itemToF iid kit+          object = case ek of+            Left (Just n) ->+              assert (n <= k `blame` (aid, verb, iid, cstore))+              $ partItemWs side factionD n cstore localTime itemFull+            Left Nothing ->+              let (_, _, name, stats) =+                    partItem side factionD cstore 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 side factionD cstore 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 Bool+msgDuplicateScrap = do+  report <- getsSession _sreport+  history <- getsSession shistory+  let (lastMsg, repRest) = lastMsgOfReport report+      lastDup = isJust . findInReport (== lastMsg)+      lastDuplicated = lastDup repRest+                       || lastDup (lastReportOfHistory history)+  when lastDuplicated $+    modifySession $ \sess -> sess {_sreport = repRest}+  return lastDuplicated++createActorUI :: MonadClientUI m => Bool -> ActorId -> Actor -> m ()+createActorUI born aid body = do+  side <- getsClient sside+  fact <- getsState $ (EM.! bfid body) . sfactionD+  mbUI <- getsSession $ EM.lookup aid . sactorUI+  bUI <- case mbUI of+    Just bUI -> return bUI+    Nothing -> do+      trunk <- getsState $ getItemBody $ btrunk body+      Config{configHeroNames} <- getsSession sconfig+      let isBlast = jsymbol trunk `elem` ['`', '\'', '*']  -- good enough approx+          baseColor = flavourToColor $ jflavour trunk+          basePronoun | not (bproj body) && fhasGender (gplayer fact) = "he"+                      | otherwise = "it"+          nameFromNumber fn k = if k == 0+                                then makePhrase [MU.Ws $ MU.Text fn, "Captain"]+                                else fn <+> tshow k+          heroNamePronoun k =+            if gcolor fact /= Color.BrWhite+            then (nameFromNumber (fname $ gplayer fact) k, "he")+            else fromMaybe (nameFromNumber (fname $ gplayer fact) k, "he")+                 $ lookup k configHeroNames+      (n, bsymbol) <-+        if | bproj body -> return (0, if isBlast then jsymbol trunk else '*')+           | baseColor /= Color.BrWhite -> return (0, jsymbol trunk)+           | otherwise -> do+             sactorUI <- getsSession sactorUI+             let hasNameK k bUI = bname bUI == fst (heroNamePronoun k)+                                  && bcolor bUI == gcolor fact+                 findHeroK k = isJust $ find (hasNameK k) (EM.elems sactorUI)+                 mhs = map findHeroK [0..]+                 n = fromJust $ elemIndex False mhs+             return (n, if 0 < n && n < 10 then Char.intToDigit n else '@')+      factionD <- getsState sfactionD+      localTime <- getsState $ getLocalTime $ blid body+      let (bname, bpronoun) =+            if | bproj body ->+                 let adj | length (btrajectory body) < 5 = "falling"+                         | otherwise = "flying"+                     -- Not much detail about a fast flying item.+                     (_, _, object1, object2) =+                       partItem (bfid body) factionD CInv localTime+                                (itemNoDisco (trunk, 1))+                 in ( makePhrase [MU.AW $ MU.Text adj, object1, object2]+                    , basePronoun )+               | baseColor /= Color.BrWhite -> (jname trunk, basePronoun)+               | otherwise -> heroNamePronoun n+          bcolor | bproj body = if isBlast then baseColor else Color.BrWhite+                 | baseColor == Color.BrWhite = gcolor fact+                 | otherwise = baseColor+          bUI = ActorUI{..}+      modifySession $ \sess ->+        sess {sactorUI = EM.insert aid bUI $ sactorUI sess}+      return bUI+  let verb = if born+             then MU.Text $ "appear"+                            <+> if bfid body == side then "" else "suddenly"+             else "be spotted"+  mapM_ (\(iid, store) -> void $ updateItemSlotSide store aid iid)+        (getCarriedIidCStore body)+  when (bfid body /= side) $ do+    when (not (bproj body) && isAtWar fact side) $+      -- Aim even if nobody can shoot at the enemy. Let's home in on him+      -- and then we can aim or melee. We set permit to False, because it's+      -- technically very hard to check aimability here, because we are+      -- in-between turns and, e.g., leader's move has not yet been taken+      -- into account.+      modifySession $ \sess -> sess {sxhair = TEnemy aid False}+    stopPlayBack+  -- Don't spam if the actor was already visible (but, e.g., on a tile that is+  -- invisible this turn (in that case move is broken down to lose+spot)+  -- or on a distant tile, via teleport while the observer teleported, too).+  lastLost <- getsSession slastLost+  if ES.member aid lastLost || bproj body then+    markDisplayNeeded (blid body)+  else do+    actorVerbMU aid bUI verb+    animate (blid body) $ actorX (bpos body)+  lookAtMove aid++destroyActorUI :: MonadClientUI m => Bool -> ActorId -> Actor -> m ()+destroyActorUI destroy aid b = do+  trunk <- getsState $ getItemBody $ btrunk b+  let baseColor = flavourToColor $ jflavour trunk+  unless (baseColor == Color.BrWhite) $  -- keep setup for heroes, etc.+    modifySession $ \sess -> sess {sactorUI = EM.delete aid $ sactorUI sess}+  let affect tgt = case tgt of+        TEnemy a permit | a == aid ->+          if destroy then+            -- If *really* nothing more interesting, the actor will+            -- go to last known location to perhaps find other foes.+            TPoint TAny (blid b) (bpos b)+          else+            -- If enemy only hides (or we stepped behind obstacle) find him.+            TPoint (TEnemyPos a permit) (blid b) (bpos b)+        _ -> tgt+  modifySession $ \sess -> sess {sxhair = affect $ sxhair sess}+  when (isNothing $ btrajectory b) $+    modifySession $ \sess -> sess {slastLost = ES.insert aid $ slastLost sess}+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  let gameOver = isJust $ gquit fact  -- we are the UI faction, so we determine+  unless gameOver $ do+    when (bfid b == side && not (bproj b)) $ do+      stopPlayBack+      let upd = ES.delete aid+      modifySession $ \sess -> sess {sselected = upd $ sselected sess}+      when destroy $ do+        displayMore ColorBW "Alas!"+        mleader <- getsClient _sleader+        when (isJust mleader)+          -- This is especially handy when the dead actor was a leader+          -- on a different level than the new one:+          clearAimMode+    -- If pushed, animate spotting again, to draw attention to pushing.+    markDisplayNeeded (blid b)++moveActor :: MonadClientUI m => ActorId -> Point -> Point -> m ()+moveActor aid source target = do+  -- If source and target tile distant, assume it's a teleportation+  -- and display an animation. Note: jumps and pushes go through all+  -- intervening tiles, so won't be considered. Note: if source or target+  -- not seen, the (half of the) animation would be boring, just a delay,+  -- not really showing a transition, so we skip it (via 'breakUpdAtomic').+  -- The message about teleportation is sometimes shown anyway, just as the X.+  body <- getsState $ getActorBody aid+  if adjacent source target+  then markDisplayNeeded (blid body)+  else do+    let ps = (source, target)+    animate (blid body) $ teleport ps+  lookAtMove aid++displaceActorUI :: MonadClientUI m => ActorId -> ActorId -> m ()+displaceActorUI source target = do+  sb <- getsState $ getActorBody source+  sbUI <- getsSession $ getActorUI source+  tb <- getsState $ getActorBody target+  tbUI <- getsSession $ getActorUI target+  spart <- partActorLeader source sbUI+  tpart <- partActorLeader target tbUI+  let msg = makeSentence [MU.SubjectVerbSg spart "displace", tpart]+  msgAdd msg+  when (bfid sb /= bfid tb) $ do+    lookAtMove source+    lookAtMove target+  let ps = (bpos tb, bpos sb)+  animate (blid sb) $ swapPlaces ps++moveItemUI :: MonadClientUI m+           => ItemId -> Int -> ActorId -> CStore -> CStore+           -> m ()+moveItemUI iid k aid cstore1 cstore2 = do+  let verb = verbCStore cstore2+  b <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  let underAI = isAIFact fact+  mleader <- getsClient _sleader+  ItemSlots itemSlots _ <- getsSession sslots+  case lookup iid $ map swap $ EM.assocs itemSlots of+    Just slastSlot -> do+      when (Just aid == mleader) $ modifySession $ \sess -> sess {slastSlot}+      if cstore1 == CGround && Just aid == mleader && not underAI then+        itemAidVerbMU aid (MU.Text verb) iid (Right k) cstore2+      else when (not (bproj b) && bhp b > 0) $  -- don't announce death drops+        itemAidVerbMU aid (MU.Text verb) iid (Left $ Just k) cstore2+    Nothing -> assert `failure` (iid, k, aid, cstore1, cstore2, itemSlots)++quitFactionUI :: MonadClientUI m => FactionId -> Maybe Status -> m ()+quitFactionUI fid toSt = do+  Kind.COps{coitem=Kind.Ops{okind, ouniqGroup}} <- getsState scops+  fact <- getsState $ (EM.! fid) . sfactionD+  let fidName = MU.Text $ gname fact+      person = if fhasGender $ gplayer fact then MU.PlEtc else MU.Sg3rd+      horror = isHorrorFact fact+  side <- getsClient sside+  when (side == fid && maybe False ((/= Camping) . stOutcome) toSt) $ do+    let won = case toSt of+          Just Status{stOutcome=Conquer} -> True+          Just Status{stOutcome=Escape} -> True+          _ -> False+    when won $ do+      gameModeId <- getsState sgameModeId+      scurChal <- getsClient scurChal+      let sing = M.singleton scurChal 1+          f = M.unionWith (+)+          g = EM.insertWith f gameModeId sing+      modifyClient $ \cli -> cli {svictories = g $ svictories cli}+    tellGameClipPS+    resetGameStart+  let msgIfSide _ | fid /= side = Nothing+      msgIfSide s = Just s+      (startingPart, partingPart) = case toSt of+        _ | horror ->+          -- Ignore summoned actors' factions.+          (Nothing, Nothing)+        Just Status{stOutcome=Killed} ->+          ( Just "be eliminated"+          , msgIfSide "Let's hope another party can save the day!" )+        Just Status{stOutcome=Defeated} ->+          ( Just "be decisively defeated"+          , msgIfSide "Let's hope your new overlords let you live." )+        Just Status{stOutcome=Camping} ->+          ( Just "order save and exit"+          , Just $ if fid == side+                   then "See you soon, stronger and braver!"+                   else "See you soon, stalwart warrior!" )+        Just Status{stOutcome=Conquer} ->+          ( Just "vanquish all foes"+          , msgIfSide "Can it be done in a better style, though?" )+        Just Status{stOutcome=Escape} ->+          ( Just "achieve victory"+          , msgIfSide "Can it be done better, though?" )+        Just Status{stOutcome=Restart, stNewGame=Just gn} ->+          ( Just $ MU.Text $ "order mission restart in" <+> tshow gn <+> "mode"+          , Just $ if fid == side+                   then "This time for real."+                   else "Somebody couldn't stand the heat." )+        Just Status{stOutcome=Restart, stNewGame=Nothing} ->+          assert `failure` (fid, toSt)+        Nothing -> (Nothing, Nothing)  -- server wipes out Camping for savefile+  case startingPart of+    Nothing -> return ()+    Just sp -> msgAdd $ makeSentence [MU.SubjectVerb person MU.Yes fidName sp]+  case (toSt, partingPart) of+    (Just status, Just pp) -> do+      isNoConfirms <- isNoConfirmsGame+      go <- if isNoConfirms then return False else displaySpaceEsc ColorFull ""+      when (side == fid) recordHistory+        -- we are going to exit or restart, so record and clear, but only once+      when go $ do+        lidV <- viewedLevelUI+        Level{lxsize, lysize} <- getLevel lidV+        let store = CGround  -- only matters for UI details; all items shown+            currencyName = MU.Text $ IK.iname $ okind $ ouniqGroup "currency"+        arena <- getArenaUI+        (bag, itemSlides, total) <- do+          (bag, tot) <- getsState $ calculateTotal side+          if EM.null bag then return (EM.empty, emptySlideshow, 0)+          else do+            let spoilsMsg = makeSentence [ "Your spoils are worth"+                                         , MU.CarWs tot currencyName ]+            promptAdd spoilsMsg+            io <- itemOverlay store arena bag+            sli <- overlayToSlideshow (lysize + 1) [K.spaceKM, K.escKM] io+            return (bag, sli, tot)+        localTime <- getsState $ getLocalTime arena+        itemToF <- itemToFullClient+        ItemSlots lSlots _ <- getsSession sslots+        let keyOfEKM (Left km) = km+            keyOfEKM (Right SlotChar{slotChar}) = [K.mkChar slotChar]+            allOKX = concatMap snd $ slideshow itemSlides+            keys = [K.spaceKM, K.escKM] ++ concatMap (keyOfEKM . fst) allOKX+            examItem slot =+              case EM.lookup slot lSlots of+                Nothing -> assert `failure` slot+                Just iid -> case EM.lookup iid bag of+                  Nothing -> assert `failure` iid+                  Just kit@(k, _) -> do+                    factionD <- getsState sfactionD+                    let itemFull = itemToF iid kit+                        attrLine = itemDesc side factionD 0+                                            store localTime itemFull+                        ov = splitAttrLine lxsize attrLine+                        worth = itemPrice (itemBase itemFull, 1)+                        lootMsg = makeSentence $+                          ["This particular loot is worth"]+                          ++ (if k > 1 then [ MU.Cardinal k, "times"] else [])+                          ++ [MU.CarWs worth currencyName]+                    promptAdd lootMsg+                    slides <- overlayToSlideshow (lysize + 1)+                                                 [K.spaceKM, K.escKM]+                                                 (ov, [])+                    km <- getConfirms ColorFull [K.spaceKM, K.escKM] slides+                    return $! km == K.spaceKM+            viewItems pointer =+              if itemSlides == emptySlideshow then return True+              else do+                (ekm, pointer2) <- displayChoiceScreen ColorFull False pointer+                                                       itemSlides keys+                case ekm of+                  Left km | km == K.spaceKM -> return True+                  Left km | km == K.escKM -> return False+                  Left _ -> assert `failure` ekm+                  Right slot -> do+                    go2 <- examItem slot+                    if go2 then viewItems pointer2 else return True+        go3 <- viewItems 2+        when go3 $ do+          -- Show score for any UI client after any kind of game exit,+          -- even though it is saved only for human UI clients at game over.+          scoreSlides <- scoreToSlideshow total status+          void $ getConfirms ColorFull [K.spaceKM, K.escKM] scoreSlides+          -- The last prompt stays onscreen during shutdown, etc.+          promptAdd pp+          partingSlide <- reportToSlideshow [K.spaceKM, K.escKM]+          void $ getConfirms ColorFull [K.spaceKM, K.escKM] partingSlide+      unless (fmap stOutcome toSt == Just Camping) $+        fadeOutOrIn True+    _ -> return ()++discover :: MonadClientUI m => Container -> StateClient -> ItemId -> m ()+discover c oldCli iid = do+  let StateClient{sdiscoKind=oldDiscoKind, sdiscoAspect=oldDiscoAspect} = oldCli+      cstore = storeFromC c+  lid <- getsState $ lidFromC c+  discoKind <- getsClient sdiscoKind+  discoAspect <- getsClient sdiscoAspect+  localTime <- getsState $ getLocalTime lid+  itemToF <- itemToFullClient+  bag <- getsState $ getContainerBag c+  side <- getsClient sside+  factionD <- getsState sfactionD+  (isOurOrgan, nameWhere) <- case c of+    CActor aidOwner storeOwner -> do+      bOwner <- getsState $ getActorBody aidOwner+      bOwnerUI <- getsSession $ getActorUI aidOwner+      let name = if bproj bOwner || bfid bOwner == side+                 then []+                 else ppCStoreWownW True storeOwner (partActor bOwnerUI)+      return (bfid bOwner == side && storeOwner == COrgan, name)+    _ -> return (False, [])+  let kit = EM.findWithDefault (1, []) iid bag+      itemFull = itemToF iid kit+      knownName = partItemMediumAW side factionD cstore 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 side factionD cstore localTime itemSecret+      namePhrase = MU.Phrase $ [secretName, secretAEText] ++ nameWhere+      msg = makeSentence+        ["the", MU.SubjectVerbSg namePhrase "turn out to be", knownName]+      jix = jkindIx $ itemBase itemFull+      ik = itemKind $ fromJust $ itemDisco itemFull+  -- Compare descriptions of all aspects and effects to determine+  -- if the discovery was meaningful to the player.+  unless (isOurOrgan+          || (EM.member jix discoKind == EM.member jix oldDiscoKind+              && (EM.member iid discoAspect == EM.member iid oldDiscoAspect+                  || not (aspectsRandom ik)))) $+    msgAdd msg++-- * RespSfxAtomicUI++-- | Display special effects (text, animation) sent to the client.+displayRespSfxAtomicUI :: MonadClientUI m => Bool -> SfxAtomic -> m ()+{-# INLINE displayRespSfxAtomicUI #-}+displayRespSfxAtomicUI verbose sfx = case sfx of+  SfxStrike source target iid store ->+    strike False source target iid store+  SfxRecoil source target _ _ -> do+    spart <- partAidLeader source+    tpart <- partAidLeader target+    msgAdd $ makeSentence [MU.SubjectVerbSg spart "shrink away from", tpart]+  SfxSteal source target iid store ->+    strike True source target iid store+  SfxRelease source target _ _ -> do+    spart <- partAidLeader source+    tpart <- partAidLeader target+    msgAdd $ makeSentence [MU.SubjectVerbSg spart "release", tpart]+  SfxProject aid iid cstore -> do+    setLastSlot aid iid cstore+    itemAidVerbMU aid "fling" iid (Left $ Just 1) cstore+  SfxReceive aid iid cstore ->+    itemAidVerbMU aid "receive" iid (Left $ Just 1) cstore+  SfxApply aid iid cstore -> do+    setLastSlot aid iid cstore+    itemAidVerbMU aid "apply" iid (Left $ Just 1) cstore+  SfxCheck aid iid cstore ->+    itemAidVerbMU aid "deapply" iid (Left $ Just 1) cstore+  SfxTrigger aid _p ->+    -- So far triggering is visible, e.g., doors close, so no need for messages.+    when verbose $ aidVerbMU aid "trigger"+  SfxShun aid _p ->+    when verbose $ aidVerbMU aid "shun"+  SfxEffect fidSource aid effect hpDelta -> do+    b <- getsState $ getActorBody aid+    bUI <- getsSession $ getActorUI aid+    side <- getsClient sside+    let fid = bfid b+        isOurCharacter = fid == side && not (bproj b)+        isOurAlive = isOurCharacter && bhp b > 0+    case effect of+        IK.ELabel{} -> return ()+        IK.EqpSlot{} -> return ()+        IK.Burn{} -> do+          if isOurAlive+          then actorVerbMU aid bUI "feel burned"+          else actorVerbMU aid bUI "look burned"+          let ps = (bpos b, bpos b)+          animate (blid b) $ twirlSplash ps Color.BrRed Color.Red+        IK.Explode{} -> return ()  -- lots of visual feedback+        IK.RefillHP p | p == 1 -> return ()  -- no spam from regeneration+        IK.RefillHP p | p == -1 -> return ()  -- no spam from poison+        IK.RefillHP{} | hpDelta > 0 -> do+          if isOurAlive then+            actorVerbMU aid bUI "feel healthier"+          else+            actorVerbMU aid bUI "look healthier"+          let ps = (bpos b, bpos b)+          animate (blid b) $ twirlSplash ps Color.BrBlue Color.Blue+        IK.RefillHP{} -> do+          if isOurAlive then+            actorVerbMU aid bUI "feel wounded"+          else+            actorVerbMU aid bUI "look wounded"+          let ps = (bpos b, bpos b)+          animate (blid b) $ twirlSplash ps Color.BrRed Color.Red+        IK.RefillCalm p | p == 1 -> return ()  -- no spam from regen items+        IK.RefillCalm p | p > 0 ->+          if isOurAlive then+            actorVerbMU aid bUI "feel calmer"+          else+            actorVerbMU aid bUI "look calmer"+        IK.RefillCalm _ ->+          if isOurAlive then+            actorVerbMU aid bUI "feel agitated"+          else+            actorVerbMU aid bUI "look agitated"+        IK.Dominate -> do+          -- For subsequent messages use the proper name, never "you".+          let subject = partActor bUI+          if fid /= fidSource then do+            -- Before domination, possibly not seen if actor (yet) not ours.+            if | bcalm b == 0 ->  -- sometimes only a coincidence, but nm+                 aidVerbMU aid $ MU.Text "yield, under extreme pressure"+               | isOurAlive ->+                 aidVerbMU aid $ MU.Text "black out, dominated by foes"+               | otherwise ->+                 aidVerbMU aid $ MU.Text "decide abrubtly to switch allegiance"+            fidName <- getsState $ gname . (EM.! fid) . sfactionD+            let verb = "be no longer controlled by"+            msgAdd $ makeSentence+              [MU.SubjectVerbSg subject verb, MU.Text fidName]+            when isOurAlive $ displayMoreKeep ColorFull ""+          else do+            -- After domination, possibly not seen, if actor (already) not ours.+            fidSourceName <- getsState $ gname . (EM.! fidSource) . sfactionD+            let verb = "be now under"+            msgAdd $ makeSentence+              [MU.SubjectVerbSg subject verb, MU.Text fidSourceName, "control"]+          stopPlayBack+        IK.Impress -> actorVerbMU aid bUI $+          if fidSource == bfid b+          then "remember forgone allegiance suddenly"+          else "be awestruck"+        IK.Summon grp p -> do+          let verb = if bproj b then "lure" else "summon"+              object = if p == 1+                       then [MU.Text $ tshow grp]+                       else [MU.Ws $ MU.Text $ tshow grp]  -- avoid "1 + dl 3"+          actorVerbMU aid bUI $ MU.Phrase $ verb : object+        IK.Ascend True -> actorVerbMU aid bUI "find a way upstairs"+        IK.Ascend False -> actorVerbMU aid bUI "find a way downstairs"+        IK.Escape{} -> return ()+        IK.Paralyze{} -> actorVerbMU aid bUI "be paralyzed"+        IK.InsertMove{} -> actorVerbMU aid bUI "act with extreme speed"+        IK.Teleport t | t <= 8 -> actorVerbMU aid bUI "blink"+        IK.Teleport{} -> actorVerbMU aid bUI "teleport"+        IK.CreateItem{} -> return ()+        IK.DropItem _ _ COrgan _ -> return ()+        IK.DropItem{} -> actorVerbMU aid bUI "be stripped"+        IK.PolyItem -> do+          localTime <- getsState $ getLocalTime $ blid b+          allAssocs <- fullAssocsClient aid [CGround]+          case allAssocs of+            [] -> return ()  -- invisible items?+            (_, ItemFull{..}) : _ -> do+              subject <- partActorLeader aid bUI+              factionD <- getsState sfactionD+              let itemSecret = itemNoDisco (itemBase, itemK)+                  (_, _, secretName, secretAEText) =+                    partItem side factionD CGround localTime itemSecret+                  verb = "repurpose"+                  store = MU.Text $ ppCStoreIn CGround+              msgAdd $ makeSentence+                [ MU.SubjectVerbSg subject verb+                , "the", secretName, secretAEText, store ]+        IK.Identify -> do+          allAssocs <- fullAssocsClient aid [CGround]+          case allAssocs of+            [] -> return ()  -- invisible items?+            (_, ItemFull{..}) : _ -> do+              subject <- partActorLeader aid bUI+              let verb = "inspect"+                  store = MU.Text $ ppCStoreIn CGround+              msgAdd $ makeSentence+                [ MU.SubjectVerbSg subject verb+                , "an item", store ]+        IK.Detect{} -> do+          subject <- partActorLeader aid bUI+          let verb = "perceive nearby area"+          displayMore ColorFull $ makeSentence [MU.SubjectVerbSg subject verb]+        IK.DetectActor{} -> do+          subject <- partActorLeader aid bUI+          let verb = "detect nearby actors"+          displayMore ColorFull $ makeSentence [MU.SubjectVerbSg subject verb]+        IK.DetectItem{} -> do+          subject <- partActorLeader aid bUI+          let verb = "detect nearby items"+          displayMore ColorFull $ makeSentence [MU.SubjectVerbSg subject verb]+        IK.DetectExit{} -> do+          subject <- partActorLeader aid bUI+          let verb = "detect nearby exits"+          displayMore ColorFull $ makeSentence [MU.SubjectVerbSg subject verb]+        IK.DetectHidden{} -> do+          subject <- partActorLeader aid bUI+          let verb = "detect nearby secrets"+          displayMore ColorFull $ makeSentence [MU.SubjectVerbSg subject verb]+        IK.SendFlying{} -> actorVerbMU aid bUI "be sent flying"+        IK.PushActor{} -> actorVerbMU aid bUI "be pushed"+        IK.PullActor{} -> actorVerbMU aid bUI "be pulled"+        IK.DropBestWeapon -> actorVerbMU aid bUI "be disarmed"+        IK.ActivateInv{} -> return ()+        IK.ApplyPerfume ->+          msgAdd "The fragrance quells all scents in the vicinity."+        IK.OneOf{} -> return ()+        IK.OnSmash{} -> assert `failure` sfx+        IK.Recharging{} -> assert `failure` sfx+        IK.Temporary t -> actorVerbMU aid bUI $ MU.Text t+        IK.Unique -> assert `failure` sfx+        IK.Periodic -> assert `failure` sfx+  SfxMsgFid _ sfxMsg -> do+    mleader <- getsClient _sleader+    case mleader of+      Just{} -> return ()  -- will display stuff when leader moves+      Nothing -> do+        lidV <- viewedLevelUI+        markDisplayNeeded lidV+        recordHistory+    msg <- ppSfxMsg sfxMsg+    msgAdd msg++ppSfxMsg :: MonadClientUI m => SfxMsg -> m Text+ppSfxMsg sfxMsg = case sfxMsg of+  SfxUnexpected reqFailure -> return $!+    "Unexpected problem:" <+> showReqFailure reqFailure <> "."+  SfxLoudUpd local cmd -> do+    Kind.COps{coTileSpeedup} <- getsState scops+    let sound = case cmd of+          UpdDestroyActor{} -> "shriek"+          UpdCreateItem{} -> "clatter"+          UpdTrajectory{} ->+            -- Projectile hits an non-walkable tile on leader's level.+            "thud"+          UpdAlterTile _ _ fromTile _ ->+            if Tile.isDoor coTileSpeedup fromTile+            then "creaking sound"+            else "rumble"+          UpdAlterClear _ k -> if k > 0 then "grinding noise"+                                        else "fizzing noise"+          _ -> assert `failure` cmd+        distant = if local then [] else ["distant"]+        msg = makeSentence [ "you hear"+                           , MU.AW $ MU.Phrase $ distant ++ [sound] ]+    return $! msg+  SfxLoudStrike local ik distance -> do+    Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops+    let verb = IK.iverbHit $ okind ik+        adverb = if | distance < 5 -> "loudly"+                    | distance < 10 -> "distinctly"+                    | distance < 40 -> ""  -- most common+                    | distance < 45 -> "faintly"+                    | otherwise -> "barely"  -- 50 is the hearing limit+        distant = if local then [] else ["far away"]+        msg = makeSentence $+          [ "you", adverb, "hear something", verb, "someone"] ++ distant+    return $! msg+  SfxFizzles -> return "It flashes and fizzles."+  SfxVoidDetection -> return "Nothing new detected."+  SfxSummonLackCalm aid -> do+    msbUI <- getsSession $ EM.lookup aid . sactorUI+    case msbUI of+      Nothing -> return ""+      Just sbUI -> do+        let subject = partActor sbUI+            verb = "lack Calm to summon"+        return $! makeSentence [MU.SubjectVerbSg subject verb]+  SfxLevelNoMore -> return "No more levels in this direction."+  SfxLevelPushed -> return "You notice somebody pushed to another level."+  SfxBracedImmune aid -> do+    msbUI <- getsSession $ EM.lookup aid . sactorUI+    case msbUI of+      Nothing -> return ""+      Just sbUI -> do+        let subject = partActor sbUI+            verb = "be braced and so immune to translocation"+        return $! makeSentence [MU.SubjectVerbSg subject verb]+  SfxEscapeImpossible -> return "This faction doesn't want to escape outside."+  SfxTransImpossible -> return "Translocation not possible."+  SfxIdentifyNothing store -> return $!+    "Nothing to identify" <+> ppCStoreIn store <> "."+  SfxPurposeNothing store -> return $!+    "The purpose of repurpose cannot be availed without an item"+    <+> ppCStoreIn store <> "."+  SfxPurposeTooFew maxCount itemK -> return $!+    "The purpose of repurpose is served by" <+> tshow maxCount+    <+> "pieces of this item, not by" <+> tshow itemK <> "."+  SfxPurposeUnique -> return "Unique items can't be repurposed."+  SfxColdFish -> return "Healing attempt from another faction is thwarted by your cold fish attitude."++setLastSlot :: MonadClientUI m => ActorId -> ItemId -> CStore -> m ()+setLastSlot aid iid cstore = do+  mleader <- getsClient _sleader+  when (Just aid == mleader) $ do+    ItemSlots itemSlots _ <- getsSession sslots+    case lookup iid $ map swap $ EM.assocs itemSlots of+      Just slastSlot -> modifySession $ \sess -> sess {slastSlot}+      Nothing -> assert `failure` (iid, cstore, aid)++strike :: MonadClientUI m+       => Bool -> ActorId -> ActorId -> ItemId -> CStore -> m ()+strike catch source target iid cstore = assert (source /= target) $ do+  actorAspect <- getsClient sactorAspect+  tb <- getsState $ getActorBody target+  tbUI <- getsSession $ getActorUI target+  sourceSeen <- getsState $ memActor source (blid tb)+  (ps, hurtMult) <-+   if sourceSeen then do+    hurtMult <- getsState $ armorHurtBonus actorAspect source target+    itemToF <- itemToFullClient+    sb <- getsState $ getActorBody source+    sbUI <- getsSession $ getActorUI source+    spart <- partActorLeader source sbUI+    tpart <- partActorLeader target tbUI+    spronoun <- partPronounLeader source sbUI+    localTime <- getsState $ getLocalTime (blid tb)+    bag <- getsState $ getBodyStoreBag sb cstore+    side <- getsClient sside+    factionD <- getsState sfactionD+    let kit = EM.findWithDefault (1, []) iid bag+        itemFull = itemToF iid kit+        verb = case itemDisco itemFull of+          _ | catch -> "catch"+          Nothing -> "hit"  -- not identified+          Just ItemDisco{itemKind} -> IK.iverbHit itemKind+        isOrgan = iid `EM.member` borgan sb+        partItemChoice =+          if isOrgan+          then partItemShortWownW side factionD spronoun COrgan localTime+          else partItemShortAW side factionD cstore localTime+        msg | bhp tb <= 0 || hurtMult > 90 = makeSentence $  -- minor armor+              [MU.SubjectVerbSg spart verb, tpart]+              ++ if bproj sb+                 then []+                 else ["with", partItemChoice itemFull]+            | otherwise =+          -- This sounds funny when the victim falls down immediately,+          -- but there is no easy way to prevent that. And it's consistent.+          -- If/when death blow instead sets HP to 1 and only the next below 1,+          -- we can check here for HP==1; also perhaps actors with HP 1 should+          -- not be able to block.+          let sActs = if bproj sb+                      then [ MU.SubjectVerbSg spart "connect" ]+                      else [ MU.SubjectVerbSg spart verb, tpart+                           , "with", partItemChoice itemFull ]+              actionPhrase =+                MU.SubjectVerbSg tpart+                $ if bproj sb+                  then if braced tb+                       then "deflect it"+                       else "fend it off"  -- ward it off+                  else if braced tb+                       then "block"  -- parry+                       else "dodge"  -- evade+              butEvenThough = if catch then ", even though" else ", but"+          in makeSentence+               [ MU.Phrase sActs <> butEvenThough+               , actionPhrase+               , if | hurtMult >= 50 ->  -- braced or big bonuses+                      "partly"+                    | hurtMult > 1 ->  -- braced and/or huge bonuses+                      if braced tb then "doggedly" else "nonchalantly"+                    | otherwise ->         -- 1% got through, which can+                      "almost completely"  -- still be deadly, if fast missile+               ]+    msgAdd msg+    return ((bpos tb, bpos sb), hurtMult)+   else return ((bpos tb, bpos tb), 100)+  let anim | hurtMult > 90 = twirlSplash ps Color.BrRed Color.Red+           | hurtMult > 1 = blockHit ps Color.BrRed Color.Red+           | otherwise = blockMiss ps+  animate (blid tb) anim

− Game/LambdaHack/Client/UI/DrawClient.hs

@@ -1,391 +0,0 @@--- | Display game data on the screen using one of the available frontends--- (determined at compile time with cabal flags).-module Game.LambdaHack.Client.UI.DrawClient-  ( ColorMode(..)-  , draw-  ) where--import Control.Exception.Assert.Sugar-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.List-import Data.Maybe-import Data.Ord-import Data.Text (Text)-import qualified Data.Text as T--import Game.LambdaHack.Client.Bfs-import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.Animation-import qualified Game.LambdaHack.Common.Ability as Ability-import Game.LambdaHack.Common.Actor as Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Dice as Dice-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemDescription-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.ModeKind-import qualified Game.LambdaHack.Content.TileKind as TK---- | Color mode for the display.-data ColorMode =-    ColorFull  -- ^ normal, with full colours-  | ColorBW    -- ^ black+white only---- TODO: split up and generally rewrite.--- | Draw the whole screen: level map and status area.--- Pass at most a single page if overlay of text unchanged--- to the frontends to display separately or overlay over map,--- depending on the frontend.-draw :: MonadClient m-     => ColorMode -> LevelId-     -> Maybe Point -> Maybe Point-     -> Maybe (PointArray.Array BfsDistance, Maybe [Point])-     -> (Text, Maybe Text) -> (Text, Maybe Text) -> Overlay-     -> m SingleFrame-draw dm drawnLevelId cursorPos tgtPos bfsmpathRaw-     (cursorDesc, mcursorHP) (targetDesc, mtargetHP) sfTop = do-  cops <- getsState scops-  mleader <- getsClient _sleader-  s <- getState-  cli@StateClient{ stgtMode, seps, sexplored-                 , smarkVision, smarkSmell, smarkSuspect, swaitTimes }-    <- getClient-  per <- getPerFid drawnLevelId-  let Kind.COps{cotile=cotile@Kind.Ops{okind=tokind, ouniqGroup}} = cops-      (lvl@Level{lxsize, lysize, lsmell, ltime}) = sdungeon s EM.! drawnLevelId-      (bl, mblid, mbpos) = case (cursorPos, mleader) of-        (Just cursor, Just leader) ->-          let Actor{bpos, blid} = getActorBody leader s-          in if blid /= drawnLevelId-             then ( [cursor], Just blid, Just bpos )-             else ( fromMaybe [] $ bla lxsize lysize seps bpos cursor-                  , Just blid-                  , Just bpos )-        _ -> ([], Nothing, Nothing)-      mpath = maybe Nothing (\(_, mp) -> if null bl-                                            || mblid /= Just drawnLevelId-                                         then Nothing-                                         else mp) bfsmpathRaw-      actorsHere = actorAssocs (const True) drawnLevelId s-      cursorHere = find (\(_, m) -> cursorPos == Just (Actor.bpos m))-                   actorsHere-      shiftedBTrajectory = case cursorHere of-        Just (_, Actor{btrajectory = Just p, bpos = prPos}) ->-          trajectoryToPath prPos (fst p)-        _ -> []-      unknownId = ouniqGroup "unknown space"-      dis pos0 =-        let tile = lvl `at` pos0-            tk = tokind tile-            floorBag = EM.findWithDefault EM.empty pos0 $ lfloor lvl-            (itemSlots, _) = sslots cli-            bagItemSlots = EM.filter (`EM.member` floorBag) itemSlots-            floorIids = EM.elems bagItemSlots  -- first slot will be shown-            sml = EM.findWithDefault timeZero pos0 lsmell-            smlt = sml `timeDeltaToFrom` ltime-            viewActor aid Actor{bsymbol, bcolor, bhp, bproj}-              | Just aid == mleader = (symbol, inverseVideo)-              | otherwise = (symbol, Color.defAttr {Color.fg = bcolor})-             where-              symbol | bhp <= 0 && not bproj = '%'-                     | otherwise = bsymbol-            rainbow p = Color.defAttr {Color.fg =-                                         toEnum $ fromEnum p `rem` 14 + 1}-            -- smarkSuspect is an optional overlay, so let's overlay it-            -- over both visible and invisible tiles.-            vcolor-              | smarkSuspect && Tile.isSuspect cotile tile = Color.BrCyan-              | vis = 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-              (True, True)   -> Color.BrGreen-              (True, False)  -> Color.BrRed-              (False, True)  -> Color.Green-              (False, False) -> Color.Red-            atttrOnPathOrLine = if Just pos0 == cursorPos-                                then inverseVideo {Color.fg = fgOnPathOrLine}-                                else Color.defAttr {Color.fg = fgOnPathOrLine}-            (char, attr0) =-              case find (\(_, m) -> pos0 == Actor.bpos m) actorsHere of-                _ | isJust stgtMode-                    && (elem pos0 bl || elem pos0 shiftedBTrajectory) ->-                  ('*', atttrOnPathOrLine)  -- line takes precedence over path-                _ | isJust stgtMode-                    && maybe False (elem pos0) mpath ->-                  (';', Color.defAttr {Color.fg = fgOnPathOrLine})-                Just (aid, m) -> viewActor aid m-                _ | smarkSmell && sml > ltime ->-                  (timeDeltaToDigit smellTimeout smlt, rainbow pos0)-                  | otherwise ->-                  case floorIids of-                    [] -> (TK.tsymbol tk, Color.defAttr {Color.fg = vcolor})-                    iid : _ -> viewItem $ getItemBody iid s-            vis = ES.member pos0 $ totalVisible per-            a = case dm of-                  ColorBW -> Color.defAttr-                  ColorFull -> if smarkVision && vis-                               then attr0 {Color.bg = Color.Blue}-                               else attr0-        in Color.AttrChar a char-      widthX = 80-      widthTgt = 39-      widthStats = widthX - widthTgt-      addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)-      arenaStatus = drawArenaStatus (ES.member drawnLevelId sexplored) lvl-                                    widthStats-      displayPathText mp mt =-        let (plen, llen) = case (mp, bfsmpathRaw, mbpos) of-              (Just target, Just (bfs, _), Just bpos)-                | mblid == Just drawnLevelId ->-                  (fromMaybe 0 (accessBfs bfs target), chessDist bpos target)-              _ -> (0, 0)-            pText | plen == 0 = ""-                  | otherwise = "p" <> tshow plen-            lText | llen == 0 = ""-                  | otherwise = "l" <> tshow llen-            text = fromMaybe (pText <+> lText) mt-        in if T.null text then "" else " " <> text-      -- The indicators must fit, they are the actual information.-      pathCsr = displayPathText cursorPos mcursorHP-      trimTgtDesc n t = assert (not (T.null t) && n > 2) $-        if T.length t <= n then t-        else let ellipsis = "..."-                 fitsPlusOne = T.take (n - T.length ellipsis + 1) t-                 fits = if T.last fitsPlusOne == ' '-                        then T.init fitsPlusOne-                        else let lw = T.words fitsPlusOne-                             in T.unwords $ init lw-             in fits <> ellipsis-      cursorText =-        let n = widthTgt - T.length pathCsr - 8-        in (if isJust stgtMode then "x-hair>" else "X-hair:")-           <+> trimTgtDesc n cursorDesc-      cursorGap = T.replicate (widthTgt - T.length pathCsr-                                        - T.length cursorText) " "-      cursorStatus = addAttr $ cursorText <> cursorGap <> pathCsr-      minLeaderStatusWidth = 19  -- covers 3-digit HP-  selectedStatus <- drawSelected drawnLevelId-                                 (widthStats - minLeaderStatusWidth)-  leaderStatus <- drawLeaderStatus swaitTimes-                                   (widthStats - length selectedStatus)-  damageStatus <- drawLeaderDamage (widthStats - length leaderStatus-                                               - length selectedStatus)-  nameStatus <- drawPlayerName (widthStats - length leaderStatus-                                           - length selectedStatus-                                           - length damageStatus)-  let statusGap = addAttr $ T.replicate (widthStats - length leaderStatus-                                                    - length selectedStatus-                                                    - length damageStatus-                                                    - length nameStatus) " "-      -- The indicators must fit, they are the actual information.-      pathTgt = displayPathText tgtPos mtargetHP-      targetText =-        let n = widthTgt - T.length pathTgt - 8-        in "Target:" <+> trimTgtDesc n targetDesc-      targetGap = T.replicate (widthTgt - T.length pathTgt-                                        - T.length targetText) " "-      targetStatus = addAttr $ targetText <> targetGap <> pathTgt-      sfBottom =-        [ encodeLine $ arenaStatus ++ cursorStatus-        , encodeLine $ selectedStatus ++ nameStatus ++ statusGap-                       ++ damageStatus ++ leaderStatus-                       ++ targetStatus ]-      fLine y = encodeLine $-        let f l x = let ac = dis $ Point x y in ac : l-        in foldl' f [] [lxsize-1,lxsize-2..0]-      sfLevel =  -- fully evaluated-        let f l y = let !line = fLine y in line : l-        in foldl' f [] [lysize-1,lysize-2..0]-      sfBlank = False-  return $! SingleFrame{..}--inverseVideo :: Color.Attr-inverseVideo = Color.Attr { Color.fg = Color.bg Color.defAttr-                          , Color.bg = Color.fg Color.defAttr }---- Comfortably accomodates 3-digit level numbers and 25-character--- level descriptions (currently enforced max).-drawArenaStatus :: Bool -> Level -> Int -> [Color.AttrChar]-drawArenaStatus explored Level{ldepth=AbsDepth ld, ldesc, lseen, lclear} width =-  let addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)-      seenN = 100 * lseen `div` max 1 lclear-      seenTxt | explored || seenN >= 100 = "all"-              | otherwise = T.justifyLeft 3 ' ' (tshow seenN <> "%")-      lvlN = T.justifyLeft 2 ' ' (tshow ld)-      seenStatus = "[" <> seenTxt <+> "seen] "-  in addAttr $ T.justifyLeft width ' '-             $ T.take 29 (lvlN <+> T.justifyLeft 26 ' ' ldesc) <+> seenStatus--drawLeaderStatus :: MonadClient m => Int -> Int -> m [Color.AttrChar]-drawLeaderStatus waitT width = do-  mleader <- getsClient _sleader-  s <- getState-  let addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)-      addColor c t = map (Color.AttrChar $ Color.Attr c Color.defBG)-                         (T.unpack t)-      maxLeaderStatusWidth = 23  -- covers 3-digit HP and 2-digit Calm-      (calmHeaderText, hpHeaderText) = if width < maxLeaderStatusWidth-                                       then ("C", "H")-                                       else ("Calm", "HP")-  case mleader of-    Just leader -> do-      activeItems <- activeItemsClient leader-      let (darkL, bracedL, hpDelta, calmDelta,-           ahpS, bhpS, acalmS, bcalmS) =-            let b@Actor{bhp, bcalm} = getActorBody leader s-                amaxHP = sumSlotNoFilter 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)-               , tshow $ max 0 amaxCalm, tshow (bcalm `divUp` oneM))-          -- This is a valuable feedback for the otherwise hard to observe-          -- 'wait' command.-          slashes = ["/", "|", "\\", "|"]-          slashPick = slashes !! (max 0 (waitT - 1) `mod` length slashes)-          checkDelta ResDelta{..}-            | resCurrentTurn < 0 || resPreviousTurn < 0-              = addColor Color.BrRed  -- alarming news have priority-            | resCurrentTurn > 0 || resPreviousTurn > 0-              = addColor Color.BrGreen-            | otherwise = addAttr  -- only if nothing at all noteworthy-          calmAddAttr = checkDelta calmDelta-          darkPick | darkL   = "."-                   | otherwise = ":"-          calmHeader = calmAddAttr $ calmHeaderText <> darkPick-          calmText = bcalmS <> (if darkL then slashPick else "/") <> acalmS-          bracePick | bracedL   = "}"-                    | otherwise = ":"-          hpAddAttr = checkDelta hpDelta-          hpHeader = hpAddAttr $ hpHeaderText <> bracePick-          hpText = bhpS <> (if bracedL then slashPick else "/") <> ahpS-      return $! calmHeader <> addAttr (T.justifyRight 6 ' ' calmText <> " ")-                <> hpHeader <> addAttr (T.justifyRight 6 ' ' hpText <> " ")-    Nothing -> return $! addAttr $ calmHeaderText <> ": --/-- "-                                   <> hpHeaderText <> ": --/-- "--drawLeaderDamage :: MonadClient m => Int -> m [Color.AttrChar]-drawLeaderDamage width = do-  mleader <- getsClient _sleader-  let addColor t = map (Color.AttrChar $ Color.Attr Color.BrCyan Color.defBG)-                   (T.unpack t)-  stats <- case mleader of-    Just leader -> do-      actorSk <- actorSkillsClient leader-      b <- getsState $ getActorBody leader-      localTime <- getsState $ getLocalTime (blid b)-      allAssocs <- fullAssocsClient leader [CEqp, COrgan]-      let activeItems = map snd allAssocs-          calm10 = calmEnough10 b $ map snd allAssocs-          forced = assert (not $ bproj b) False-          permitted = permittedPrecious calm10 forced-          preferredPrecious = either (const False) id . permitted-          strongest = strongestMelee False localTime allAssocs-          strongestPreferred = filter (preferredPrecious . snd . snd) strongest-          damage = case strongestPreferred of-            _ | EM.findWithDefault 0 Ability.AbMelee actorSk <= 0 -> "0"-            [] -> "0"-            (_average, (_, itemFull)) : _ ->-              let getD :: IK.Effect -> Maybe Dice.Dice -> Maybe Dice.Dice-                  getD (IK.Hurt dice) acc = Just $ dice + fromMaybe 0 acc-                  getD (IK.Burn dice) acc = Just $ dice + fromMaybe 0 acc-                  getD _ acc = acc-                  mdice = case itemDisco itemFull of-                    Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} ->-                      foldr getD Nothing jeffects-                    Just ItemDisco{itemKind} ->-                      foldr getD Nothing (IK.ieffects itemKind)-                    Nothing -> Nothing-                  tdice = case mdice of-                    Nothing -> "0"-                    Just dice -> tshow dice-                  bonus = sumSlotNoFilter IK.EqpSlotAddHurtMelee activeItems-                  unknownBonus = unknownMelee activeItems-                  tbonus = if bonus == 0-                           then if unknownBonus then "+?" else ""-                           else (if bonus > 0 then "+" else "")-                                <> tshow bonus-                                <> if unknownBonus then "%?" else "%"-             in tdice <> tbonus-      return $! damage-    Nothing -> return ""-  return $! if T.null stats || T.length stats >= width then []-            else addColor $ stats <> " "---- TODO: colour some texts using the faction's colour-drawSelected :: MonadClient m => LevelId -> Int -> m [Color.AttrChar]-drawSelected drawnLevelId width = do-  mleader <- getsClient _sleader-  selected <- getsClient sselected-  side <- getsClient sside-  allOurs <- getsState $ filter ((== side) . bfid) . EM.elems . sactorD-  ours <- getsState $ filter (not . bproj . snd)-                      . actorAssocs (== side) drawnLevelId-  let viewOurs (aid, Actor{bsymbol, bcolor, bhp}) =-        let cattr = Color.defAttr {Color.fg = bcolor}-            sattr-              | Just aid == mleader = inverseVideo-              | ES.member aid selected =-                  -- TODO: in the future use a red rectangle instead-                  -- of background and mark them on the map, too;-                  -- also, perhaps blink all selected on the map,-                  -- when selection changes-                  if bcolor /= Color.Blue-                  then cattr {Color.bg = Color.Blue}-                  else cattr {Color.bg = Color.Magenta}-              | otherwise = cattr-        in Color.AttrChar sattr $ if bhp > 0 then bsymbol else '%'-      maxViewed = width - 2-      star = let sattr = case ES.size selected of-                   0 -> Color.defAttr {Color.fg = Color.BrBlack}-                   n | n == length ours ->-                     Color.defAttr {Color.bg = Color.Blue}-                   _ -> Color.defAttr-                 char = if length ours > maxViewed then '$' else '*'-             in Color.AttrChar sattr char-      viewed = map viewOurs $ take maxViewed-               $ sortBy (comparing keySelected) ours-      addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)-      -- Don't show anything if the only actor in the dungeon is the leader.-      -- He's clearly highlighted on the level map, anyway.-      party = if length allOurs == 1 && length ours == 1 || null ours-              then []-              else [star] ++ viewed ++ addAttr " "-  return $! party--drawPlayerName :: MonadClient m => Int -> m [Color.AttrChar]-drawPlayerName width = do-  let addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  let nameN n t =-        let fitWords [] = []-            fitWords l@(_ : rest) = if sum (map T.length l) + length l - 1 > n-                                    then fitWords rest-                                    else l-        in T.unwords $ reverse $ fitWords $ reverse $ T.words t-      ourName = nameN (width - 1) $ fname $ gplayer fact-  return $! if T.null ourName || T.length ourName >= width-            then []-            else addAttr $ ourName <> " "

+ Game/LambdaHack/Client/UI/DrawM.hs view

@@ -0,0 +1,603 @@+-- {-# OPTIONS_GHC -fprof-auto #-}+-- | Display game data on the screen using one of the available frontends+-- (determined at compile time with cabal flags).+module Game.LambdaHack.Client.UI.DrawM+  ( targetDescLeader, drawBaseFrame+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , targetDesc, targetDescXhair, drawFrameTerrain, drawFrameContent+  , drawFramePath, drawFrameActor, drawFrameExtra, drawFrameStatus+  , drawArenaStatus, drawLeaderStatus, drawLeaderDamage, drawSelected+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Control.Arrow (first)+import Control.Monad.ST.Strict+import qualified Data.Char as Char+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import Data.Ord+import qualified Data.Text as T+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as VM+import Data.Word (Word16)+import GHC.Exts (inline)+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Client.Bfs+import Game.LambdaHack.Client.BfsM+import Game.LambdaHack.Client.CommonM+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Client.UI.ActorUI+import Game.LambdaHack.Client.UI.ItemDescription+import Game.LambdaHack.Client.UI.MonadClientUI+import Game.LambdaHack.Client.UI.Overlay+import Game.LambdaHack.Client.UI.SessionUI+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import qualified Game.LambdaHack.Common.Color as Color+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.ItemStrongest+import qualified Game.LambdaHack.Common.Kind as Kind+import qualified Game.LambdaHack.Common.KindOps as KindOps+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Perception+import Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Vector+import qualified Game.LambdaHack.Content.ModeKind as MK+import Game.LambdaHack.Content.TileKind (TileKind, isUknownSpace)+import qualified Game.LambdaHack.Content.TileKind as TK++targetDesc :: MonadClientUI m => Maybe Target -> m (Maybe Text, Maybe Text)+targetDesc mtarget = do+  arena <- getArenaUI+  lidV <- viewedLevelUI+  mleader <- getsClient _sleader+  case mtarget of+    Just (TEnemy aid _) -> do+      side <- getsClient sside+      b <- getsState $ getActorBody aid+      bUI <- getsSession $ getActorUI aid+      actorAspect <- getsClient sactorAspect+      let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect)+          percentage = 100 * bhp b `div` xM (max 5 $ aMaxHP ar)+          chs n = "[" <> T.replicate n "*"+                      <> T.replicate (4 - n) "_" <> "]"+          stars = chs $ fromEnum $ max 0 $ min 4 $ percentage `div` 20+          hpIndicator = if bfid b == side then Nothing else Just stars+      return (Just $ bname bUI, hpIndicator)+    Just (TPoint tgoal lid p) -> case tgoal of+      TEnemyPos{} -> do+        let hotText = if lid == lidV && arena == lidV+                      then "hot spot" <+> tshow p+                      else "a hot spot on level" <+> tshow (abs $ fromEnum lid)+        return (Just hotText, Nothing)+      _ -> do  -- the other goals can be invalidated by now anyway and it's+               -- better to say what there is rather than what there isn't+        pointedText <-+          if lid == lidV && arena == lidV+          then do+            bag <- getsState $ getFloorBag lid p+            case EM.assocs bag of+              [] -> return $! "exact spot" <+> tshow p+              [(iid, kit@(k, _))] -> do+                localTime <- getsState $ getLocalTime lid+                itemToF <- itemToFullClient+                side <- getsClient sside+                factionD <- getsState sfactionD+                let (_, _, name, stats) =+                      partItem side factionD CGround localTime (itemToF iid kit)+                return $! makePhrase+                          $ if k == 1+                            then [name, stats]  -- "a sword" too wordy+                            else [MU.CarWs k name, stats]+              _ -> return $! "many items at" <+> tshow p+          else return $! "an exact spot on level" <+> tshow (abs $ fromEnum lid)+        return (Just pointedText, Nothing)+    Just target@TVector{} ->+      case mleader of+        Nothing -> return (Just "a relative shift", Nothing)+        Just aid -> do+          tgtPos <- aidTgtToPos aid lidV target+          let invalidMsg = "an invalid relative shift"+              validMsg p = "shift to" <+> tshow p+          return (Just $ maybe invalidMsg validMsg tgtPos, Nothing)+    Nothing -> return (Nothing, Nothing)++targetDescLeader :: MonadClientUI m => ActorId -> m (Maybe Text, Maybe Text)+targetDescLeader leader = do+  tgt <- getsClient $ getTarget leader+  targetDesc tgt++targetDescXhair :: MonadClientUI m => m (Text, Maybe Text)+targetDescXhair = do+  sxhair <- getsSession sxhair+  first fromJust <$> targetDesc (Just sxhair)++drawFrameTerrain :: forall m. MonadClientUI m => LevelId -> m FrameForall+drawFrameTerrain drawnLevelId = do+  Kind.COps{coTileSpeedup, cotile=Kind.Ops{okind}} <- getsState scops+  StateClient{smarkSuspect} <- getClient+  Level{lxsize, ltile=PointArray.Array{avector}} <- getLevel drawnLevelId+  totVisible <- totalVisible <$> getPerFid drawnLevelId+  let dis :: Int -> Kind.Id TileKind -> Color.AttrCharW32+      {-# INLINE dis #-}+      dis pI tile = case okind tile of+        TK.TileKind{tsymbol, tcolor, tcolor2} ->+          -- Passing @p0@ as arg in place of @pI@ is much more costly.+          let p0 :: Point+              {-# INLINE p0 #-}+              p0 = PointArray.punindex lxsize pI+              -- @smarkSuspect@ can be turned off easily, so let's overlay it+              -- over both visible and remembered tiles.+              fg :: Color.Color+              {-# INLINE fg #-}+              fg | smarkSuspect > 0+                   && Tile.isSuspect coTileSpeedup tile = Color.BrMagenta+                 | smarkSuspect > 1+                   && Tile.isHideAs coTileSpeedup tile = Color.Magenta+                 | ES.member p0 totVisible = tcolor+                 | otherwise = tcolor2+          in Color.attrChar2ToW32 fg tsymbol+      mapVT :: forall s. (Int -> Kind.Id TileKind -> Color.AttrCharW32)+            -> FrameST s+      {-# INLINE mapVT #-}+      mapVT f v = do+        let g :: Int -> Word16 -> ST s ()+            g !pI !tile = do+              let w = Color.attrCharW32 $ f pI (KindOps.Id tile)+              VM.write v (pI + lxsize) w+        U.imapM_ g avector+      upd :: FrameForall+      upd = FrameForall $ \v -> mapVT dis v  -- should be eta-expanded; lazy+  return upd++drawFrameContent :: forall m. MonadClientUI m => LevelId -> m FrameForall+drawFrameContent drawnLevelId = do+  SessionUI{smarkSmell} <- getSession+  Level{lxsize, lsmell, ltime, lfloor} <- getLevel drawnLevelId+  s <- getState+  let {-# INLINE viewItemBag #-}+      viewItemBag _ floorBag = case EM.toDescList floorBag of+        (iid, _) : _ -> viewItem $ getItemBody iid s+        [] -> assert `failure` "lfloor not sparse" `twith` ()+      viewSmell :: Point -> Time -> Color.AttrCharW32+      {-# INLINE viewSmell #-}+      viewSmell p0 sml =+        let fg = toEnum $ fromEnum p0 `rem` 14 + 1+            smlt = sml `timeDeltaToFrom` ltime+        in Color.attrChar2ToW32 fg (timeDeltaToDigit smellTimeout smlt)+      mapVAL :: forall a s. (Point -> a -> Color.AttrCharW32) -> [(Point, a)]+             -> FrameST s+      {-# INLINE mapVAL #-}+      mapVAL f l v = do+        let g :: (Point, a) -> ST s ()+            g (!p0, !a0) = do+              let pI = PointArray.pindex lxsize p0+                  w = Color.attrCharW32 $ f p0 a0+              VM.write v (pI + lxsize) w+        mapM_ g l+      upd :: FrameForall+      upd = FrameForall $ \v -> do+        mapVAL viewItemBag (EM.assocs lfloor) v+        when smarkSmell $+          mapVAL viewSmell (filter ((> ltime) . snd) $ EM.assocs lsmell) v+  return upd++drawFramePath :: forall m. MonadClientUI m => LevelId -> m FrameForall+drawFramePath drawnLevelId = do+ SessionUI{saimMode} <- getSession+ if isNothing saimMode then return $! FrameForall $ \_ -> return () else do+  Kind.COps{coTileSpeedup} <- getsState scops+  StateClient{seps} <- getClient+  Level{lxsize, lysize, ltile=PointArray.Array{avector}}+    <- getLevel drawnLevelId+  totVisible <- totalVisible <$> getPerFid drawnLevelId+  mleader <- getsClient _sleader+  xhairPosRaw <- xhairToPos+  let xhairPos = fromMaybe originPoint xhairPosRaw+  s <- getState+  bline <- case mleader of+    Just leader -> do+      Actor{bpos, blid} <- getsState $ getActorBody leader+      return $! if blid /= drawnLevelId+                then []+                else fromMaybe [] $ bla lxsize lysize seps bpos xhairPos+    _ -> return []+  mpath <- maybe (return Nothing) (\aid -> Just <$> do+    mtgtMPath <- getsClient $ EM.lookup aid . stargetD+    case mtgtMPath of+      Just TgtAndPath{tapPath=tapPath@AndPath{pathGoal}}+        | pathGoal == xhairPos -> return tapPath+      _ -> getCachePath aid xhairPos) mleader+  let lpath = if null bline then []+              else maybe [] (\mp -> case mp of+                NoPath -> []+                AndPath {pathList} -> pathList) mpath+      xhairHere = find (\(_, m) -> xhairPos == bpos m)+                       (inline actorAssocs (const True) drawnLevelId s)+      shiftedBTrajectory = case xhairHere of+        Just (_, Actor{btrajectory = Just p, bpos = prPos}) ->+          trajectoryToPath prPos (fst p)+        _ -> []+      shiftedLine = if null shiftedBTrajectory+                    then bline+                    else shiftedBTrajectory+      acOnPathOrLine :: Char.Char -> Point -> Kind.Id TileKind+                     -> Color.AttrCharW32+      acOnPathOrLine !ch !p0 !tile =+        let fgOnPathOrLine =+              case ( ES.member p0 totVisible+                   , Tile.isWalkable coTileSpeedup tile ) of+                _ | isUknownSpace tile -> Color.BrBlack+                _ | Tile.isSuspect coTileSpeedup tile -> Color.BrMagenta+                (True, True)   -> Color.BrGreen+                (True, False)  -> Color.BrRed+                (False, True)  -> Color.Green+                (False, False) -> Color.Red+        in Color.attrChar2ToW32 fgOnPathOrLine ch+      mapVTL :: forall s. (Point -> Kind.Id TileKind -> Color.AttrCharW32)+             -> [Point]+             -> FrameST s+      mapVTL f l v = do+        let g :: Point -> ST s ()+            g !p0 = do+              let pI = PointArray.pindex lxsize p0+                  tile = avector U.! pI+                  w = Color.attrCharW32 $ f p0 (KindOps.Id tile)+              VM.write v (pI + lxsize) w+        mapM_ g l+      upd :: FrameForall+      upd = FrameForall $ \v -> do+        mapVTL (acOnPathOrLine ';') lpath v+        mapVTL (acOnPathOrLine '*') shiftedLine v  -- overwrites path+  return upd++drawFrameActor :: forall m. MonadClientUI m => LevelId -> m FrameForall+drawFrameActor drawnLevelId = do+  SessionUI{sselected} <- getSession+  Level{lxsize, lactor} <- getLevel drawnLevelId+  mleader <- getsClient _sleader+  s <- getState+  sactorUI <- getsSession sactorUI+  let {-# INLINE viewActor #-}+      viewActor _ as = case as of+        aid : _ ->+          let Actor{bhp, bproj} = getActorBody aid s+              ActorUI{bsymbol, bcolor} = sactorUI EM.! aid+              symbol | bhp > 0 || bproj = bsymbol+                     | otherwise = '%'+              bg = case mleader of+                Just leader | aid == leader -> Color.HighlightRed+                _ -> if aid `ES.notMember` sselected+                     then Color.HighlightNone+                     else Color.HighlightBlue+          in Color.attrCharToW32+             $ Color.AttrChar Color.Attr{fg=bcolor, bg} symbol+        [] -> assert `failure` "lactor not sparse" `twith` ()+      mapVAL :: forall a s. (Point -> a -> Color.AttrCharW32) -> [(Point, a)]+             -> FrameST s+      {-# INLINE mapVAL #-}+      mapVAL f l v = do+        let g :: (Point, a) -> ST s ()+            g (!p0, !a0) = do+              let pI = PointArray.pindex lxsize p0+                  w = Color.attrCharW32 $ f p0 a0+              VM.write v (pI + lxsize) w+        mapM_ g l+      upd :: FrameForall+      upd = FrameForall $ \v ->+        mapVAL viewActor (EM.assocs lactor) v+  return upd++drawFrameExtra :: forall m. MonadClientUI m+               => ColorMode -> LevelId -> m FrameForall+drawFrameExtra dm drawnLevelId = do+  SessionUI{saimMode, smarkVision} <- getSession+  Level{lxsize, lysize} <- getLevel drawnLevelId+  totVisible <- totalVisible <$> getPerFid drawnLevelId+  mxhairPos <- xhairToPos+  mtgtPos <- do+    mleader <- getsClient _sleader+    case mleader of+      Nothing -> return Nothing+      Just leader -> do+        mtgt <- getsClient $ getTarget leader+        case mtgt of+          Nothing -> return Nothing+          Just tgt -> aidTgtToPos leader drawnLevelId tgt+  let visionMarks =+        if smarkVision+        then map (PointArray.pindex lxsize) $ ES.toList totVisible+        else []+      backlightVision :: Color.AttrChar -> Color.AttrChar+      backlightVision ac = case ac of+        Color.AttrChar (Color.Attr fg _) ch ->+          Color.AttrChar (Color.Attr fg Color.HighlightGrey) ch+      writeSquare !hi (Color.AttrChar (Color.Attr fg bg) ch) =+        let hiUnlessLeader | bg == Color.HighlightRed = bg+                           | otherwise = hi+        in Color.AttrChar (Color.Attr fg hiUnlessLeader) ch+      turnBW (Color.AttrChar _ ch) = Color.AttrChar Color.defAttr ch+      mapVL :: forall s. (Color.AttrChar -> Color.AttrChar) -> [Int]+            -> FrameST s+      mapVL f l v = do+        let g :: Int -> ST s ()+            g !pI = do+              w0 <- VM.read v (pI + lxsize)+              let w = Color.attrCharW32 . Color.attrCharToW32+                      . f . Color.attrCharFromW32 . Color.AttrCharW32 $ w0+              VM.write v (pI + lxsize) w+        mapM_ g l+      lDungeon = [0..lxsize * lysize - 1]+      upd :: FrameForall+      upd = FrameForall $ \v -> do+        when (isJust saimMode) $ mapVL backlightVision visionMarks v+        case mtgtPos of+          Nothing -> return ()+          Just p -> mapVL (writeSquare Color.HighlightGrey)+                          [PointArray.pindex lxsize p] v+        case mxhairPos of  -- overwrites target+          Nothing -> return ()+          Just p -> mapVL (writeSquare Color.HighlightYellow)+                          [PointArray.pindex lxsize p] v+        when (dm == ColorBW) $ mapVL turnBW lDungeon v+  return upd++drawFrameStatus :: MonadClientUI m => LevelId -> m AttrLine+drawFrameStatus drawnLevelId = do+  SessionUI{sselected, saimMode, swaitTimes, sitemSel} <- getSession+  mleader <- getsClient _sleader+  xhairPos <- xhairToPos+  tgtPos <- leaderTgtToPos+  mbfs <- maybe (return Nothing) (\aid -> Just <$> getCacheBfs aid) mleader+  (mtgtDesc, mtargetHP) <-+    maybe (return (Nothing, Nothing)) targetDescLeader mleader+  (xhairDesc, mxhairHP) <- targetDescXhair+  sexplored <- getsClient sexplored+  lvl <- getLevel drawnLevelId+  (mblid, mbpos, mbodyUI) <- case mleader of+    Just leader -> do+      Actor{bpos, blid} <- getsState $ getActorBody leader+      bodyUI <- getsSession $ getActorUI leader+      return (Just blid, Just bpos, Just bodyUI)+    Nothing -> return (Nothing, Nothing, Nothing)+  let widthX = 80+      widthTgt = 39+      widthStats = widthX - widthTgt - 1+      arenaStatus = drawArenaStatus (ES.member drawnLevelId sexplored) lvl+                                    widthStats+      displayPathText mp mt =+        let (plen, llen) = case (mp, mbfs, mbpos) of+              (Just target, Just bfs, Just bpos)+                | mblid == Just drawnLevelId ->+                  (fromMaybe 0 (accessBfs bfs target), chessDist bpos target)+              _ -> (0, 0)+            pText | plen == 0 = ""+                  | otherwise = "p" <> tshow plen+            lText | llen == 0 = ""+                  | otherwise = "l" <> tshow llen+            text = fromMaybe (pText <+> lText) mt+        in if T.null text then "" else " " <> text+      -- The indicators must fit, they are the actual information.+      pathCsr = displayPathText xhairPos mxhairHP+      trimTgtDesc n t = assert (not (T.null t) && n > 2 `blame` (t, n)) $+        if T.length t <= n then t+        else let ellipsis = "..."+                 fitsPlusOne = T.take (n - T.length ellipsis + 1) t+                 fits = if T.last fitsPlusOne == ' '+                        then T.init fitsPlusOne+                        else let lw = T.words fitsPlusOne+                             in T.unwords $ init lw+             in fits <> ellipsis+      xhairText =+        let n = widthTgt - T.length pathCsr - 8+        in (if isJust saimMode then "x-hair>" else "X-hair:")+           <+> trimTgtDesc n xhairDesc+      xhairGap = emptyAttrLine (widthTgt - T.length pathCsr+                                         - T.length xhairText)+      xhairStatus = textToAL xhairText ++ xhairGap ++ textToAL pathCsr+      leaderStatusWidth = 23+  leaderStatus <- drawLeaderStatus swaitTimes+  (selectedStatusWidth, selectedStatus)+    <- drawSelected drawnLevelId (widthStats - leaderStatusWidth) sselected+  damageStatus <- drawLeaderDamage (widthStats - leaderStatusWidth+                                               - selectedStatusWidth)+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  let statusGap = emptyAttrLine (widthStats - leaderStatusWidth+                                            - selectedStatusWidth+                                            - length damageStatus)+      tgtOrItem n = do+        let fallback = if MK.fleaderMode (gplayer fact) == MK.LeaderNull+                       then "This faction never picks a leader"+                       else "Waiting for a team member to spawn"+            leaderName =+              maybe fallback (\body ->+                "Leader:" <+> trimTgtDesc n (bname body)) mbodyUI+            tgtBlurb = maybe leaderName (\t ->+              "Target:" <+> trimTgtDesc n t) mtgtDesc+        case (sitemSel, mleader) of+          (Just (fromCStore, iid), Just leader) -> do+            b <- getsState $ getActorBody leader+            bag <- getsState $ getBodyStoreBag b fromCStore+            case iid `EM.lookup` bag of+              Nothing -> return $! tgtBlurb+              Just kit@(k, _) -> do+                localTime <- getsState $ getLocalTime (blid b)+                itemToF <- itemToFullClient+                factionD <- getsState sfactionD+                let (_, _, name, stats) =+                      partItem (bfid b) factionD+                               fromCStore localTime (itemToF iid kit)+                    t = makePhrase+                        $ if k == 1+                          then [name, stats]  -- "a sword" too wordy+                          else [MU.CarWs k name, stats]+                return $! "Item:" <+> trimTgtDesc n t+          _ -> return $! tgtBlurb+      -- The indicators must fit, they are the actual information.+      pathTgt = displayPathText tgtPos mtargetHP+  targetText <- tgtOrItem $ widthTgt - T.length pathTgt - 8+  let targetGap = emptyAttrLine (widthTgt - T.length pathTgt+                                          - T.length targetText)+      targetStatus = textToAL targetText ++ targetGap ++ textToAL pathTgt+  return $! arenaStatus <+:> xhairStatus+            <> selectedStatus ++ statusGap ++ damageStatus ++ leaderStatus+               <+:> targetStatus++-- | Draw the whole screen: level map and status area.+-- Pass at most a single page if overlay of text unchanged+-- to the frontends to display separately or overlay over map,+-- depending on the frontend.+drawBaseFrame :: MonadClientUI m => ColorMode -> LevelId -> m FrameForall+drawBaseFrame dm drawnLevelId = do+  Level{lxsize, lysize} <- getLevel drawnLevelId+  updTerrain <- drawFrameTerrain drawnLevelId+  updContent <- drawFrameContent drawnLevelId+  updPath <- drawFramePath drawnLevelId+  updActor <- drawFrameActor drawnLevelId+  updExtra <- drawFrameExtra dm drawnLevelId+  frameStatus <- drawFrameStatus drawnLevelId+  let !_A = assert (length frameStatus == 2 * lxsize+                    `blame` map Color.charFromW32 frameStatus) ()+      upd = FrameForall $ \v -> do+        unFrameForall updTerrain v+        unFrameForall updContent v+        unFrameForall updPath v+        unFrameForall updActor v+        unFrameForall updExtra v+        unFrameForall (writeLine (lxsize * (lysize + 1)) frameStatus) v+  return upd++-- Comfortably accomodates 3-digit level numbers and 25-character+-- level descriptions (currently enforced max).+drawArenaStatus :: Bool -> Level -> Int -> AttrLine+drawArenaStatus explored Level{ldepth=AbsDepth ld, ldesc, lseen, lclear} width =+  let seenN = 100 * lseen `div` max 1 lclear+      seenTxt | explored || seenN >= 100 = "all"+              | otherwise = T.justifyLeft 3 ' ' (tshow seenN <> "%")+      lvlN = T.justifyLeft 2 ' ' (tshow ld)+      seenStatus = "[" <> seenTxt <+> "seen]"+  in textToAL $ T.justifyLeft width ' '+              $ T.take 29 (lvlN <+> T.justifyLeft 26 ' ' ldesc) <+> seenStatus++drawLeaderStatus :: MonadClient m => Int -> m AttrLine+drawLeaderStatus waitT = do+  let calmHeaderText = "Calm"+      hpHeaderText = "HP"+  mleader <- getsClient _sleader+  case mleader of+    Just leader -> do+      actorAspect <- getsClient sactorAspect+      s <- getState+      let ar = fromMaybe (assert `failure` leader)+                         (EM.lookup leader actorAspect)+          showTrunc :: Show a => a -> String+          showTrunc = (\t -> if length t > 3 then "***" else t) . show+          (darkL, bracedL, hpDelta, calmDelta,+           ahpS, bhpS, acalmS, bcalmS) =+            let b@Actor{bhp, bcalm} = getActorBody leader s+            in ( not (actorInAmbient b s)+               , braced b, bhpDelta b, bcalmDelta b+               , showTrunc $ aMaxHP ar, showTrunc (bhp `divUp` oneM)+               , showTrunc $ aMaxCalm ar, showTrunc (bcalm `divUp` oneM))+          -- This is a valuable feedback for the otherwise hard to observe+          -- 'wait' command.+          slashes = ["/", "|", "\\", "|"]+          slashPick = slashes !! (max 0 (waitT - 1) `mod` length slashes)+          addColor c = map (Color.attrChar2ToW32 c)+          checkDelta ResDelta{..}+            | fst resCurrentTurn < 0 || fst resPreviousTurn < 0+              = addColor Color.BrRed  -- alarming news have priority+            | snd resCurrentTurn > 0 || snd resPreviousTurn > 0+              = addColor Color.BrGreen+            | otherwise = stringToAL  -- only if nothing at all noteworthy+          calmAddAttr = checkDelta calmDelta+          -- We only show ambient light, because in fact client can't tell+          -- if a tile is lit, because it it's seen it may be due to ambient+          -- or dynamic light or due to infravision.+          darkPick | darkL   = "."+                   | otherwise = ":"+          calmHeader = calmAddAttr $ calmHeaderText <> darkPick+          calmText = bcalmS <> (if darkL then slashPick else "/") <> acalmS+          bracePick | bracedL   = "}"+                    | otherwise = ":"+          hpAddAttr = checkDelta hpDelta+          hpHeader = hpAddAttr $ hpHeaderText <> bracePick+          hpText = bhpS <> (if bracedL then slashPick else "/") <> ahpS+          justifyRight n t = replicate (n - length t) ' ' ++ t+      return $! calmHeader <> stringToAL (justifyRight 7 calmText)+                <+:> hpHeader <> stringToAL (justifyRight 7 hpText)+    Nothing -> return $! stringToAL (calmHeaderText ++ ":  --/--")+                         <+:> stringToAL (hpHeaderText <> ":  --/--")++drawLeaderDamage :: MonadClientUI m => Int -> m AttrLine+drawLeaderDamage width = do+  mleader <- getsClient _sleader+  let addColor = map (Color.attrChar2ToW32 Color.BrCyan)+  stats <- case mleader of+    Just leader -> do+      allAssocsRaw <- fullAssocsClient leader [CEqp, COrgan]+      let allAssocs = filter (isMelee . itemBase . snd) allAssocsRaw+      actorSk <- leaderSkillsClientUI+      actorAspect <- getsClient sactorAspect+      strongest <- pickWeaponM Nothing allAssocs actorSk actorAspect leader+      let damage = case strongest of+            [] -> "0"+            (_, (_, itemFull)) : _ ->+              let tdice = show $ jdamage $ itemBase itemFull+                  bonusRaw = aHurtMelee $ actorAspect EM.! leader+                  bonus = min 200 $ max (-200) bonusRaw+                  unknownBonus = unknownMelee $ map snd allAssocs+                  tbonus = if bonus == 0+                           then if unknownBonus then "+?" else ""+                           else (if bonus > 0 then "+" else "")+                                <> show bonus+                                <> (if bonus /= bonusRaw then "$" else "")+                                <> if unknownBonus then "%?" else "%"+             in tdice <> tbonus+      return $! damage+    Nothing -> return ""+  return $! if null stats || length stats >= width then []+            else addColor $ stats <> " "++drawSelected :: MonadClientUI m+             => LevelId -> Int -> ES.EnumSet ActorId -> m (Int, AttrLine)+drawSelected drawnLevelId width selected = do+  mleader <- getsClient _sleader+  side <- getsClient sside+  sactorUI <- getsSession sactorUI+  ours <- getsState $ filter (not . bproj . snd)+                      . inline actorAssocs (== side) drawnLevelId+  let oursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) ours+      viewOurs (aid, Actor{bhp}, ActorUI{bsymbol, bcolor}) =+        let bg = if | mleader == Just aid -> Color.HighlightRed+                    | ES.member aid selected -> Color.HighlightBlue+                    | otherwise -> Color.HighlightNone+            sattr = Color.Attr {Color.fg = bcolor, bg}+        in Color.attrCharToW32 $ Color.AttrChar sattr+           $ if bhp > 0 then bsymbol else '%'+      maxViewed = width - 2+      len = length oursUI+      star = let fg = case ES.size selected of+                   0 -> Color.BrBlack+                   n | n == len -> Color.BrWhite+                   _ -> Color.defFG+                 char = if len > maxViewed then '$' else '*'+             in Color.attrChar2ToW32 fg char+      viewed = map viewOurs $ take maxViewed+               $ sortBy (comparing keySelected) oursUI+  return (min width (len + 2), [star] ++ viewed ++ [Color.spaceAttrW32])

+ Game/LambdaHack/Client/UI/EffectDescription.hs view

@@ -0,0 +1,317 @@+-- | Description of effects. No operation in this module+-- involves state or monad types.+module Game.LambdaHack.Client.UI.EffectDescription+  ( effectToSuffix, featureToSuff, kindAspectToSuffix, affixDice+  , featureToSentence, slotToSentence+  , slotToName, slotToDesc, slotToDecorator, statSlots+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.Text as T+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Common.Ability+import Game.LambdaHack.Common.Actor+import qualified Game.LambdaHack.Common.Dice as Dice+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Content.ItemKind++-- | Suffix to append to a basic content name if the content causes the effect.+--+-- 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.+effectToSuffix :: Effect -> Text+effectToSuffix effect =+  case effect of+    ELabel _ -> ""  -- printed specially+    EqpSlot{} -> ""  -- used in @slotToSentence@ instead+    Burn d -> wrapInParens (tshow d+                            <+> if d > 1 then "burns" else "burn")+    Explode t -> "of" <+> tshow t <+> "explosion"+    RefillHP p | p > 0 -> "of healing" <+> wrapInParens (affixBonus p)+    RefillHP 0 -> assert `failure` effect+    RefillHP p -> "of wounding" <+> wrapInParens (affixBonus p)+    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"+    Summon grp p -> makePhrase+      [ "of summoning"+      , if p == 1 then "" else MU.Text $ tshow p+      , MU.Ws $ MU.Text $ tshow grp ]+    ApplyPerfume -> "of smell removal"+    Ascend True -> "of ascending"+    Ascend False -> "of descending"+    Escape{} -> "of escaping"+    Paralyze dice ->+      let time = case Dice.reduceDice dice of+            Nothing -> tshow dice <+> "* 0.05s"+            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)+    Teleport dice -> "of teleport" <+> wrapInParens (tshow dice)+    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 n k store grp ->+      let ntxt = if | n == 1 && k == 1 -> ""+                    | n == 1 && k == maxBound -> "all"+                    | n == maxBound && k == maxBound -> "all kinds of"+                    | otherwise -> "some"+          verb = if store == COrgan then "nullify" else "drop"+      in "of" <+> verb <+> ntxt <+> tshow grp  -- TMI: <+> ppCStore store+    PolyItem -> "of repurpose on the ground"+    Identify -> "of identify on the ground"+    Detect radius -> "of detection" <+> wrapInParens (tshow radius)+    DetectActor radius -> "of actor detection" <+> wrapInParens (tshow radius)+    DetectItem radius -> "of item detection" <+> wrapInParens (tshow radius)+    DetectExit radius -> "of exit detection" <+> wrapInParens (tshow radius)+    DetectHidden radius ->+      "of secrets detection" <+> wrapInParens (tshow radius)+    SendFlying tmod -> "of impact" <+> tmodToSuff "" tmod+    PushActor tmod -> "of pushing" <+> tmodToSuff "" tmod+    PullActor tmod -> "of pulling" <+> tmodToSuff "" tmod+    DropBestWeapon -> "of disarming"+    ActivateInv ' ' -> "of item pack 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 _ -> ""  -- printed inside a separate section+    Recharging _ -> ""  -- printed inside Periodic or Timeout+    Temporary _ -> ""+    Unique -> ""  -- marked by capital letters in name+    Periodic -> ""  -- printed specially++slotToSentence :: EqpSlot -> Text+slotToSentence es = case es of+  EqpSlotMiscBonus -> "Those that don't scorn minor bonuses may equip it."+  EqpSlotAddHurtMelee -> "Veteran melee fighters are known to devote equipment slot to it."+  EqpSlotAddArmorMelee -> "Worn by people in risk of melee wounds."+  EqpSlotAddArmorRanged -> "People scared of shots in the dark wear it."+  EqpSlotAddMaxHP -> "The frail wear it to increase their Hit Point capacity."+  EqpSlotAddSpeed -> "The slughish equip it to speed up their whole life."+  EqpSlotAddSight -> "The short-sighted wear it to spot their demise sooner."+  EqpSlotLightSource -> "Explorers brave enough to highlight themselves put it in their equipment."+  EqpSlotWeapon -> "Melee fighters consider it for their weapon combo."+  EqpSlotMiscAbility -> "Those that don't scorn uncanny skills may equip it."+  EqpSlotAbMove -> "Those unskilled in movement equip it."+  EqpSlotAbMelee -> "Those unskilled in melee equip it."+  EqpSlotAbDisplace -> "Those unskilled in displacing equip it."+  EqpSlotAbAlter -> "Those unskilled in alteration equip it."+  EqpSlotAbProject -> "Those unskilled in flinging equip it."+  EqpSlotAbApply -> "Those unskilled in applying items equip it."+  _ -> assert `failure` "should not be used in content" `twith` es++slotToName :: EqpSlot -> Text+slotToName eqpSlot =+  case eqpSlot of+    EqpSlotMiscBonus -> "misc bonuses"+    EqpSlotAddHurtMelee -> "to melee damage"+    EqpSlotAddArmorMelee -> "melee armor"+    EqpSlotAddArmorRanged -> "ranged armor"+    EqpSlotAddMaxHP -> "max HP"+    EqpSlotAddSpeed -> "speed"+    EqpSlotAddSight -> "sight radius"+    EqpSlotLightSource -> "shine radius"+    EqpSlotWeapon -> "weapon power"+    EqpSlotMiscAbility -> "misc abilities"+    EqpSlotAbMove -> tshow AbMove <+> "ability"+    EqpSlotAbMelee -> tshow AbMelee <+> "ability"+    EqpSlotAbDisplace -> tshow AbDisplace <+> "ability"+    EqpSlotAbAlter -> tshow AbAlter <+> "ability"+    EqpSlotAbProject -> tshow AbProject <+> "ability"+    EqpSlotAbApply -> tshow AbApply <+> "ability"+    EqpSlotAddMaxCalm -> "max Calm"+    EqpSlotAddSmell -> "smell radius"+    EqpSlotAddNocto -> "night vision radius"+    EqpSlotAddAggression -> "aggression level"+    EqpSlotAbWait -> tshow AbWait <+> "ability"+    EqpSlotAbMoveItem -> tshow AbMoveItem <+> "ability"++slotToDesc :: EqpSlot -> Text+slotToDesc eqpSlot =+  let statName = slotToName eqpSlot+      capName = "The '" <> statName <> "' stat"+  in capName <+> case eqpSlot of+    EqpSlotMiscBonus -> "represent the total power of assorted stat bonuses for the character."+    EqpSlotAddHurtMelee -> "is a percentage of addtional damage dealt by the actor (either a character or a missile) with any weapon. The value is capped at 200%, then the armor percentage of the defender is subtracted from it and the resulting total is capped at 99%."+    EqpSlotAddArmorMelee -> "is a percentage of melee damage avoided by the actor. The value is capped at 200%, then the extra melee damage percentage of the attacker is subtracted from it and the resulting total is capped at 99% (always at least 1% of damage gets through). It includes 50% bonus from being braced for combat, if applicable."+    EqpSlotAddArmorRanged ->  "is a percentage of ranged damage avoided by the actor. The value is capped at 200%, then the extra melee damage percentage of the attacker is subtracted from it and the resulting total is capped at 99% (always at least 1% of damage gets through). It includes 25% bonus from being braced for combat, if applicable."+    EqpSlotAddMaxHP -> "is a cap on HP of the actor, except for some rare effects able to overfill HP. At any direct enemy damage (but not, e.g., incremental poisoning damage or wounds inflicted by mishandling a device) HP is cut back to the cap."+    EqpSlotAddSpeed -> "is expressed in meters per second, which corresponds to map location (1m by 1m) per two standard turns (0.5s each). Thus actor at standard speed of 2m/s moves one location per standard turn."+    EqpSlotAddSight -> "is the limit of visibility in light. The radius is measured from the middle of the map location occupied by the character to the edge of the furthest covered location."+    EqpSlotLightSource -> "determines the maximal area lit by the actor. The radius is measured from the middle of the map location occupied by the character to the edge of the furthest covered location."+    EqpSlotWeapon -> "represents the total power of weapons equipped by the character."+    EqpSlotMiscAbility -> "represent the total power of assorted ability bonuses for the character."+    EqpSlotAbMove -> "determines whether the character can move. Actors not capable of movement can't be dominated."+    EqpSlotAbMelee -> "determines whether the character can melee. Actors that can't melee can still cause damage by flinging missiles or by ramming (being pushed) at opponents."+    EqpSlotAbDisplace -> "determines whether the character can displace adjacent actors. In some cases displacing is not possible regardless of ability: when the target is braced, dying, has no move ability or when both actors are supported by adjacent friendly units. Missiles can be displaced always, unless more than one occupies the map location."+    EqpSlotAbAlter -> "determines which kinds of terrain can be altered or triggered by the character. Opening doors and searching suspect tiles require ability 2, stairs require 3, closing doors requires 4, some others require 5. Actors not smart enough to be capable of using stairs can't be dominated."+    EqpSlotAbProject -> "determines which kinds of items the character can propel. Items that can be lobbed to explode at a precise location, such as flasks, require ability 3. Other items travel until they meet an obstacle and ability 1 is enough to fling them. In some cases, e.g., of too intricate or two awkward items at low Calm, throwing is not possible regardless of the ability value."+    EqpSlotAbApply -> "determines which kinds of items the character can activate. Items that assume literacy require ability 2, others can be used already at ability 1. In some cases, e.g., when the item needs recharging, has no possible effects or is too intricate for the character Calm level, applying may not be possible."+    EqpSlotAddMaxCalm -> "is a cap on Calm of the actor, except for some rare effects able to overfill Calm. At any direct enemy damage (but not, e.g., incremental poisoning damage or wounds inflicted by mishandling a device) Calm is lowered, sometimes very significantly and always at least back down to the cap."+    EqpSlotAddSmell -> "determines the maximal area smelled by the actor. The radius is measured from the middle of the map location occupied by the character to the edge of the furthest covered location."+    EqpSlotAddNocto -> "is the limit of visibility in dark. The radius is measured from the middle of the map location occupied by the character to the edge of the furthest covered location."+    EqpSlotAddAggression -> "represents the willingness of the actor to engage in combat, especially close quarters, and conversly, to break engagement when overpowered."+    EqpSlotAbWait -> "determines whether the character can wait, bracing for comat and potentially blocking the effects of some attacks."+    EqpSlotAbMoveItem -> "determines whether the character can pick up items and manage inventory."++slotToDecorator :: EqpSlot -> Actor -> Int -> Text+slotToDecorator eqpSlot b t =+  let tshow200 n = let n200 = min 200 $ max (-200) n+                   in tshow n200 <> if n200 /= n then "$" else ""+      -- Some values can be negative, for others 0 is equivalent but shorter.+      tshowRadius r = if r == 0 then "0m" else tshow (r - 1) <> ".5m"+      tshowBlock k n = tshow200 $ n + if braced b then k else 0+      showIntWith1 :: Int -> Text+      showIntWith1 k =+        let l = k `div` 10+            x = k - l * 10+        in tshow l <> if x == 0 then "" else "." <> tshow x+  in case eqpSlot of+    EqpSlotMiscBonus -> tshow t+    EqpSlotAddHurtMelee -> tshow200 t <> "%"+    EqpSlotAddArmorMelee -> "[" <> tshowBlock 50 t <> "%]"+    EqpSlotAddArmorRanged -> "{" <> tshowBlock 25 t <> "%}"+    EqpSlotAddMaxHP -> tshow $ max 0 t+    EqpSlotAddSpeed -> showIntWith1 t <> "m/s"+    EqpSlotAddSight ->+      let tmax = max 0 t+          tcapped = min (fromEnum $ bcalm b `div` (5 * oneM)) tmax+      in tshowRadius tcapped+         <+> if tcapped == tmax+             then ""+             else "(max" <+> tshowRadius tmax <> ")"+    EqpSlotLightSource -> tshowRadius (max 0 t)+    EqpSlotWeapon -> tshow t+    EqpSlotMiscAbility -> tshow t+    EqpSlotAbMove -> tshow t+    EqpSlotAbMelee -> tshow t+    EqpSlotAbDisplace -> tshow t+    EqpSlotAbAlter -> tshow t+    EqpSlotAbProject -> tshow t+    EqpSlotAbApply -> tshow t+    EqpSlotAddMaxCalm -> tshow $ max 0 t+    EqpSlotAddSmell -> tshowRadius (max 0 t)+    EqpSlotAddNocto -> tshowRadius (max 0 t)+    EqpSlotAddAggression -> tshow t+    EqpSlotAbWait -> tshow t+    EqpSlotAbMoveItem -> tshow t++statSlots :: [EqpSlot]+statSlots = [ EqpSlotAddHurtMelee+            , EqpSlotAddArmorMelee+            , EqpSlotAddArmorRanged+            , EqpSlotAddMaxHP+            , EqpSlotAddMaxCalm+            , EqpSlotAddSpeed+            , EqpSlotAddSight+            , EqpSlotAddSmell+            , EqpSlotLightSource+            , EqpSlotAddNocto+-- WIP:           , EqpSlotAddAggression+            , EqpSlotAbMove+            , EqpSlotAbMelee+            , EqpSlotAbDisplace+            , EqpSlotAbAlter+            , EqpSlotAbWait+            , EqpSlotAbMoveItem+            , EqpSlotAbProject+            , EqpSlotAbApply ]++tmodToSuff :: Text -> ThrowMod -> Text+tmodToSuff verb ThrowMod{..} =+  let vSuff | throwVelocity == 100 = ""+            | otherwise = "v=" <> tshow throwVelocity <> "%"+      tSuff | throwLinger == 100 = ""+            | otherwise = "t=" <> tshow throwLinger <> "%"+  in if vSuff == "" && tSuff == "" then ""+     else verb <+> "with" <+> vSuff <+> tSuff++kindAspectToSuffix :: Aspect -> Text+kindAspectToSuffix aspect =+  case aspect of+    Timeout{} -> ""  -- printed specially+    AddHurtMelee{} -> ""  -- printed together with dice, even if dice is zero+    AddArmorMelee t -> "[" <> affixDice t <> "%]"+    AddArmorRanged t -> "{" <> affixDice t <> "%}"+    AddMaxHP t -> wrapInParens $ affixDice t <+> "HP"+    AddMaxCalm t -> wrapInParens $ affixDice t <+> "Calm"+    AddSpeed t -> wrapInParens $ affixDice t <+> "speed"+    AddSight t -> wrapInParens $ affixDice t <+> "sight"+    AddSmell t -> wrapInParens $ affixDice t <+> "smell"+    AddShine t -> wrapInParens $ affixDice t <+> "shine"+    AddNocto t -> wrapInParens $ affixDice t <+> "night vision"+    AddAggression t -> wrapInParens $ affixDice t <+> "aggression"+    AddAbility ab t -> wrapInParens $ affixDice t <+> tshow ab++featureToSuff :: Feature -> Text+featureToSuff feat =+  case feat of+    Fragile -> wrapInChevrons "fragile"+    Lobable -> wrapInChevrons "can be lobbed"+    Durable -> wrapInChevrons "durable"+    ToThrow tmod -> wrapInChevrons $ tmodToSuff "flies" tmod+    Identified -> ""+    Applicable -> ""+    Equipable -> ""+    Meleeable -> ""+    Precious -> ""+    Tactic tactics -> "overrides tactics to" <+> tshow tactics++featureToSentence :: Feature -> Maybe Text+featureToSentence feat =+  case feat of+    Fragile -> Nothing+    Lobable -> Nothing+    Durable -> Nothing+    ToThrow{} -> Nothing+    Identified -> Nothing+    Applicable -> Just "It is meant to be applied."+    Equipable -> Nothing+    Meleeable -> Just "It is considered for melee strikes by default."+    Precious -> Just "It seems precious."+    Tactic{}  -> Nothing++affixBonus :: Int -> Text+affixBonus p = case compare p 0 of+  EQ -> "0"+  LT -> tshow p+  GT -> "+" <> tshow p++wrapInParens :: Text -> Text+wrapInParens "" = ""+wrapInParens t = "(" <> t <> ")"++wrapInChevrons :: Text -> Text+wrapInChevrons "" = ""+wrapInChevrons t = "<" <> t <> ">"++affixDice :: Dice.Dice -> Text+affixDice d = maybe "+?" affixBonus $ Dice.reduceDice d

+ Game/LambdaHack/Client/UI/Frame.hs view

@@ -0,0 +1,82 @@+-- | Screen frames.+module Game.LambdaHack.Client.UI.Frame+  ( SingleFrame(..), Frames+  , blankSingleFrame, overlayFrame, overlayFrameWithLines+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Data.Word (Word32)++import Game.LambdaHack.Client.UI.Overlay+import Game.LambdaHack.Common.Color+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray++-- | An overlay that fits on the screen (or is meant to be truncated on display)+-- and is padded to fill the whole screen+-- and is displayed as a single game screen frame.+--+-- Note that we don't provide a list of color-highlighed positions separately,+-- because overlays need to obscure not only map, but the highlights as well.+newtype SingleFrame = SingleFrame+  {singleFrame :: PointArray.GArray Word32 AttrCharW32}+  deriving (Eq, Show)++-- | Sequences of screen frames, including delays.+type Frames = [Maybe FrameForall]++blankSingleFrame :: SingleFrame+blankSingleFrame =+  let lxsize = fst normalLevelBound + 1+      lysize = snd normalLevelBound + 4+  in SingleFrame $ PointArray.replicateA lxsize lysize spaceAttrW32++-- | Truncate the overlay: for each line, if it's too long, it's truncated+-- and if there are too many lines, excess is dropped and warning is appended.+truncateLines :: Bool -> [AttrLine] -> [AttrLine]+truncateLines onBlank l =+  let lxsize = fst normalLevelBound + 1+      lysize = snd normalLevelBound + 1+      canvasLength = if onBlank then lysize + 3 else lysize + 1+      topLayer = if length l <= canvasLength+                 then l ++ [[] | length l < canvasLength && length l > 3]+                 else take (canvasLength - 1) l+                      ++ [stringToAL "--a portion of the text trimmed--"]+      f lenPrev lenNext layerLine =+        truncateAttrLine lxsize layerLine (max lenPrev lenNext)+      lens = map (min (lxsize - 1) . length) topLayer+  in zipWith3 f (0 : lens) (drop 1 lens ++ [0]) topLayer++-- | Add a space at the message end, for display overlayed over the level map.+-- Also trim (do not wrap!) too long lines.+truncateAttrLine :: X -> AttrLine -> X -> AttrLine+truncateAttrLine w xs lenMax =+  case compare w (length xs) of+    LT -> let discarded = drop w xs+          in if all (== spaceAttrW32) discarded+             then take w xs+             else take (w - 1) xs ++ [attrChar2ToW32 BrBlack '$']+    EQ -> xs+    GT -> let xsSpace = if null xs || last xs == spaceAttrW32+                        then xs+                        else xs ++ [spaceAttrW32]+              whiteN = max (40 - length xsSpace) (1 + lenMax - length xsSpace)+          in xsSpace ++ replicate whiteN spaceAttrW32++-- | Overlays either the game map only or the whole empty screen frame.+-- We assume the lines of the overlay are not too long nor too many.+overlayFrame :: Overlay -> FrameForall -> FrameForall+overlayFrame ov ff = FrameForall $ \v -> do+  unFrameForall ff v+  mapM_ (\(offset, l) -> unFrameForall (writeLine offset l) v) ov++overlayFrameWithLines :: Bool -> [AttrLine] -> FrameForall -> FrameForall+overlayFrameWithLines onBlank l msf =+  let lxsize = fst normalLevelBound + 1+      ov = map (\(y, al) -> (y * lxsize, al))+           $ zip [0..] $ truncateLines onBlank l+  in overlayFrame ov msf

+ Game/LambdaHack/Client/UI/FrameM.hs view

@@ -0,0 +1,119 @@+-- | A set of Frame monad operations.+module Game.LambdaHack.Client.UI.FrameM+  ( drawOverlay, promptGetKey, stopPlayBack, animate, fadeOutOrIn+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.EnumMap.Strict as EM++import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Client.UI.Animation+import Game.LambdaHack.Client.UI.Config+import Game.LambdaHack.Client.UI.DrawM+import Game.LambdaHack.Client.UI.Frame+import qualified Game.LambdaHack.Client.UI.Key as K+import Game.LambdaHack.Client.UI.MonadClientUI+import Game.LambdaHack.Client.UI.Msg+import Game.LambdaHack.Client.UI.MsgM+import Game.LambdaHack.Client.UI.Overlay+import Game.LambdaHack.Client.UI.SessionUI+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.ClientOptions+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.State++-- | Draw the current level with the overlay on top.+-- If the overlay is too long, it's truncated.+-- Similarly, for each line of the overlay, if it's too wide, it's truncated.+drawOverlay :: MonadClientUI m+            => ColorMode -> Bool -> [AttrLine] -> LevelId -> m FrameForall+drawOverlay dm onBlank topTrunc lid = do+  mbaseFrame <- if onBlank+                then return $ FrameForall $ \_v -> return ()+                else drawBaseFrame dm lid+  return $! overlayFrameWithLines onBlank topTrunc mbaseFrame++promptGetKey :: MonadClientUI m+             => ColorMode -> [AttrLine] -> Bool -> [K.KM] -> m K.KM+promptGetKey dm ov onBlank frontKeyKeys = do+  lidV <- viewedLevelUI+  keyPressed <- anyKeyPressed+  lastPlayOld <- getsSession slastPlay+  km <- case lastPlayOld of+    km : kms | not keyPressed && (null frontKeyKeys+                                  || km `elem` frontKeyKeys) -> do+      frontKeyFrame <- drawOverlay dm onBlank ov lidV+      displayFrames lidV [Just frontKeyFrame]+      modifySession $ \sess -> sess {slastPlay = kms}+      Config{configRunStopMsgs} <- getsSession sconfig+      when configRunStopMsgs $ promptAdd $ "Voicing '" <> tshow km <> "'."+      return km+    _ : _ -> do+      -- We can't continue playback, so wipe out old slastPlay, srunning, etc.+      stopPlayBack+      discardPressedKey+      let ov2 = ov `glueLines` [stringToAL "*interrupted*" | keyPressed]+      frontKeyFrame <- drawOverlay dm onBlank ov2 lidV+      connFrontendFrontKey frontKeyKeys frontKeyFrame+    [] -> do+      frontKeyFrame <- drawOverlay dm onBlank ov lidV+      connFrontendFrontKey frontKeyKeys frontKeyFrame+  (seqCurrent, seqPrevious, k) <- getsSession slastRecord+  let slastRecord = (km : seqCurrent, seqPrevious, k)+  modifySession $ \sess -> sess { slastRecord+                                , sdisplayNeeded = False }+  return km++stopPlayBack :: MonadClientUI m => m ()+stopPlayBack = do+  modifySession $ \sess -> sess+    { slastPlay = []+    , slastRecord = ([], [], 0)+        -- Needed to cancel macros that contain apostrophes.+    , swaitTimes = - abs (swaitTimes sess)+    }+  srunning <- getsSession srunning+  case srunning of+    Nothing -> return ()+    Just RunParams{runLeader} -> do+      -- Switch to the original leader, from before the run start,+      -- unless dead or unless the faction never runs with multiple+      -- (but could have the leader changed automatically meanwhile).+      side <- getsClient sside+      fact <- getsState $ (EM.! side) . sfactionD+      arena <- getArenaUI+      s <- getState+      when (memActor runLeader arena s && not (noRunWithMulti fact)) $+        modifyClient $ updateLeader runLeader s+      modifySession (\sess -> sess {srunning = Nothing})++-- | Render animations on top of the current screen frame.+renderFrames :: MonadClientUI m => LevelId -> Animation -> m Frames+renderFrames arena anim = do+  report <- getReportUI+  let truncRep = [renderReport report]+  basicFrame <- drawOverlay ColorFull False truncRep arena+  snoAnim <- getsClient $ snoAnim . sdebugCli+  return $! if fromMaybe False snoAnim+            then [Just basicFrame]+            else renderAnim basicFrame anim++-- | Render and display animations on top of the current screen frame.+animate :: MonadClientUI m => LevelId -> Animation -> m ()+animate arena anim = do+  frames <- renderFrames arena anim+  displayFrames arena frames++fadeOutOrIn :: MonadClientUI m => Bool -> m ()+fadeOutOrIn out = do+  arena <- getArenaUI+  Level{lxsize, lysize} <- getLevel arena+  animMap <- rndToActionForget $ fadeout out 2 lxsize lysize+  animFrs <- renderFrames arena animMap+  displayFrames arena (tail animFrs)  -- no basic frame between fadeout and in

Game/LambdaHack/Client/UI/Frontend.hs view

@@ -1,140 +1,192 @@+{-# LANGUAGE GADTs, KindSignatures, RankNTypes #-} -- | Display game data on the screen and receive user input -- using one of the available raw frontends and derived operations. module Game.LambdaHack.Client.UI.Frontend   ( -- * Connection types-    FrontReq(..), ChanFrontend(..)+    FrontReq(..), ChanFrontend(..), KMP(..)     -- * Re-exported part of the raw frontend   , frontendName-    -- * A derived operation-  , startupF+    -- * Derived operations+  , chanFrontendIO+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , getKey, fchanFrontend, display, defaultMaxFps, microInSec+  , frameTimeoutThread, lazyStartup, nullStartup, seqFrame+#endif   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Control.Concurrent+import Control.Concurrent.Async import qualified Control.Concurrent.STM as STM-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.Text.IO as T-import System.IO+import Control.Monad.ST.Strict+import Data.IORef+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as VM+import Data.Word -import Data.Maybe-import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.UI.Animation-import Game.LambdaHack.Client.UI.Frontend.Chosen+import Game.LambdaHack.Client.UI.Frame+import qualified Game.LambdaHack.Client.UI.Frontend.Chosen as Chosen+import Game.LambdaHack.Client.UI.Frontend.Common+import qualified Game.LambdaHack.Client.UI.Frontend.Teletype as Teletype+import qualified Game.LambdaHack.Client.UI.Key as K+import Game.LambdaHack.Client.UI.Overlay import Game.LambdaHack.Common.ClientOptions+import qualified Game.LambdaHack.Common.Color as Color+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray --- | The instructions sent by clients to the raw frontend over a channel.-data FrontReq =-    FrontNormalFrame {frontFrame :: !SingleFrame}-      -- ^ show a frame-  | FrontDelay-      -- ^ perform a single explicit delay-  | FrontKey {frontKM :: ![K.KM], frontFr :: !SingleFrame}-      -- ^ flush frames, possibly show fadeout/fadein and ask for a keypress-  | FrontSlides { frontClear   :: ![K.KM]-                , frontSlides  :: ![SingleFrame]-                , frontFromTop :: !(Maybe Bool) }-      -- ^ show a whole slideshow without interleaving with other clients-  | FrontAutoYes !Bool-      -- ^ set the frontend option for auto-answering prompts-  | FrontFinish-      -- ^ exit frontend loop+-- | The instructions sent by clients to the raw frontend.+data FrontReq :: * -> * where+  -- | Show a frame.+  FrontFrame :: {frontFrame :: !FrameForall} -> FrontReq ()+  -- | Perform an explicit delay of the given length.+  FrontDelay :: !Int -> FrontReq ()+  -- | Flush frames, display a frame and ask for a keypress.+  FrontKey :: { frontKeyKeys  :: ![K.KM]+              , frontKeyFrame :: !FrameForall } -> FrontReq KMP+  -- | Inspect the fkeyPressed MVar.+  FrontPressed :: FrontReq Bool+  -- | discard a key in the queue, if any.+  FrontDiscard :: FrontReq ()+  -- | Add a key to the queue.+  FrontAdd :: KMP -> FrontReq ()+  -- | set in the frontend that it should auto-answer prompts.+  FrontAutoYes :: Bool -> FrontReq ()+  -- | shut the frontend down.+  FrontShutdown :: FrontReq ()  -- | Connection channel between a frontend and a client. Frontend acts--- as a server, serving keys, when given frames to display.-data ChanFrontend = ChanFrontend-  { responseF :: !(STM.TQueue K.KM)-  , requestF  :: !(STM.TQueue FrontReq)-  }+-- as a server, serving keys, etc., when given frames to display.+newtype ChanFrontend = ChanFrontend (forall a. FrontReq a -> IO a) --- | Initialize the frontend and apply the given continuation to the results--- of the initialization.-startupF :: DebugModeCli  -- ^ debug settings-         -> (Maybe (MVar ())-             -> (ChanFrontend -> IO ())-             -> IO ())  -- ^ continuation-         -> IO ()-startupF dbg cont =-  (if sfrontendNull dbg then nullStartup-   else if sfrontendStd dbg then stdStartup-        else chosenStartup) dbg $ \fs -> do-    cont (fescMVar fs) (loopFrontend fs)-    let debugPrint t = when (sdbgMsgCli dbg) $ do-          T.hPutStrLn stderr t-          hFlush stderr-    debugPrint "Server shuts down"+data FSession = FSession+  { fautoYesRef   :: !(IORef Bool)+  , fasyncTimeout :: !(Async ())+  , fdelay        :: !(MVar Int)+  }  -- | Display a prompt, wait for any of the specified keys (for any key, -- if the list is empty). Repeat if an unexpected key received.-promptGetKey :: RawFrontend -> [K.KM] -> SingleFrame -> IO K.KM-promptGetKey fs [] frame = fpromptGetKey fs frame-promptGetKey fs keys frame = do-  km <- fpromptGetKey fs frame-  if km{K.pointer=Nothing} `elem` keys-    then return km-    else promptGetKey fs keys frame--getConfirmGeneric :: Bool -> RawFrontend -> [K.KM] -> SingleFrame -> IO K.KM-getConfirmGeneric autoYes fs clearKeys frame = do-  let DebugModeCli{sdisableAutoYes} = fdebugCli fs-  if autoYes && not sdisableAutoYes then do-    fdisplay fs (Just frame)-    return K.spaceKM+getKey :: DebugModeCli -> FSession -> RawFrontend -> [K.KM] -> FrameForall+       -> IO KMP+getKey sdebugCli fs rf@RawFrontend{fchanKey} keys frame = do+  autoYes <- readIORef $ fautoYesRef fs+  if autoYes && (null keys || K.spaceKM `elem` keys) then do+    display rf frame+    return $! KMP{kmpKeyMod = K.spaceKM, kmpPointer=originPoint}   else do-    let extraKeys = [K.spaceKM, K.escKM, K.pgupKM, K.pgdnKM]-    promptGetKey fs (clearKeys ++ extraKeys) frame+    -- Wait until timeout is up, not to skip the last frame of animation.+    display rf frame+    kmp <- STM.atomically $ STM.readTQueue fchanKey+    if null keys || kmpKeyMod kmp `elem` keys+    then return kmp+    else getKey sdebugCli fs rf keys frame --- Read UI requests from the client and send them to the frontend,-loopFrontend :: RawFrontend -> ChanFrontend -> IO ()-loopFrontend fs ChanFrontend{..} = loop False- where-  writeKM :: K.KM -> IO ()-  writeKM km = STM.atomically $ STM.writeTQueue responseF km+-- | Read UI requests from the client and send them to the frontend,+fchanFrontend :: DebugModeCli -> FSession -> RawFrontend -> ChanFrontend+fchanFrontend sdebugCli fs@FSession{..} rf =+  ChanFrontend $ \req -> case req of+    FrontFrame{..} -> display rf frontFrame+    FrontDelay k -> modifyMVar_ fdelay $ return . (+ k)+    FrontKey{..} -> getKey sdebugCli fs rf frontKeyKeys frontKeyFrame+    FrontPressed -> do+      noKeysPending <- STM.atomically $ STM.isEmptyTQueue (fchanKey rf)+      return $! not noKeysPending+    FrontDiscard ->+      void $ STM.atomically $ STM.tryReadTQueue (fchanKey rf)+    FrontAdd kmp -> STM.atomically $ STM.writeTQueue (fchanKey rf) kmp+    FrontAutoYes b -> writeIORef fautoYesRef b+    FrontShutdown -> do+      cancel fasyncTimeout+      -- In case the last frame display is pending:+      void $ tryTakeMVar $ fshowNow rf+      fshutdown rf -  loop :: Bool -> IO ()-  loop autoYes = do-    efr <- STM.atomically $ STM.readTQueue requestF-    case efr of-      FrontNormalFrame{..} -> do-        fdisplay fs (Just frontFrame)-        loop autoYes-      FrontDelay -> do-        fdisplay fs Nothing-        loop autoYes-      FrontKey{..} -> do-        km <- promptGetKey fs frontKM frontFr-        writeKM km-        loop autoYes-      FrontSlides{frontSlides = []} -> do-        -- Hack.-        fsyncFrames fs-        writeKM K.spaceKM-        loop autoYes-      FrontSlides{..} -> do-        let displayFrs frs srf =-              case frs of-                [] -> assert `failure` "null slides" `twith` frs-                [x] | isNothing frontFromTop -> do-                  fdisplay fs (Just x)-                  writeKM K.spaceKM-                x : xs -> do-                  K.KM{..} <- getConfirmGeneric autoYes fs frontClear x-                  case key of-                    K.Esc -> writeKM K.escKM-                    K.PgUp -> case srf of-                      [] -> displayFrs frs srf-                      y : ys -> displayFrs (y : frs) ys-                    K.Space -> case xs of-                      [] -> writeKM K.escKM  -- hack-                      _ -> displayFrs xs (x : srf)-                    _ -> case xs of  -- K.PgDn and any other permitted key-                      [] -> displayFrs frs srf-                      _ -> displayFrs xs (x : srf)-        case (frontFromTop, reverse frontSlides) of-          (Just False, r : rs) -> displayFrs [r] rs-          _ -> displayFrs frontSlides []-        loop autoYes-      FrontAutoYes b ->-        loop b-      FrontFinish ->-        return ()-        -- Do not loop again.+display :: RawFrontend -> FrameForall -> IO ()+display rf@RawFrontend{fshowNow} frontFrame = do+  let lxsize = fst normalLevelBound + 1+      lysize = snd normalLevelBound + 1+      canvasLength = lysize + 3+      new :: forall s. ST s (G.Mutable U.Vector s Word32)+      new = do+        v <- VM.replicate (lxsize * canvasLength)+                          (Color.attrCharW32 Color.spaceAttrW32)+        unFrameForall frontFrame v+        return v+      singleFrame = PointArray.Array lxsize canvasLength (U.create new)+  putMVar fshowNow () -- 1. wait for permission to display; 3. ack+  fdisplay rf $ SingleFrame singleFrame++defaultMaxFps :: Int+defaultMaxFps = 30++microInSec :: Int+microInSec = 1000000++-- This thread is canceled forcefully, because the @threadDelay@+-- may be much longer than an acceptable shutdown time.+frameTimeoutThread :: Int -> MVar Int -> RawFrontend -> IO ()+frameTimeoutThread delta fdelay RawFrontend{..} = do+  let loop = do+        threadDelay delta+        let delayLoop = do+              delay <- readMVar fdelay+              when (delay > 0) $ do+                threadDelay $ delta * delay+                modifyMVar_ fdelay $ return . subtract delay+                delayLoop+        delayLoop+        let showFrameAndRepeatIfKeys = do+              -- @fshowNow@ is full at this point, unless @saveKM@ emptied it,+              -- in which case we wait below until @display@ fills it+              takeMVar fshowNow  -- 2. permit display+              -- @fshowNow@ is ever empty only here, unless @saveKM@ empties it+              readMVar fshowNow  -- 4. wait for ack before starting delay+              -- @fshowNow@ is full at this point+              noKeysPending <- STM.atomically $ STM.isEmptyTQueue fchanKey+              unless noKeysPending $ do+                void $ swapMVar fdelay 0  -- cancel delays lest they accumulate+                showFrameAndRepeatIfKeys+        showFrameAndRepeatIfKeys+        loop+  loop++-- | The name of the chosen frontend.+frontendName :: String+frontendName = Chosen.frontendName++lazyStartup :: IO RawFrontend+lazyStartup = createRawFrontend (\_ -> return ()) (return ())++nullStartup :: IO RawFrontend+nullStartup = createRawFrontend seqFrame (return ())++seqFrame :: SingleFrame -> IO ()+seqFrame SingleFrame{singleFrame} =+  let seqAttr () attr = Color.colorToRGB (Color.fgFromW32 attr)+                        `seq` Color.bgFromW32 attr+                        `seq` Color.charFromW32 attr == ' '+                        `seq` ()+  in return $! PointArray.foldlA' seqAttr () singleFrame++chanFrontendIO :: DebugModeCli -> IO ChanFrontend+chanFrontendIO sdebugCli = do+  let startup | sfrontendNull sdebugCli = nullStartup+              | sfrontendLazy sdebugCli = lazyStartup+              | sfrontendTeletype sdebugCli = Teletype.startup sdebugCli+              | otherwise = Chosen.startup sdebugCli+      maxFps = fromMaybe defaultMaxFps $ smaxFps sdebugCli+      delta = max 1 $ microInSec `div` maxFps+  rf <- startup+  fautoYesRef <- newIORef $ not $ sdisableAutoYes sdebugCli+  fdelay <- newMVar 0+  fasyncTimeout <- async $ frameTimeoutThread delta fdelay rf+  -- Warning: not linking @fasyncTimeout@, so it'd better not crash.+  let fs = FSession{..}+  return $ fchanFrontend sdebugCli fs rf

Game/LambdaHack/Client/UI/Frontend/Chosen.hs view

@@ -1,68 +1,21 @@-{-# LANGUAGE CPP #-} -- | Re-export the operations of the chosen raw frontend -- (determined at compile time with cabal flags). module Game.LambdaHack.Client.UI.Frontend.Chosen-  ( RawFrontend(..), chosenStartup, stdStartup, nullStartup-  , frontendName+  ( startup, frontendName   ) where -import Control.Concurrent-import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.UI.Animation (SingleFrame (..))-import Game.LambdaHack.Common.ClientOptions+import Prelude () -#ifdef VTY-import qualified Game.LambdaHack.Client.UI.Frontend.Vty as Chosen-#elif CURSES-import qualified Game.LambdaHack.Client.UI.Frontend.Curses as Chosen+#ifdef USE_CURSES+import Game.LambdaHack.Client.UI.Frontend.Curses+#elif USE_VTY+import Game.LambdaHack.Client.UI.Frontend.Vty+#elif USE_GTK+import Game.LambdaHack.Client.UI.Frontend.Gtk+#elif USE_SDL+import Game.LambdaHack.Client.UI.Frontend.Sdl+#elif USE_BROWSER+import Game.LambdaHack.Client.UI.Frontend.Dom #else-import qualified Game.LambdaHack.Client.UI.Frontend.Gtk as Chosen+import Game.LambdaHack.Client.UI.Frontend.Gtk #endif--import qualified Game.LambdaHack.Client.UI.Frontend.Std as Std---- | The name of the chosen frontend.-frontendName :: String-frontendName = Chosen.frontendName--data RawFrontend = RawFrontend-  { fdisplay      :: Maybe SingleFrame -> IO ()-  , fpromptGetKey :: SingleFrame -> IO K.KM-  , fsyncFrames   :: IO ()-  , fescMVar      :: !(Maybe (MVar ()))-  , fdebugCli     :: !DebugModeCli-  }--chosenStartup :: DebugModeCli -> (RawFrontend -> IO ()) -> IO ()-chosenStartup fdebugCli cont =-  Chosen.startup fdebugCli $ \fs ->-    cont RawFrontend-      { fdisplay = Chosen.fdisplay fs-      , fpromptGetKey = Chosen.fpromptGetKey fs-      , fsyncFrames = Chosen.fsyncFrames fs-      , fescMVar = Chosen.sescMVar fs-      , fdebugCli-      }--stdStartup :: DebugModeCli -> (RawFrontend -> IO ()) -> IO ()-stdStartup fdebugCli cont =-  Std.startup fdebugCli $ \fs ->-    cont RawFrontend-      { fdisplay = Std.fdisplay fs-      , fpromptGetKey = Std.fpromptGetKey fs-      , fsyncFrames = Std.fsyncFrames fs-      , fescMVar = Std.sescMVar fs-      , fdebugCli-      }--nullStartup :: DebugModeCli -> (RawFrontend -> IO ()) -> IO ()-nullStartup fdebugCli cont =-  -- Std used to fork (async) the server thread, to avoid bound thread overhead.-  Std.startup fdebugCli $ \_ ->-    cont RawFrontend-      { fdisplay = \_ -> return ()-      , fpromptGetKey = \_ -> return K.escKM-      , fsyncFrames = return ()-      , fescMVar = Nothing-      , fdebugCli-      }

+ Game/LambdaHack/Client/UI/Frontend/Common.hs view

@@ -0,0 +1,71 @@+-- | Screen frames and animations.+module Game.LambdaHack.Client.UI.Frontend.Common+  ( RawFrontend(..), KMP(..)+  , startupBound, createRawFrontend, resetChanKey, saveKMP+  , modifierTranslate+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Control.Concurrent+import Control.Concurrent.Async+import qualified Control.Concurrent.STM as STM++import Game.LambdaHack.Client.UI.Frame+import qualified Game.LambdaHack.Client.UI.Key as K+import Game.LambdaHack.Common.Point++data KMP = KMP { kmpKeyMod  :: !K.KM+               , kmpPointer :: !Point }++data RawFrontend = RawFrontend+  { fdisplay  :: !(SingleFrame -> IO ())+  , fshutdown :: !(IO ())+  , fshowNow  :: !(MVar ())+  , fchanKey  :: !(STM.TQueue KMP)+  }++startupBound :: (MVar RawFrontend -> IO ()) -> IO RawFrontend+startupBound k = do+  rfMVar <- newEmptyMVar+  a <- asyncBound $ k rfMVar+  link a+  takeMVar rfMVar++createRawFrontend :: (SingleFrame -> IO ()) -> IO () -> IO RawFrontend+createRawFrontend fdisplay fshutdown = do+  -- Set up the channel for keyboard input.+  fchanKey <- STM.atomically STM.newTQueue+  -- Create the session record.+  fshowNow <- newEmptyMVar+  return $! RawFrontend+    { fdisplay+    , fshutdown+    , fshowNow+    , fchanKey+    }++-- | Empty the keyboard channel.+resetChanKey :: STM.TQueue KMP -> IO ()+resetChanKey fchanKey = do+  res <- STM.atomically $ STM.tryReadTQueue fchanKey+  when (isJust res) $ resetChanKey fchanKey++saveKMP :: RawFrontend -> K.Modifier -> K.Key -> Point -> IO ()+saveKMP !rf !modifier !key !kmpPointer = do+  -- Instantly show any frame waiting for display.+  void $ tryTakeMVar $ fshowNow rf+  let kmp = KMP{kmpKeyMod = K.KM{..}, kmpPointer}+  unless (key == K.DeadKey) $+    -- Store the key in the channel.+    STM.atomically $ STM.writeTQueue (fchanKey rf) kmp++-- | Translates modifiers to our own encoding.+modifierTranslate :: Bool -> Bool -> Bool -> Bool -> K.Modifier+modifierTranslate modCtrl modShift modAlt modMeta+  | modCtrl = K.Control+  | modAlt || modMeta = K.Alt+  | modShift = K.Shift+  | otherwise = K.NoModifier

Game/LambdaHack/Client/UI/Frontend/Curses.hs view

@@ -2,37 +2,33 @@ -- due to the limitations of the curses library (keys, colours, last character -- of the last line). module Game.LambdaHack.Client.UI.Frontend.Curses-  ( -- * Session data type for the frontend-    FrontendSession(sescMVar)-    -- * The output and input operations-  , fdisplay, fpromptGetKey, fsyncFrames-    -- * Frontend administration tools-  , frontendName, startup+  ( startup, frontendName   ) where -import Control.Concurrent+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Control.Concurrent.Async-import qualified Control.Exception as Ex hiding (handle)-import Control.Exception.Assert.Sugar-import Control.Monad import Data.Char (chr, ord) import qualified Data.Map.Strict as M import qualified UI.HSCurses.Curses as C import qualified UI.HSCurses.CursesHelper as C -import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.UI.Animation+import Game.LambdaHack.Client.UI.Frame+import Game.LambdaHack.Client.UI.Frontend.Common+import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Common.ClientOptions import qualified Game.LambdaHack.Common.Color as Color-import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray  -- | Session data maintained by the frontend. data FrontendSession = FrontendSession-  { swin      :: !C.Window  -- ^ the window to draw to-  , sstyles   :: !(M.Map Color.Attr C.CursesStyle)+  { swin    :: !C.Window  -- ^ the window to draw to+  , sstyles :: !(M.Map (Color.Color, Color.Color) C.CursesStyle)       -- ^ map from fore/back colour pairs to defined curses styles-  , sescMVar  :: !(Maybe (MVar ()))-  , sdebugCli :: !DebugModeCli  -- ^ client configuration   }  -- | The name of the frontend.@@ -40,63 +36,78 @@ frontendName = "curses"  -- | Starts the main program loop using the frontend input and output.-startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()-startup sdebugCli k = do+startup :: DebugModeCli -> IO RawFrontend+startup _sdebugCli = do   C.start---  C.keypad C.stdScr False  -- TODO: may help to fix xterm keypad on Ubuntu   void $ C.cursSet C.CursorInvisible-  let s = [ (Color.Attr{fg, bg}, C.Style (toFColor fg) (toBColor bg))-          | fg <- [minBound..maxBound],-            -- No more color combinations possible: 16*4, 64 is max.-            bg <- Color.legalBG ]+  let s = [ ((fg, bg), C.Style (toFColor fg) (toBColor bg))+          | -- No more color combinations possible: 16*4, 64 is max.+            fg <- [minBound..maxBound]+          , bg <- [Color.Black, Color.Blue, Color.White, Color.BrBlack] ]   nr <- C.colorPairs   when (nr < length s) $     C.end >> (assert `failure` "terminal has too few color pairs" `twith` nr)   let (ks, vs) = unzip s   ws <- C.convertStyles vs   let swin = C.stdScr-      sstyles = M.fromList (zip ks ws)-  a <- async $ k FrontendSession{sescMVar = Nothing, ..} `Ex.finally` C.end-  wait a+      sstyles = M.fromDistinctAscList (zip ks ws)+      sess = FrontendSession{..}+  rf <- createRawFrontend (display sess) shutdown+  let storeKeys :: IO ()+      storeKeys = do+        K.KM{..} <- keyTranslate <$> C.getKey C.refresh+        saveKMP rf modifier key originPoint+        storeKeys+  void $ async storeKeys+  return $! rf +shutdown :: IO ()+shutdown = C.end+ -- | Output to the screen via the frontend.-fdisplay :: FrontendSession    -- ^ frontend session data-         -> Maybe SingleFrame  -- ^ the screen frame to draw-         -> IO ()-fdisplay _ Nothing = return ()-fdisplay FrontendSession{..}  (Just rawSF) = do-  let SingleFrame{sfLevel} = overlayOverlay rawSF+display :: FrontendSession    -- ^ frontend session data+        -> SingleFrame  -- ^ the screen frame to draw+        -> IO ()+display FrontendSession{..} SingleFrame{singleFrame} = do   -- let defaultStyle = C.defaultCursesStyle   -- Terminals with white background require this:-  let defaultStyle = sstyles M.! Color.defAttr+  let defaultStyle = sstyles M.! (Color.defFG, Color.Black)   C.erase   C.setStyle defaultStyle   -- We need to remove the last character from the status line,   -- because otherwise it would overflow a standard size xterm window,   -- due to the curses historical limitations.-  let sfLevelDecoded = map decodeLine sfLevel-      level = init sfLevelDecoded ++ [init $ last sfLevelDecoded]+  let sf = chunk $ map Color.attrCharFromW32+                 $ PointArray.toListA singleFrame+      level = init sf ++ [init $ last sf]       nm = zip [0..] $ map (zip [0..]) level-  sequence_ [ C.setStyle (M.findWithDefault defaultStyle acAttr sstyles)-              >> C.mvWAddStr swin (y + 1) x [acChar]-            | (y, line) <- nm, (x, Color.AttrChar{..}) <- line ]+      lxsize = fst normalLevelBound + 1+      chunk [] = []+      chunk l = let (ch, r) = splitAt lxsize l+                in ch : chunk r+  sequence_ [ C.setStyle (M.findWithDefault defaultStyle acAttr2 sstyles)+              >> C.mvWAddStr swin y x [acChar]+            | (y, line) <- nm+            , (x, Color.AttrChar{acAttr=Color.Attr{..}, ..}) <- line+            , let acAttr2 = case bg of+                    Color.HighlightNone -> (fg, Color.Black)+                    Color.HighlightRed -> (Color.Black, Color.defFG)+                    Color.HighlightBlue ->+                      if fg /= Color.Blue+                      then (fg, Color.Blue)+                      else (fg, Color.BrBlack)+                    Color.HighlightYellow ->+                      if fg /= Color.Brown+                      then (fg, Color.Brown)+                      else (fg, Color.defFG)+                    Color.HighlightGrey ->+                      if fg /= Color.BrBlack+                      then (fg, Color.BrBlack)+                      else (fg, Color.defFG) ]   C.refresh --- | Input key via the frontend.-nextEvent :: IO K.KM-nextEvent = keyTranslate `fmap` C.getKey C.refresh--fsyncFrames :: FrontendSession -> IO ()-fsyncFrames _ = return ()---- | Display a prompt, wait for any key.-fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM-fpromptGetKey sess frame = do-  fdisplay sess $ Just frame-  nextEvent- keyTranslate :: C.Key -> K.KM-keyTranslate e = (\(key, modifier) -> K.toKM modifier key) $+keyTranslate e = (\(key, modifier) -> K.KM modifier key) $   case e of     C.KeyChar '\ESC' -> (K.Esc,     K.NoModifier)     C.KeyExit        -> (K.Esc,     K.NoModifier)@@ -122,8 +133,6 @@     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.     C.KeyChar c       -- This case needs to be considered after Tab, since, apparently,       -- on some terminals ^i == Tab and Tab is more important for us.@@ -133,9 +142,9 @@         -- Movement keys are more important than leader picking,         -- so disabling the latter and interpreting the keypad numbers         -- as movement:-      | c `elem` ['1'..'9'] -> (K.KP c,              K.NoModifier)-      | otherwise           -> (K.Char c,            K.NoModifier)-    _                       -> (K.Unknown (tshow e), K.NoModifier)+      | c `elem` ['1'..'9'] -> (K.KP c, K.NoModifier)+      | otherwise           -> (K.Char c, K.NoModifier)+    _                       -> (K.Unknown (show e), K.NoModifier)  toFColor :: Color.Color -> C.ForegroundColor toFColor Color.Black     = C.BlackF

+ Game/LambdaHack/Client/UI/Frontend/Dom.hs view

@@ -0,0 +1,274 @@+-- | Text frontend running in Browser.+module Game.LambdaHack.Client.UI.Frontend.Dom+  ( startup, frontendName+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Control.Concurrent+import qualified Control.Monad.IO.Class as IO+import Control.Monad.Trans.Reader (ask)+import qualified Data.Char as Char+import Data.IORef+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import Data.Word (Word32)++import GHCJS.DOM (currentDocument, currentWindow)+import GHCJS.DOM.CSSStyleDeclaration (setProperty)+import GHCJS.DOM.Document (createElement, getBodyUnchecked)+import GHCJS.DOM.Element (Element (Element), getStyle, setInnerHTML)+import GHCJS.DOM.EventM (EventM, mouseAltKey, mouseButton, mouseCtrlKey,+                         mouseMetaKey, mouseShiftKey, on, on, preventDefault,+                         stopPropagation)+import GHCJS.DOM.GlobalEventHandlers (contextMenu, keyDown, mouseUp, wheel)+import GHCJS.DOM.HTMLCollection (itemUnsafe)+import GHCJS.DOM.HTMLTableElement (HTMLTableElement (HTMLTableElement), getRows,+                                   setCellPadding, setCellSpacing)+import GHCJS.DOM.HTMLTableRowElement (HTMLTableRowElement (HTMLTableRowElement),+                                      getCells)+import GHCJS.DOM.KeyboardEvent (getAltGraphKey, getAltKey, getCtrlKey, getKey,+                                getMetaKey, getShiftKey)+import GHCJS.DOM.Node (appendChild_, replaceChild_, setTextContent)+import GHCJS.DOM.NonElementParentNode (getElementByIdUnsafe)+import GHCJS.DOM.RequestAnimationFrameCallback+import GHCJS.DOM.Types (CSSStyleDeclaration, DOM,+                        HTMLDivElement (HTMLDivElement),+                        HTMLTableCellElement (HTMLTableCellElement),+                        IsMouseEvent, Window, runDOM, unsafeCastTo)+import GHCJS.DOM.WheelEvent (getDeltaY)+import GHCJS.DOM.Window (requestAnimationFrame_)++import Game.LambdaHack.Client.UI.Frame+import Game.LambdaHack.Client.UI.Frontend.Common+import qualified Game.LambdaHack.Client.UI.Key as K+import Game.LambdaHack.Common.ClientOptions+import qualified Game.LambdaHack.Common.Color as Color+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray++-- | Session data maintained by the frontend.+data FrontendSession = FrontendSession+  { scurrentWindow :: !Window+  , scharCells     :: !(V.Vector (HTMLTableCellElement, CSSStyleDeclaration))+  , spreviousFrame :: !(IORef SingleFrame)+  }++extraBlankMargin :: Int+extraBlankMargin = 1++-- | The name of the frontend.+frontendName :: String+frontendName = "browser"++-- | Starts the main program loop using the frontend input and output.+startup :: DebugModeCli -> IO RawFrontend+startup sdebugCli = do+  rfMVar <- newEmptyMVar+  flip runDOM undefined $ runWeb sdebugCli rfMVar+  takeMVar rfMVar++runWeb :: DebugModeCli -> MVar RawFrontend -> DOM ()+runWeb sdebugCli@DebugModeCli{..} rfMVar = do+  -- Init the document.+  Just doc <- currentDocument+  Just scurrentWindow <- currentWindow+  body <- getBodyUnchecked doc+  pageStyle <- getStyle body+  setProp pageStyle "background-color" (Color.colorToRGB Color.Black)+  setProp pageStyle "color" (Color.colorToRGB Color.White)+  divBlockRaw <- createElement doc ("div" :: Text)+  divBlock <- unsafeCastTo HTMLDivElement divBlockRaw+  divStyle <- getStyle divBlock+  setProp divStyle "text-align" "center"+  let lxsize = fst normalLevelBound + 1+      lysize = snd normalLevelBound + 4+      cell = "<td>" ++ [Char.chr 160]+      row = "<tr>" ++ concat (replicate (lxsize + extraBlankMargin * 2) cell)+      rows = concat (replicate (lysize + extraBlankMargin * 2) row)+  tableElemRaw <- createElement doc ("table" :: Text)+  tableElem <- unsafeCastTo HTMLTableElement tableElemRaw+  appendChild_ divBlock tableElem+  scharStyle <- getStyle tableElem+  -- Speed: http://www.w3.org/TR/CSS21/tables.html#fixed-table-layout+  setProp scharStyle "table-layout" "fixed"+  setProp scharStyle "font-family" "lambdaHackFont"+  setProp scharStyle "font-size" $ tshow (fromJust sfontSize) <> "px"+  setProp scharStyle "font-weight" "bold"+  setProp scharStyle "outline" "1px solid grey"+  setProp scharStyle "border-collapse" "collapse"+  setProp scharStyle "margin-left" "auto"+  setProp scharStyle "margin-right" "auto"+  -- Get rid of table spacing. Tons of spurious hacks just in case.+  setCellPadding tableElem (Just ("0" :: Text))+  setCellSpacing tableElem (Just ("0" :: Text))+  setProp scharStyle "padding" "0 0 0 0"+  setProp scharStyle "border-spacing" "0"+  setProp scharStyle "border" "none"+  -- Create the session record.+  setInnerHTML tableElem $ Just rows+  scharCells <- flattenTable tableElem+  spreviousFrame <- newIORef blankSingleFrame+  let sess = FrontendSession{..}+  rf <- IO.liftIO $ createRawFrontend (display sdebugCli sess) shutdown+  let readMod = do+        modCtrl <- ask >>= getCtrlKey+        modShift <- ask >>= getShiftKey+        modAlt <- ask >>= getAltKey+        modMeta <- ask >>= getMetaKey+        modAltG <- ask >>= getAltGraphKey+        return $! modifierTranslate+                    modCtrl modShift (modAlt || modAltG) modMeta+  void $ doc `on` keyDown $ do+    keyId <- ask >>= getKey+    modifier <- readMod+--  This is currently broken at least for Shift-F1, etc., so won't be used:+--    keyLoc <- ask >>= getKeyLocation+--    let onKeyPad = case keyLoc of+--          3 {-KEY_LOCATION_NUMPAD-} -> True+--          _ -> False+    let key = K.keyTranslateWeb keyId (modifier == K.Shift)+        modifierNoShift =  -- to prevent S-!, etc.+          if modifier == K.Shift then K.NoModifier else modifier+    -- IO.liftIO $ do+    --   putStrLn $ "keyId: " ++ keyId+    --   putStrLn $ "key: " ++ K.showKey key+    --   putStrLn $ "modifier: " ++ show modifier+    when (key == K.Esc) $ IO.liftIO $ resetChanKey (fchanKey rf)+    IO.liftIO $ saveKMP rf modifierNoShift key originPoint+    -- Pass through C-+ and others, disable special behaviour on Tab.+    when (modifier `elem` [K.NoModifier, K.Shift, K.Control]) $ do+      preventDefault+      stopPropagation+  -- Handle mouseclicks, per-cell.+  let setupMouse i a =+        let Point x y = PointArray.punindex lxsize i+        in handleMouse rf a x y+  V.imapM_ setupMouse scharCells+  -- Display at the end to avoid redraw. Replace "Please wait".+  pleaseWait <- getElementByIdUnsafe doc ("pleaseWait" :: Text)+  replaceChild_ body divBlock pleaseWait+  IO.liftIO $ putMVar rfMVar rf+    -- send to client only after the whole webpage is set up+    -- because there is no @mainGUI@ to start accepting++shutdown :: IO ()+shutdown = return () -- nothing to clean up++setProp :: CSSStyleDeclaration -> Text -> Text -> DOM ()+setProp style propRef propValue =+  setProperty style propRef (Just propValue) (Nothing :: Maybe Text)++-- | Let each table cell handle mouse events inside.+handleMouse :: RawFrontend+            -> (HTMLTableCellElement, CSSStyleDeclaration) -> Int -> Int+            -> DOM ()+handleMouse rf (cell, _) cx cy = do+  let readMod :: IsMouseEvent e => EventM HTMLTableCellElement e K.Modifier+      readMod = do+        modCtrl <- mouseCtrlKey+        modShift <- mouseShiftKey+        modAlt <- mouseAltKey+        modMeta <- mouseMetaKey+        return $! modifierTranslate modCtrl modShift modAlt modMeta+      saveWheel = do+        wheelY <- ask >>= getDeltaY+        modifier <- readMod+        let mkey = if | wheelY < -0.01 -> Just K.WheelNorth+                      | wheelY > 0.01 -> Just K.WheelSouth+                      | otherwise -> Nothing  -- probably a glitch+            pointer = Point cx cy+        maybe (return ())+              (\key -> IO.liftIO $ saveKMP rf modifier key pointer) mkey+      saveMouse = do+        -- https://hackage.haskell.org/package/ghcjs-dom-0.2.1.0/docs/GHCJS-DOM-EventM.html+        but <- mouseButton+        modifier <- readMod+        let key = case but of+              0 -> K.LeftButtonRelease+              1 -> K.MiddleButtonRelease+              2 -> K.RightButtonRelease  -- not handled in contextMenu+              _ -> K.LeftButtonRelease  -- any other is alternate left+            pointer = Point cx cy+        -- IO.liftIO $ putStrLn $+        --   "m: " ++ show but ++ show modifier ++ show pointer+        IO.liftIO $ saveKMP rf modifier key pointer+  void $ cell `on` wheel $ do+    saveWheel+    preventDefault+    stopPropagation+  void $ cell `on` contextMenu $ do+    preventDefault+    stopPropagation+  void $ cell `on` mouseUp $ do+    saveMouse+    preventDefault+    stopPropagation++-- | Get the list of all cells of an HTML table.+flattenTable :: HTMLTableElement+             -> DOM (V.Vector (HTMLTableCellElement, CSSStyleDeclaration))+flattenTable table = do+  let lxsize = fst normalLevelBound + 1+      lysize = snd normalLevelBound + 4+  rows <- getRows table+  let f y = do+        rowsItem <- itemUnsafe rows y+        unsafeCastTo HTMLTableRowElement rowsItem+  lrow <- mapM f [toEnum extraBlankMargin+                  .. toEnum (lysize - 1 + extraBlankMargin)]+  let getC :: HTMLTableRowElement+           -> DOM [(HTMLTableCellElement, CSSStyleDeclaration)]+      getC row = do+        cells <- getCells row+        let g x = do+              cellsItem <- itemUnsafe cells x+              cell <- unsafeCastTo HTMLTableCellElement cellsItem+              style <- getStyle cell+              return (cell, style)+        mapM g [toEnum extraBlankMargin+                .. toEnum (lxsize - 1 + extraBlankMargin)]+  lrc <- mapM getC lrow+  return $! V.fromListN (lxsize * lysize) $ concat lrc++-- | Output to the screen via the frontend.+display :: DebugModeCli+        -> FrontendSession  -- ^ frontend session data+        -> SingleFrame  -- ^ the screen frame to draw+        -> IO ()+display DebugModeCli{scolorIsBold}+        FrontendSession{..}+        curFrame = flip runDOM undefined $ do+  let setChar :: Int -> Word32 -> Word32 -> DOM ()+      setChar i w wPrev = unless (w == wPrev) $ do+        let Color.AttrChar{acAttr=Color.Attr{..}, acChar} =+              Color.attrCharFromW32 $ Color.AttrCharW32 w+            (cell, style) = scharCells V.! i+        case Char.ord acChar of+          32 -> setTextContent cell $ Just [Char.chr 160]+          183 | fg <= Color.BrBlack && scolorIsBold == Just True ->+            setTextContent cell $ Just [Char.chr 8901]+          _  -> setTextContent cell $ Just [acChar]+        setProp style "color" $ Color.colorToRGB fg+        case bg of+          Color.HighlightNone ->+            setProp style "border-color" "transparent"+          Color.HighlightRed ->+            setProp style "border-color" $ Color.colorToRGB Color.Red+          Color.HighlightBlue ->+            setProp style "border-color" $ Color.colorToRGB Color.Blue+          Color.HighlightYellow ->+            setProp style "border-color" $ Color.colorToRGB Color.BrYellow+          Color.HighlightGrey ->+            setProp style "border-color" $ Color.colorToRGB Color.BrBlack+  prevFrame <- readIORef spreviousFrame+  writeIORef spreviousFrame curFrame+  -- Sync, no point mutitasking threads in the single-threaded JS.+  callback <- newRequestAnimationFrameCallback $ \_ ->+    U.izipWithM_ setChar (PointArray.avector $ singleFrame curFrame)+                         (PointArray.avector $ singleFrame prevFrame)+  -- This ensures no frame redraws while callback executes.+  requestAnimationFrame_ scurrentWindow callback

Game/LambdaHack/Client/UI/Frontend/Gtk.hs view

@@ -1,179 +1,152 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-unused-do-bind #-}+#endif -- | Text frontend based on Gtk. module Game.LambdaHack.Client.UI.Frontend.Gtk-  ( -- * Session data type for the frontend-    FrontendSession(sescMVar)-    -- * The output and input operations-  , fdisplay, fpromptGetKey, fsyncFrames-    -- * Frontend administration tools-  , frontendName, startup+  ( startup, frontendName+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , startupFun, shutdown, doAttr, extraAttr, display+#endif   ) where -import Control.Applicative+import Prelude ()++import Game.LambdaHack.Common.Prelude hiding (Alt)+ import Control.Concurrent-import Control.Concurrent.Async-import qualified Control.Concurrent.STM as STM-import qualified Control.Exception as Ex hiding (handle)-import Control.Monad-import Control.Monad.Reader-import qualified Data.ByteString.Char8 as BS+import qualified Control.Monad.IO.Class as IO+import qualified Data.IntMap.Strict as IM import Data.IORef-import Data.List-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.String (IsString (..)) import qualified Data.Text as T+import qualified Game.LambdaHack.Common.PointArray as PointArray import Graphics.UI.Gtk hiding (Point)-import System.Time+import System.Exit (exitFailure) -import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.UI.Animation+import Game.LambdaHack.Client.UI.Frame+import Game.LambdaHack.Client.UI.Frontend.Common+import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Common.ClientOptions import qualified Game.LambdaHack.Common.Color as Color-import Game.LambdaHack.Common.LQueue+import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point -data FrameState =-    FPushed  -- frames stored in a queue, to be drawn in equal time intervals-      { fpushed :: !(LQueue (Maybe GtkFrame))  -- ^ screen output channel-      , fshown  :: !GtkFrame                   -- ^ last full frame shown-      }-  | FNone  -- no frames stored- -- | Session data maintained by the frontend. data FrontendSession = FrontendSession-  { sview       :: !TextView                    -- ^ the widget to draw to-  , stags       :: !(M.Map Color.Attr TextTag)  -- ^ text color tags for fg/bg-  , schanKey    :: !(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,-      -- to display frames, which is done by a single polling thread,-      -- in real time.-  , slastFull   :: !(MVar (GtkFrame, Bool))-      -- ^ Most recent full (not empty, not repeated) frame received-      -- and if any empty frame followed it. This mvar is locked-      -- for longer intervals to ensure that threads (possibly many)-      -- add frames in an orderly manner. This is not done in real time,-      -- though sometimes the frame display subsystem has to poll-      -- for a frame, in which case the locking interval becomes meaningful.-  , sescMVar    :: !(Maybe (MVar ()))-  , sdebugCli   :: !DebugModeCli  -- ^ client configuration+  { sview :: !TextView             -- ^ the widget to draw to+  , stags :: !(IM.IntMap TextTag)  -- ^ text color tags for fg/bg   } -data GtkFrame = GtkFrame-  { gfChar :: !BS.ByteString-  , gfAttr :: ![[TextTag]]-  }-  deriving Eq--dummyFrame :: GtkFrame-dummyFrame = GtkFrame BS.empty []---- | Perform an operation on the frame queue.-onQueue :: (LQueue (Maybe GtkFrame) -> LQueue (Maybe GtkFrame))-        -> FrontendSession -> IO ()-onQueue f FrontendSession{sframeState} = do-  fs <- takeMVar sframeState-  case fs of-    FPushed{..} ->-      putMVar sframeState FPushed{fpushed = f fpushed, ..}-    FNone ->-      putMVar sframeState fs- -- | The name of the frontend. frontendName :: String frontendName = "gtk" --- | Starts GTK. The other threads have to be spawned--- after gtk is initialized, because they call @postGUIAsync@,--- and need @sview@ and @stags@. Because of Windows, GTK needs to be--- on a bound thread, so we can't avoid the communication overhead--- of bound threads, so there's no point spawning a separate thread for GTK.-startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()-startup = runGtk+-- | Set up and start the main GTK loop providing input and output.+--+-- Because of Windows, GTK needs to be on a bound thread,+-- so we can't avoid the communication overhead of bound threads.+startup :: DebugModeCli -> IO RawFrontend+startup sdebugCli = startupBound $ startupFun sdebugCli --- | Sets up and starts the main GTK loop providing input and output.-runGtk :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()-runGtk sdebugCli@DebugModeCli{sfont} cont = do+startupFun :: DebugModeCli -> MVar RawFrontend -> IO ()+startupFun sdebugCli@DebugModeCli{..} rfMVar = do   -- Init GUI.   unsafeInitGUIForThreadedRTS   -- Text attributes.+  let emulateBox attr = case attr of+        Color.Attr{bg=Color.HighlightNone,fg} ->+          (fg, Color.Black)+        Color.Attr{bg=Color.HighlightRed} ->+          (Color.Black, Color.defFG)+        Color.Attr{bg=Color.HighlightBlue,fg} ->+          if fg /= Color.Blue+          then (fg, Color.Blue)+          else (fg, Color.BrBlack)+        Color.Attr{bg=Color.HighlightYellow,fg} ->+          if fg /= Color.Brown+          then (fg, Color.Brown)+          else (fg, Color.defFG)+        Color.Attr{bg=Color.HighlightGrey,fg} ->+          if fg /= Color.BrBlack+          then (fg, Color.BrBlack)+          else (fg, Color.defFG)   ttt <- textTagTableNew-  stags <- M.fromList <$>-             mapM (\ ak -> do+  stags <- IM.fromDistinctAscList <$>+             mapM (\ak -> do                       tt <- textTagNew Nothing                       textTagTableAdd ttt tt-                      doAttr sdebugCli tt ak-                      return (ak, tt))+                      doAttr sdebugCli tt (emulateBox ak)+                      return (fromEnum ak, tt))                [ Color.Attr{fg, bg}-               | fg <- [minBound..maxBound], bg <- Color.legalBG ]+               | fg <- [minBound..maxBound], bg <- [minBound..maxBound] ]   -- Text buffer.   tb <- textBufferNew (Just ttt)-  -- Create text view. TODO: use GtkLayout or DrawingArea instead of TextView?+  -- Create text view.   sview <- textViewNewWithBuffer tb   textViewSetEditable sview False   textViewSetCursorVisible sview False-  -- Set up the channel for keyboard input.-  schanKey <- STM.atomically STM.newTQueue-  -- Set up the frame state.-  let frameState = FNone-  -- Create the session record.-  sframeState <- newMVar frameState-  slastFull <- newMVar (dummyFrame, False)-  escMVar <- newEmptyMVar-  let sess = FrontendSession{sescMVar = Just escMVar, ..}-  -- Fork the game logic thread. When logic ends, game exits.-  -- TODO: is postGUISync needed here?-  aCont <- async $ cont sess `Ex.finally` postGUISync mainQuit-  link aCont-  -- Fork the thread that periodically draws a frame from a queue, if any.-  -- TODO: mainQuit somehow never called.-  aPoll <- async $ pollFramesAct sess `Ex.finally` postGUISync mainQuit-  link aPoll-  let flushChanKey = do-        res <- STM.atomically $ STM.tryReadTQueue schanKey-        when (isJust res) flushChanKey-  -- Fill the keyboard channel.+  widgetDelEvents sview [SmoothScrollMask, TouchMask]+  widgetAddEvents sview [ScrollMask]+  let sess = FrontendSession{..}+  rf <- createRawFrontend (display sess) shutdown+  putMVar rfMVar rf+  let modTranslate mods = modifierTranslate+        (Control `elem` mods)+        (Shift `elem` mods)+        (any (`elem` mods) [Alt, Alt2, Alt3, Alt4, Alt5])+        (any (`elem` mods) [Meta, Super])   sview `on` keyPressEvent $ do     n <- eventKeyName     mods <- eventModifier-#if MIN_VERSION_gtk(0,13,0)-    let !key = K.keyTranslate $ T.unpack n-#else-    let !key = K.keyTranslate n-#endif-        !modifier = let md = modifierTranslate mods-                    in if md == K.Shift then K.NoModifier else md-        !pointer = Nothing-    liftIO $ do-      unless (deadKey n) $ do-        -- If ESC, also mark it specially and reset the key channel.-        when (key == K.Esc) $ do-          void $ tryPutMVar escMVar ()-          flushChanKey-        -- Store the key in the channel.-        STM.atomically $ STM.writeTQueue schanKey K.KM{..}-      return True+    let key = K.keyTranslate $ T.unpack n+        modifier =+          let md = modTranslate mods+          in if md == K.Shift then K.NoModifier else md+        pointer = originPoint+    when (key == K.Esc) $ IO.liftIO $ resetChanKey (fchanKey rf)+    IO.liftIO $ saveKMP rf modifier key pointer+    return True   -- Set the font specified in config, if any.-  f <- fontDescriptionFromString $ fromMaybe "" sfont+  f <- fontDescriptionFromString+       $ fromMaybe "Monospace" sgtkFontFamily+         <+> maybe "16" tshow sfontSize <> "px"   widgetModifyFont sview (Just f)-  liftIO $ do+  IO.liftIO $ do     textViewSetLeftMargin sview 3     textViewSetRightMargin sview 3-  -- Prepare font chooser dialog.+  -- Take care of the mouse events.+  sview `on` scrollEvent $ do+    IO.liftIO $ resetChanKey (fchanKey rf)+    scrollDir <- eventScrollDirection+    (wx, wy) <- eventCoordinates+    mods <- eventModifier+    let modifier = modTranslate mods  -- Shift included+    IO.liftIO $ do+      (bx, by) <-+        textViewWindowToBufferCoords sview TextWindowText+                                     (round wx, round wy)+      (iter, _) <- textViewGetIterAtPosition sview bx by+      cx <- textIterGetLineOffset iter+      cy <- textIterGetLine iter+      let pointer = Point cx cy+          -- Store the mouse event coords in the keypress channel.+          storeK key = saveKMP rf modifier key pointer+      case scrollDir of+        ScrollUp -> storeK K.WheelNorth+        ScrollDown -> storeK K.WheelSouth+        _ -> return ()  -- ignore any fancy new gizmos+    return True  -- disable selection   currentfont <- newIORef f-  Just display <- displayGetDefault-  -- TODO: change cursor depending on targeting mode, etc.; hard-  cursor <- cursorNewForDisplay display Tcross  -- Target Crosshair Arrow-  sview `on` buttonPressEvent $ do-    liftIO flushChanKey+  Just defDisplay <- displayGetDefault+  cursor <- cursorNewForDisplay defDisplay Tcross  -- Target Crosshair Arrow+  sview `on` buttonPressEvent $ return True  -- disable selection+  sview `on` buttonReleaseEvent $ do+    IO.liftIO $ resetChanKey (fchanKey rf)     but <- eventButton     (wx, wy) <- eventCoordinates     mods <- eventModifier-    let !modifier = modifierTranslate mods  -- Shift included-    liftIO $ do+    let modifier = modTranslate mods  -- Shift included+    IO.liftIO $ do       when (but == RightButton && modifier == K.Control) $ do         fsd <- fontSelectionDialogNew ("Choose font" :: String)         cf  <- readIORef currentfont@@ -190,337 +163,52 @@               widgetModifyFont sview (Just fd)             Nothing  -> return ()         widgetDestroy fsd-      -- We shouldn't pass on the click if the user has selected something.-      hasSelection <- textBufferHasSelection tb-      unless hasSelection $ do-        mdrawWin <- displayGetWindowAtPointer display-        let setCursor (drawWin, _, _) =-              drawWindowSetCursor drawWin (Just cursor)-        maybe (return ()) setCursor mdrawWin-        (bx, by) <--          textViewWindowToBufferCoords sview TextWindowText-                                       (round wx, round wy)-        (iter, _) <- textViewGetIterAtPosition sview bx by-        cx <- textIterGetLineOffset iter-        cy <- textIterGetLine iter-        let !key = case but of-              LeftButton -> K.LeftButtonPress-              MiddleButton -> K.MiddleButtonPress-              RightButton -> K.RightButtonPress-              _ -> K.LeftButtonPress-            !pointer = Just $! Point cx (cy - 1)-        -- Store the mouse even coords in the keypress channel.-        STM.atomically $ STM.writeTQueue schanKey K.KM{..}-    return $! but == RightButton  -- not to disable selection+      mdrawWin <- displayGetWindowAtPointer defDisplay+      let setCursor (drawWin, _, _) =+            drawWindowSetCursor drawWin (Just cursor)+      maybe (return ()) setCursor mdrawWin+      (bx, by) <-+        textViewWindowToBufferCoords sview TextWindowText+                                     (round wx, round wy)+      (iter, _) <- textViewGetIterAtPosition sview bx by+      cx <- textIterGetLineOffset iter+      cy <- textIterGetLine iter+      let mkey = case but of+            LeftButton -> Just K.LeftButtonRelease+            MiddleButton -> Just K.MiddleButtonRelease+            RightButton -> Just K.RightButtonRelease+            _ -> Nothing  -- probably a glitch+          pointer = Point cx cy+      -- Store the mouse event coords in the keypress channel.+      maybe (return ())+            (\key -> IO.liftIO $ saveKMP rf modifier key pointer) mkey+    return True   -- Modify default colours.   let black = Color minBound minBound minBound  -- Color.defBG == Color.Black       white = Color 0xC500 0xBC00 0xB800        -- Color.defFG == Color.White-  widgetModifyBase sview StateNormal black-  widgetModifyText sview StateNormal white+  widgetModifyBg sview StateNormal black+  widgetModifyFg sview StateNormal white   -- Set up the main window.   w <- windowNew   containerAdd w sview-  onDestroy w mainQuit+  -- We assume it's intentional window kill by the player,+  -- so game is not saved, unlike with assertion failure, etc.+  w `on` deleteEvent $ IO.liftIO $ do+    putStrLn "Window killed"+    mainQuit+    exitFailure   widgetShowAll w   mainGUI --- | Output to the screen via the frontend.-output :: FrontendSession  -- ^ frontend session data-       -> GtkFrame         -- ^ the screen frame to draw-       -> IO ()-output FrontendSession{sview, stags} GtkFrame{..} = do  -- new frame-  tb <- textViewGetBuffer sview-  let attrs = zip [0..] gfAttr-      defAttr = stags M.! Color.defAttr-  textBufferSetByteString tb gfChar-  mapM_ (setTo tb defAttr 0) attrs--setTo :: TextBuffer -> TextTag -> Int -> (Int, [TextTag]) -> IO ()-setTo _ _ _ (_,  []) = return ()-setTo tb defAttr lx (ly, attr:attrs) = do-  ib <- textBufferGetIterAtLineOffset tb ly lx-  ie <- textIterCopy ib-  let setIter :: TextTag -> Int -> [TextTag] -> IO ()-      setIter previous repetitions [] = do-        textIterForwardChars ie repetitions-        when (previous /= defAttr) $-          textBufferApplyTag tb previous ib ie-      setIter previous repetitions (a:as)-        | a == previous =-            setIter a (repetitions + 1) as-        | otherwise = do-            textIterForwardChars ie repetitions-            when (previous /= defAttr) $-              textBufferApplyTag tb previous ib ie-            textIterForwardChars ib repetitions-            setIter a 1 as-  setIter attr 1 attrs---- | Maximal polls per second.-maxPolls :: Int -> Int-maxPolls maxFps = max 120 (2 * maxFps)--picoInMicro :: Int-picoInMicro = 1000000---- | Add a given number of microseconds to time.-addTime :: ClockTime -> Int -> ClockTime-addTime (TOD s p) mus = TOD s (p + fromIntegral (mus * picoInMicro))---- | The difference between the first and the second time, in microseconds.-diffTime :: ClockTime -> ClockTime -> Int-diffTime (TOD s1 p1) (TOD s2 p2) =-  fromIntegral (s1 - s2) * picoInMicro +-  fromIntegral (p1 - p2) `div` picoInMicro--microInSec :: Int-microInSec = 1000000--defaultMaxFps :: Int-defaultMaxFps = 30---- | Poll the frame queue often and draw frames at fixed intervals.-pollFramesWait :: FrontendSession -> ClockTime -> IO ()-pollFramesWait sess@FrontendSession{sdebugCli=DebugModeCli{smaxFps}}-               setTime = do-  -- Check if the time is up.-  let maxFps = fromMaybe defaultMaxFps smaxFps-  curTime <- getClockTime-  let diffSetCur = diffTime setTime curTime-  if diffSetCur > microInSec `div` maxPolls maxFps-    then do-      -- Delay half of the time difference.-      threadDelay $ diffTime curTime setTime `div` 2-      pollFramesWait sess setTime-    else-      -- Don't delay, because time is up!-      pollFramesAct sess---- | Poll the frame queue often and draw frames at fixed intervals.-pollFramesAct :: FrontendSession -> IO ()-pollFramesAct sess@FrontendSession{sframeState, sdebugCli=DebugModeCli{..}} = do-  -- Time is up, check if we actually wait for anyting.-  let maxFps = fromMaybe defaultMaxFps smaxFps-  fs <- takeMVar sframeState-  case fs of-    FPushed{..} ->-      case tryReadLQueue fpushed of-        Just (Just frame, queue) -> do-          -- The frame has arrived so send it for drawing and update delay.-          putMVar sframeState FPushed{fpushed = queue, fshown = frame}-          -- Count the time spent outputting towards the total frame time.-          curTime <- getClockTime-          -- Wait until the frame is drawn.-          postGUISync $ output sess frame-          -- Regardless of how much time drawing took, wait at least-          -- half of the normal delay time. This can distort the large-scale-          -- frame rhythm, but makes sure this frame can at all be seen.-          -- If the main GTK thread doesn't lag, large-scale rhythm will be OK.-          -- TODO: anyway, it's GC that causes visible snags, most probably.-          threadDelay $ microInSec `div` (maxFps * 2)-          pollFramesWait sess $ addTime curTime $ microInSec `div` maxFps-        Just (Nothing, queue) -> do-          -- Delay requested via an empty frame.-          putMVar sframeState FPushed{fpushed = queue, ..}-          unless snoDelay $-            -- There is no problem if the delay is a bit delayed.-            threadDelay $ microInSec `div` maxFps-          pollFramesAct sess-        Nothing -> do-          -- The queue is empty, the game logic thread lags.-          putMVar sframeState fs-          -- Time is up, the game thread is going to send a frame,-          -- (otherwise it would change the state), so poll often.-          threadDelay $ microInSec `div` maxPolls maxFps-          pollFramesAct sess-    FNone -> do-      putMVar sframeState fs-      -- Not in the Push state, so poll lazily to catch the next state change.-      -- The slow polling also gives the game logic a head start-      -- in creating frames in case one of the further frames is slow-      -- to generate and would normally cause a jerky delay in drawing.-      threadDelay $ microInSec `div` (maxFps * 2)-      pollFramesAct sess---- | Add a game screen frame to the frame drawing channel, or show--- it ASAP if @immediate@ display is requested and the channel is empty.-pushFrame :: FrontendSession -> Bool -> Maybe SingleFrame -> IO ()-pushFrame sess immediate rawFrame = do-  let FrontendSession{sframeState, slastFull} = sess-  -- Full evaluation is done outside the mvar locks.-  let !frame = case rawFrame of-        Nothing -> Nothing-        Just fr -> Just $! evalFrame sess fr-  -- Lock frame addition.-  (lastFrame, anyFollowed) <- takeMVar slastFull-  -- Comparison of frames is done outside the frame queue mvar lock.-  let nextFrame = if frame == Just lastFrame-                  then Nothing  -- no sense repeating-                  else frame-  -- Lock frame queue.-  fs <- takeMVar sframeState-  case fs of-    FPushed{..} ->-      putMVar sframeState-      $ if isNothing nextFrame && anyFollowed && isJust rawFrame-        then fs  -- old news-        else FPushed{fpushed = writeLQueue fpushed nextFrame, ..}-    FNone | immediate -> do-      -- If the frame not repeated, draw it.-      maybe (return ()) (postGUIAsync . output sess) nextFrame-      -- Frame sent, we may now safely release the queue lock.-      putMVar sframeState FNone-    FNone ->-      putMVar sframeState-      $ if isNothing nextFrame && anyFollowed && isJust rawFrame-        then fs  -- old news-        else FPushed{ fpushed = writeLQueue newLQueue nextFrame-                    , fshown = dummyFrame }-  case nextFrame of-    Nothing -> putMVar slastFull (lastFrame, not (case fs of-                                                    FNone -> True-                                                    FPushed{} -> False-                                                  && immediate-                                                  && not anyFollowed))-    Just f  -> putMVar slastFull (f, False)--evalFrame :: FrontendSession -> SingleFrame -> GtkFrame-evalFrame FrontendSession{stags} rawSF =-  let SingleFrame{sfLevel} = overlayOverlay rawSF-      sfLevelDecoded = map decodeLine sfLevel-      levelChar = unlines $ map (map Color.acChar) sfLevelDecoded-      gfChar = BS.pack $ init levelChar-      -- Strict version of @map (map ((stags M.!) . fst)) sfLevelDecoded@.-      gfAttr  = reverse $ foldl' ff [] sfLevelDecoded-      ff ll l = reverse (foldl' f [] l) : ll-      f l ac  = let !tag = stags M.! Color.acAttr ac in tag : l-  in GtkFrame{..}---- | Trim current frame queue and display the most recent frame, if any.-trimFrameState :: FrontendSession -> IO ()-trimFrameState sess@FrontendSession{sframeState} = do-  -- Take the lock to wipe out the frame queue, unless it's empty already.-  fs <- takeMVar sframeState-  case fs of-    FPushed{..} ->-      -- Remove all but the last element of the frame queue.-      -- The kept (and displayed) last element ensures that-      -- @slastFull@ is not invalidated.-      case lastLQueue fpushed of-        Just frame -> do-          -- Comparison is done inside the mvar lock, this time, but it's OK,-          -- since we wipe out the queue anyway, not draw it concurrently.-          -- The comparison is very rarely true, because that means-          -- the screen looks the same as a few moves before.-          -- Still, we want the invariant that frames are never repeated.-          let lastFrame = fshown-              nextFrame = if frame == lastFrame-                          then Nothing  -- no sense repeating-                          else Just frame-          -- Draw the last frame ASAP.-          maybe (return ()) (postGUIAsync . output sess) nextFrame-        Nothing -> return ()-    FNone -> return ()-  -- Wipe out the frame queue. Release the lock.-  putMVar sframeState FNone---- | Add a frame to be drawn.-fdisplay :: FrontendSession    -- ^ frontend session data-         -> Maybe SingleFrame  -- ^ the screen frame to draw-         -> IO ()-fdisplay sess = pushFrame sess False---- Display all queued frames, synchronously.-displayAllFramesSync :: FrontendSession -> FrameState -> IO ()-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-          -- Display synchronously.-          postGUISync $ output sess frame-          threadDelay $ microInSec `div` maxFps-          displayAllFramesSync sess FPushed{fpushed = queue, fshown = frame}-        Just (Nothing, queue) -> do-          -- Delay requested via an empty frame.-          unless snoDelay $-            threadDelay $ microInSec `div` maxFps-          displayAllFramesSync sess FPushed{fpushed = queue, ..}-        Nothing ->-          -- The queue is empty.-          return ()-    FNone ->-      -- Not in Push state to start with.-      return ()--fsyncFrames :: FrontendSession -> IO ()-fsyncFrames sess@FrontendSession{sframeState} = do-  fs <- takeMVar sframeState-  displayAllFramesSync sess fs-  putMVar sframeState FNone---- | Display a prompt, wait for any key.--- Starts in Push mode, ends in Push or None mode.--- Syncs with the drawing threads by showing the last or all queued frames.-fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM-fpromptGetKey sess@FrontendSession{..}-              frame = do-  pushFrame sess True $ Just frame-  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-    _ ->-      -- Show the last non-empty frame and empty the queue.-      trimFrameState sess-  return km---- | Tells a dead key.-deadKey :: (Eq t, IsString t) => t -> Bool-deadKey x = case x of-  "Shift_L"          -> True-  "Shift_R"          -> True-  "Control_L"        -> True-  "Control_R"        -> True-  "Super_L"          -> True-  "Super_R"          -> True-  "Menu"             -> True-  "Alt_L"            -> True-  "Alt_R"            -> True-  "ISO_Level2_Shift" -> True-  "ISO_Level3_Shift" -> True-  "ISO_Level2_Latch" -> True-  "ISO_Level3_Latch" -> True-  "Num_Lock"         -> True-  "Caps_Lock"        -> True-  _                  -> False---- | Translates modifiers to our own encoding.-modifierTranslate :: [Modifier] -> K.Modifier-modifierTranslate mods-  | Control `elem` mods = K.Control-  | any (`elem` mods) [Meta, Super, Alt, Alt2, Alt3, Alt4, Alt5] = K.Alt-  | Shift `elem` mods = K.Shift-  | otherwise = K.NoModifier+shutdown :: IO ()+shutdown = postGUISync mainQuit -doAttr :: DebugModeCli -> TextTag -> Color.Attr -> IO ()-doAttr sdebugCli tt attr@Color.Attr{fg, bg}-  | attr == Color.defAttr = return ()+doAttr :: DebugModeCli -> TextTag -> (Color.Color, Color.Color) -> IO ()+doAttr sdebugCli tt (fg, bg)+  | fg == Color.defFG && bg == Color.Black = return ()   | fg == Color.defFG =-    set tt $ extraAttr sdebugCli-             ++ [textTagBackground := Color.colorToRGB bg]-  | bg == Color.defBG =+    set tt [textTagBackground := Color.colorToRGB bg]+  | bg == Color.Black =     set tt $ extraAttr sdebugCli              ++ [textTagForeground := Color.colorToRGB fg]   | otherwise =@@ -532,3 +220,38 @@ extraAttr DebugModeCli{scolorIsBold} =   [textTagWeight := fromEnum WeightBold | scolorIsBold == Just True] --     , textTagStretch := StretchUltraExpanded++-- | Add a frame to be drawn.+display :: FrontendSession  -- ^ frontend session data+        -> SingleFrame      -- ^ the screen frame to draw+        -> IO ()+display FrontendSession{..} SingleFrame{singleFrame} = do+  let lxsize1 = fst normalLevelBound + 2+      f !w (!n, !l) = if n == -1+                      then (lxsize1 - 3, Color.charFromW32 w : '\n' : l)+                      else (n - 1, Color.charFromW32 w : l)+      (_, levelChar) = PointArray.foldrA' f (lxsize1 - 2, []) singleFrame+      !gfChar = T.pack levelChar+  postGUISync $ do+    tb <- textViewGetBuffer sview+    textBufferSetText tb gfChar+    ib <- textBufferGetStartIter tb+    ie <- textIterCopy ib+    let defEnum = fromEnum Color.defAttr+        setTo :: (X, Int) -> Color.AttrCharW32 -> IO (X, Int)+        setTo (!lx, !previous) !w | (lx + 1) `mod` lxsize1 /= 0 = do+          let current :: Int+              current = Color.attrEnumFromW32 w+          if current == previous+          then return (lx + 1, previous)+          else do+            textIterSetOffset ie lx+            when (previous /= defEnum) $+              textBufferApplyTag tb (stags IM.! previous) ib ie+            textIterSetOffset ib lx+            return (lx + 1, current)+        setTo (lx, previous) w = setTo (lx + 1, previous) w+    (lx, previous) <- PointArray.foldMA' setTo (-1, defEnum) singleFrame+    textIterSetOffset ie lx+    when (previous /= defEnum) $+      textBufferApplyTag tb (stags IM.! previous) ib ie

+ Game/LambdaHack/Client/UI/Frontend/Sdl.hs view

@@ -0,0 +1,406 @@+-- | Text frontend based on SDL2.+module Game.LambdaHack.Client.UI.Frontend.Sdl+  ( startup, frontendName+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , startupFun, shutdown, display+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude hiding (Alt)++-- Cabal+import qualified Paths_LambdaHack as Self (getDataFileName)++import Control.Concurrent+import Control.Concurrent.Async+import qualified Data.Char as Char+import qualified Data.EnumMap.Strict as EM+import Data.IORef+import qualified Data.Text as T+import qualified Data.Vector.Unboxed as U+import Data.Word (Word32, Word8)+import Foreign.C.Types (CInt)+import System.Directory+import System.FilePath++import qualified SDL+import SDL.Input.Keyboard.Codes+import qualified SDL.Raw as Raw+import qualified SDL.TTF as TTF+import qualified SDL.TTF.FFI as TTF (TTFFont)+import qualified SDL.Vect as Vect++import Game.LambdaHack.Client.UI.Frame+import Game.LambdaHack.Client.UI.Frontend.Common+import qualified Game.LambdaHack.Client.UI.Key as K+import Game.LambdaHack.Common.ClientOptions+import qualified Game.LambdaHack.Common.Color as Color+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray++type FontAtlas = EM.EnumMap Color.AttrCharW32 SDL.Texture++-- | Session data maintained by the frontend.+data FrontendSession = FrontendSession+  { swindow           :: !SDL.Window+  , srenderer         :: !SDL.Renderer+  , sfont             :: !TTF.TTFFont+  , satlas            :: !(IORef FontAtlas)+  , screenTexture     :: !SDL.Texture+  , spreviousFrame    :: !(IORef SingleFrame)+  , squitSDL          :: !(IORef Bool)+  , sdisplayPermitted :: !(MVar ())+  }++-- | The name of the frontend.+frontendName :: String+frontendName = "sdl"++-- | Set up and start the main loop providing input and output.+--+-- It seems, even on Windows, SDL2 doesn't require a bound thread.+-- so we can avoid the communication overhead of bound threads.+-- However, events can only be pumped in the thread that initialized+-- the video subsystem, so we need to enter the event-gathering loop+-- after the initialization and stay there.+startup :: DebugModeCli -> IO RawFrontend+startup sdebugCli = do+  rfMVar <- newEmptyMVar+  a <- async $ startupFun sdebugCli rfMVar+  link a+  takeMVar rfMVar++startupFun :: DebugModeCli -> MVar RawFrontend -> IO ()+startupFun sdebugCli@DebugModeCli{..} rfMVar = do+  SDL.initialize [SDL.InitVideo, SDL.InitEvents]+  let title = fromJust stitle+      fontFileName =+        "GameDefinition/fonts" </> T.unpack (fromJust sdlFontFile)+  fontFile <- if isRelative fontFileName+              then Self.getDataFileName fontFileName+              else return fontFileName+  fontFileExists <- doesFileExist fontFile+  unless fontFileExists $+    assert `failure` "Font file does not exist: " ++ fontFile+  let fontSize = fromJust sfontSize+  code <- TTF.init+  when (code /= 0) $+    assert `failure` "init of sdl2-ttf failed with: " ++ show code+  sfont <- TTF.openFont fontFile fontSize+  let fonFile = "fon" `isSuffixOf` T.unpack (fromJust sdlFontFile)+      sdlSizeAdd = fromJust $ if fonFile then sdlFonSizeAdd else sdlTtfSizeAdd+  boxSize <- (+ sdlSizeAdd) <$> TTF.getFontHeight sfont+  let xsize = fst normalLevelBound + 1+      ysize = snd normalLevelBound + 4+      screenV2 = SDL.V2 (toEnum $ xsize * boxSize)+                        (toEnum $ ysize * boxSize)+      windowConfig = SDL.defaultWindow {SDL.windowInitialSize = screenV2}+      rendererConfig = SDL.defaultRenderer {SDL.rendererTargetTexture = True}+  swindow <- SDL.createWindow title windowConfig+  srenderer <- SDL.createRenderer swindow (-1) rendererConfig+  screenTexture <- SDL.createTexture srenderer SDL.ARGB8888+                                     SDL.TextureAccessTarget screenV2+  SDL.rendererDrawBlendMode srenderer SDL.$= SDL.BlendNone+  SDL.rendererRenderTarget srenderer SDL.$= Just screenTexture+  let v4black = let Raw.Color r g b a = colorToRGBA Color.Black+                in SDL.V4 r g b a+  SDL.rendererDrawColor srenderer SDL.$= v4black+  SDL.clear srenderer  -- clear the texture+  SDL.rendererRenderTarget srenderer SDL.$= Nothing+  SDL.copy srenderer screenTexture Nothing Nothing  -- clear the backbuffer+  satlas <- newIORef EM.empty+  spreviousFrame <- newIORef blankSingleFrame+  squitSDL <- newIORef False+  sdisplayPermitted <- newMVar ()+  let sess = FrontendSession{..}+  rf <- createRawFrontend (display sdebugCli sess) (shutdown sess)+  putMVar rfMVar rf+  let pointTranslate :: forall i. (Enum i) => Vect.Point Vect.V2 i -> Point+      pointTranslate (SDL.P (SDL.V2 x y)) =+        Point (fromEnum x `div` boxSize) (fromEnum y `div` boxSize)+      redraw = do+        prevFrame <- readIORef spreviousFrame+        display sdebugCli sess prevFrame+      storeKeys :: IO ()+      storeKeys = do+        e <- SDL.waitEvent  -- blocks here, so no polling+        case SDL.eventPayload e of+          SDL.KeyboardEvent keyboardEvent+            | SDL.keyboardEventKeyMotion keyboardEvent == SDL.Pressed -> do+              let sym = SDL.keyboardEventKeysym keyboardEvent+                  ksm = SDL.keysymModifier sym+                  shiftPressed = SDL.keyModifierLeftShift ksm+                                 || SDL.keyModifierRightShift ksm+                  key = keyTranslate shiftPressed $ SDL.keysymKeycode sym+                  modifier = modTranslate ksm+              p <- SDL.getAbsoluteMouseLocation+              when (key == K.Esc) $ resetChanKey (fchanKey rf)+              saveKMP rf modifier key (pointTranslate p)+          SDL.MouseButtonEvent mouseButtonEvent+            | SDL.mouseButtonEventMotion mouseButtonEvent == SDL.Released -> do+              md <- modTranslate <$> SDL.getModState+              let key = case SDL.mouseButtonEventButton mouseButtonEvent of+                    SDL.ButtonLeft -> K.LeftButtonRelease+                    SDL.ButtonMiddle -> K.MiddleButtonRelease+                    SDL.ButtonRight -> K.RightButtonRelease+                    _ -> K.LeftButtonRelease  -- any other is spare left+                  modifier = if md == K.Shift then K.NoModifier else md+                  p = SDL.mouseButtonEventPos mouseButtonEvent+              saveKMP rf modifier key (pointTranslate p)+          SDL.MouseWheelEvent mouseWheelEvent -> do+            md <- modTranslate <$> SDL.getModState+            let SDL.V2 _ y = SDL.mouseWheelEventPos mouseWheelEvent+                mkey = case (compare y 0, SDL.mouseWheelEventDirection+                                            mouseWheelEvent) of+                  (EQ, _) -> Nothing+                  (LT, SDL.ScrollNormal) -> Just K.WheelSouth+                  (GT, SDL.ScrollNormal) -> Just K.WheelNorth+                  (LT, SDL.ScrollFlipped) -> Just K.WheelSouth+                  (GT, SDL.ScrollFlipped) -> Just K.WheelNorth+                modifier = if md == K.Shift then K.NoModifier else md+            p <- SDL.getAbsoluteMouseLocation+            maybe (return ())+                  (\key -> saveKMP rf modifier key (pointTranslate p)) mkey+          SDL.WindowClosedEvent{} -> shutdown sess+          SDL.QuitEvent -> shutdown sess+          SDL.WindowRestoredEvent{} -> redraw+          _ -> return ()+        quitSDL <- readIORef squitSDL+        unless quitSDL storeKeys+  storeKeys+  TTF.closeFont sfont+  TTF.quit+  SDL.destroyRenderer srenderer+  SDL.destroyWindow swindow+  SDL.quit++shutdown :: FrontendSession -> IO ()+shutdown FrontendSession{..} = do+  takeMVar sdisplayPermitted+  writeIORef squitSDL True++-- | Add a frame to be drawn.+display :: DebugModeCli+        -> FrontendSession  -- ^ frontend session data+        -> SingleFrame      -- ^ the screen frame to draw+        -> IO ()+display DebugModeCli{..} FrontendSession{..} curFrame = do+  let fonFile = "fon" `isSuffixOf` T.unpack (fromJust sdlFontFile)+      sdlSizeAdd = fromJust $ if fonFile then sdlFonSizeAdd else sdlTtfSizeAdd+      v4black = let Raw.Color r g b a = colorToRGBA Color.Black+                in SDL.V4 r g b a+  SDL.rendererDrawColor srenderer SDL.$= v4black+  boxSize <- (+ sdlSizeAdd) <$> TTF.getFontHeight sfont+  let xsize = fst normalLevelBound + 1+      vp :: Int -> Int -> Vect.Point Vect.V2 CInt+      vp x y = Vect.P $ Vect.V2 (toEnum x) (toEnum y)+      drawHighlight x y color = do+        let v4 = let Raw.Color r g b a = colorToRGBA color+                 in SDL.V4 r g b a+        SDL.rendererDrawColor srenderer SDL.$= v4+        let rect = SDL.Rectangle (vp (x * boxSize) (y * boxSize))+                                 (Vect.V2 (toEnum boxSize) (toEnum boxSize))+        SDL.drawRect srenderer $ Just rect+        SDL.rendererDrawColor srenderer SDL.$= v4black  -- reset back to black+      setChar :: Int -> Word32 -> Word32 -> IO ()+      setChar i w wPrev = unless (w == wPrev) $ do+        atlas <- readIORef satlas+        let (y, x) = i `divMod` xsize+            acRaw = Color.AttrCharW32 w+            Color.AttrChar{acAttr=Color.Attr{..}, acChar=acCharRaw} =+              Color.attrCharFromW32 acRaw+            normalizeAc color = (Color.attrChar2ToW32 fg acCharRaw, Just color)+            (ac, mlineColor) = case bg of+              Color.HighlightNone -> (acRaw, Nothing)+              Color.HighlightRed -> normalizeAc Color.Red+              Color.HighlightBlue -> normalizeAc Color.Blue+              Color.HighlightYellow -> normalizeAc Color.BrYellow+              Color.HighlightGrey -> normalizeAc Color.BrBlack+        -- https://github.com/rongcuid/sdl2-ttf/blob/master/src/SDL/TTF.hsc+        -- https://www.libsdl.org/projects/SDL_ttf/docs/SDL_ttf_42.html#SEC42+        textTexture <- case EM.lookup ac atlas of+          Nothing -> do+            -- Make all visible floors bold (no bold fold variant for 16x16x,+            -- so only the dot can be bold).+            let acChar = if fg <= Color.BrBlack+                            && Char.ord acCharRaw == 183  -- 0xb7+                            && scolorIsBold == Just True  -- only dot but enough+                         then Char.chr $ if fonFile+                                         then 7   -- hack+                                         else 8901  -- 0x22c5+                         else acCharRaw+            textSurface <-+              TTF.renderUTF8Shaded sfont [acChar] (colorToRGBA fg)+                                                  (colorToRGBA Color.Black)+            textTexture <- SDL.createTextureFromSurface srenderer textSurface+            SDL.freeSurface textSurface+            writeIORef satlas $ EM.insert ac textTexture atlas  -- not @acRaw@+            return textTexture+          Just textTexture -> return textTexture+        ti <- SDL.queryTexture textTexture+        let box = SDL.Rectangle (vp (x * boxSize) (y * boxSize))+                                (Vect.V2 (toEnum boxSize) (toEnum boxSize))+            width = min boxSize $ fromEnum $ SDL.textureWidth ti+            height = min boxSize $ fromEnum $ SDL.textureHeight ti+            xsrc = max 0 (fromEnum (SDL.textureWidth ti) - width) `div` 2+            ysrc = max 0 (fromEnum (SDL.textureHeight ti) - height) `div` 2+            srcR = SDL.Rectangle (vp xsrc ysrc)+                                 (Vect.V2 (toEnum width) (toEnum height))+            xtgt = (boxSize - width) `divUp` 2+            ytgt = (boxSize - height) `div` 2+            tgtR = SDL.Rectangle (vp (x * boxSize + xtgt) (y * boxSize + ytgt))+                                 (Vect.V2 (toEnum width) (toEnum height))+        SDL.fillRect srenderer $ Just box+        SDL.copy srenderer textTexture (Just srcR) (Just tgtR)+        maybe (return ()) (drawHighlight x y) mlineColor+  takeMVar sdisplayPermitted+  prevFrame <- readIORef spreviousFrame+  writeIORef spreviousFrame curFrame+  SDL.rendererRenderTarget srenderer SDL.$= Just screenTexture+  U.izipWithM_ setChar (PointArray.avector $ singleFrame curFrame)+                       (PointArray.avector $ singleFrame prevFrame)+  SDL.rendererRenderTarget srenderer SDL.$= Nothing+  SDL.copy srenderer screenTexture Nothing Nothing+  SDL.present srenderer+  putMVar sdisplayPermitted ()++-- | Translates modifiers to our own encoding, ignoring Shift.+modTranslate :: SDL.KeyModifier -> K.Modifier+modTranslate m =+  modifierTranslate+    (SDL.keyModifierLeftCtrl m || SDL.keyModifierRightCtrl m)+    False+    (SDL.keyModifierLeftAlt m+     || SDL.keyModifierRightAlt m+     || SDL.keyModifierAltGr m)+    False++keyTranslate :: Bool -> SDL.Keycode -> K.Key+keyTranslate shiftPressed n =+  case n of+    KeycodeEscape     -> K.Esc+    KeycodeReturn     -> K.Return+    KeycodeBackspace  -> K.BackSpace+    KeycodeTab        -> if shiftPressed then K.BackTab else K.Tab+    KeycodeSpace      -> K.Space+    KeycodeExclaim -> K.Char '!'+    KeycodeQuoteDbl -> K.Char '"'+    KeycodeHash -> K.Char '#'+    KeycodePercent -> K.Char '%'+    KeycodeDollar -> K.Char '$'+    KeycodeAmpersand -> K.Char '&'+    KeycodeQuote -> if shiftPressed then K.Char '"' else K.Char '\''+    KeycodeLeftParen -> K.Char '('+    KeycodeRightParen -> K.Char ')'+    KeycodeAsterisk -> K.Char '*'+    KeycodePlus -> K.Char '+'+    KeycodeComma -> if shiftPressed then K.Char '<' else K.Char ','+    KeycodeMinus -> if shiftPressed then K.Char '_' else K.Char '-'+    KeycodePeriod -> if shiftPressed then K.Char '>' else K.Char '.'+    KeycodeSlash -> if shiftPressed then K.Char '?' else K.Char '/'+    Keycode1 -> if shiftPressed then K.Char '!' else K.Char '1'+    Keycode2 -> if shiftPressed then K.Char '@' else K.Char '2'+    Keycode3 -> if shiftPressed then K.Char '#' else K.Char '3'+    Keycode4 -> if shiftPressed then K.Char '$' else K.Char '4'+    Keycode5 -> if shiftPressed then K.Char '%' else K.Char '5'+    Keycode6 -> if shiftPressed then K.Char '^' else K.Char '6'+    Keycode7 -> if shiftPressed then K.Char '&' else K.Char '7'+    Keycode8 -> if shiftPressed then K.Char '*' else K.Char '8'+    Keycode9 -> if shiftPressed then K.Char '(' else K.Char '9'+    Keycode0 -> if shiftPressed then K.Char ')' else K.Char '0'+    KeycodeColon -> K.Char ':'+    KeycodeSemicolon -> if shiftPressed then K.Char ':' else K.Char ';'+    KeycodeLess -> K.Char '<'+    KeycodeEquals -> if shiftPressed then K.Char '+' else K.Char '='+    KeycodeGreater -> K.Char '>'+    KeycodeQuestion -> K.Char '?'+    KeycodeAt -> K.Char '@'+    KeycodeLeftBracket -> if shiftPressed then K.Char '{' else K.Char '['+    KeycodeBackslash -> if shiftPressed then K.Char '|' else K.Char '\\'+    KeycodeRightBracket -> if shiftPressed then K.Char '}' else K.Char ']'+    KeycodeCaret -> K.Char '^'+    KeycodeUnderscore -> K.Char '_'+    KeycodeBackquote -> if shiftPressed then K.Char '~' else K.Char '`'+    KeycodeUp         -> K.Up+    KeycodeDown       -> K.Down+    KeycodeLeft       -> K.Left+    KeycodeRight      -> K.Right+    KeycodeHome       -> K.Home+    KeycodeEnd        -> K.End+    KeycodePageUp     -> K.PgUp+    KeycodePageDown   -> K.PgDn+    KeycodeInsert     -> K.Insert+    KeycodeDelete     -> K.Delete+    KeycodeKPDivide   -> K.KP '/'+    KeycodeKPMultiply -> K.KP '*'+    KeycodeKPMinus    -> K.Char '-'  -- KP and normal are merged here+    KeycodeKPPlus     -> K.Char '+'  -- KP and normal are merged here+    KeycodeKPEnter    -> K.Return+    KeycodeKPEquals   -> K.Return  -- in case of some funny layouts+    KeycodeKP1 -> if shiftPressed then K.KP '1' else K.End+    KeycodeKP2 -> if shiftPressed then K.KP '2' else K.Down+    KeycodeKP3 -> if shiftPressed then K.KP '3' else K.PgDn+    KeycodeKP4 -> if shiftPressed then K.KP '4' else K.Left+    KeycodeKP5 -> if shiftPressed then K.KP '5' else K.Begin+    KeycodeKP6 -> if shiftPressed then K.KP '6' else K.Right+    KeycodeKP7 -> if shiftPressed then K.KP '7' else K.Home+    KeycodeKP8 -> if shiftPressed then K.KP '8' else K.Up+    KeycodeKP9 -> if shiftPressed then K.KP '9' else K.PgUp+    KeycodeKP0 -> if shiftPressed then K.KP '0' else K.Insert+    KeycodeKPPeriod -> K.Char '.'  -- dot and comma are merged here+    KeycodeKPComma  -> K.Char '.'  -- to sidestep national standards+    KeycodeF1       -> K.Fun 1+    KeycodeF2       -> K.Fun 2+    KeycodeF3       -> K.Fun 3+    KeycodeF4       -> K.Fun 4+    KeycodeF5       -> K.Fun 5+    KeycodeF6       -> K.Fun 6+    KeycodeF7       -> K.Fun 7+    KeycodeF8       -> K.Fun 8+    KeycodeF9       -> K.Fun 9+    KeycodeF10      -> K.Fun 10+    KeycodeF11      -> K.Fun 11+    KeycodeF12      -> K.Fun 12+    KeycodeLCtrl    -> K.DeadKey+    KeycodeLShift   -> K.DeadKey+    KeycodeLAlt     -> K.DeadKey+    KeycodeLGUI     -> K.DeadKey+    KeycodeRCtrl    -> K.DeadKey+    KeycodeRShift   -> K.DeadKey+    KeycodeRAlt     -> K.DeadKey+    KeycodeRGUI     -> K.DeadKey+    KeycodeMode     -> K.DeadKey+    KeycodeNumLockClear -> K.DeadKey+    KeycodeUnknown  -> K.Unknown "KeycodeUnknown"+    _ -> let i = fromEnum $ unwrapKeycode n+         in if | 97 <= i && i <= 122+                 && shiftPressed -> K.Char $ Char.chr $ i - 32+               | 32 <= i && i <= 126 -> K.Char $ Char.chr i+               | otherwise -> K.Unknown $ show n+++sDL_ALPHA_OPAQUE :: Word8+sDL_ALPHA_OPAQUE = 255++-- This code is sadly duplicated from "Game.LambdaHack.Common.Color".+colorToRGBA :: Color.Color -> Raw.Color+colorToRGBA Color.Black     = Raw.Color 0 0 0 sDL_ALPHA_OPAQUE+colorToRGBA Color.Red       = Raw.Color 0xD5 0x00 0x00 sDL_ALPHA_OPAQUE+colorToRGBA Color.Green     = Raw.Color 0x00 0xAA 0x00 sDL_ALPHA_OPAQUE+colorToRGBA Color.Brown     = Raw.Color 0xCA 0x4A 0x00 sDL_ALPHA_OPAQUE+colorToRGBA Color.Blue      = Raw.Color 0x20 0x3A 0xF0 sDL_ALPHA_OPAQUE+colorToRGBA Color.Magenta   = Raw.Color 0xAA 0x00 0xAA sDL_ALPHA_OPAQUE+colorToRGBA Color.Cyan      = Raw.Color 0x00 0xAA 0xAA sDL_ALPHA_OPAQUE+colorToRGBA Color.White     = Raw.Color 0xC5 0xBC 0xB8 sDL_ALPHA_OPAQUE+colorToRGBA Color.BrBlack   = Raw.Color 0x6F 0x5F 0x5F sDL_ALPHA_OPAQUE+colorToRGBA Color.BrRed     = Raw.Color 0xFF 0x55 0x55 sDL_ALPHA_OPAQUE+colorToRGBA Color.BrGreen   = Raw.Color 0x75 0xFF 0x45 sDL_ALPHA_OPAQUE+colorToRGBA Color.BrYellow  = Raw.Color 0xFF 0xE8 0x55 sDL_ALPHA_OPAQUE+colorToRGBA Color.BrBlue    = Raw.Color 0x40 0x90 0xFF sDL_ALPHA_OPAQUE+colorToRGBA Color.BrMagenta = Raw.Color 0xFF 0x77 0xFF sDL_ALPHA_OPAQUE+colorToRGBA Color.BrCyan    = Raw.Color 0x60 0xFF 0xF0 sDL_ALPHA_OPAQUE+colorToRGBA Color.BrWhite   = Raw.Color 0xFF 0xFF 0xFF sDL_ALPHA_OPAQUE

− Game/LambdaHack/Client/UI/Frontend/Std.hs

@@ -1,83 +0,0 @@--- | Text frontend based on stdin/stdout, intended for bots.-module Game.LambdaHack.Client.UI.Frontend.Std-  ( -- * Session data type for the frontend-    FrontendSession(sescMVar)-    -- * The output and input operations-  , fdisplay, fpromptGetKey, fsyncFrames-    -- * Frontend administration tools-  , frontendName, startup-  ) where--import Control.Concurrent-import Control.Concurrent.Async-import qualified Control.Exception as Ex hiding (handle)-import qualified Data.ByteString.Char8 as BS-import Data.Char (chr, ord)-import qualified System.IO as SIO--import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.UI.Animation-import Game.LambdaHack.Common.ClientOptions-import qualified Game.LambdaHack.Common.Color as Color---- | No session data needs to be maintained by this frontend.-data FrontendSession = FrontendSession-  { sdebugCli :: !DebugModeCli  -- ^ client configuration-  , sescMVar  :: !(Maybe (MVar ()))-  }---- | The name of the frontend.-frontendName :: String-frontendName = "std"---- | Starts the main program loop using the frontend input and output.-startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()-startup sdebugCli k = do-  a <- async $ k FrontendSession{sescMVar = Nothing, ..}-               `Ex.finally` (SIO.hFlush SIO.stdout >> SIO.hFlush SIO.stderr)-  wait a---- | Output to the screen via the frontend.-fdisplay :: FrontendSession    -- ^ frontend session data-         -> Maybe SingleFrame  -- ^ the screen frame to draw-         -> IO ()-fdisplay _ Nothing = return ()-fdisplay _ (Just rawSF) =-  let SingleFrame{sfLevel} = overlayOverlay rawSF-      bs = map (BS.pack . map Color.acChar . decodeLine) sfLevel ++ [BS.empty]-  in mapM_ BS.putStrLn bs---- | Input key via the frontend.-nextEvent :: IO K.KM-nextEvent = do-  l <- BS.hGetLine SIO.stdin-  let c = case BS.uncons l of-        Nothing -> '\n'  -- empty line counts as RET-        Just (hd, _) -> hd-  return $! keyTranslate c--fsyncFrames :: FrontendSession -> IO ()-fsyncFrames _ = return ()---- | Display a prompt, wait for any key.-fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM-fpromptGetKey sess frame = do-  fdisplay sess $ Just frame-  nextEvent--keyTranslate :: Char -> K.KM-keyTranslate e = (\(key, modifier) -> K.toKM modifier key) $-  case e of-    '\ESC' -> (K.Esc,     K.NoModifier)-    '\n'   -> (K.Return,  K.NoModifier)-    '\r'   -> (K.Return,  K.NoModifier)-    ' '    -> (K.Space,   K.NoModifier)-    '\t'   -> (K.Tab,     K.NoModifier)-    c | ord '\^A' <= ord c && ord c <= ord '\^Z' ->-        -- Alas, only lower-case letters.-        (K.Char $ chr $ ord c - ord '\^A' + ord 'a', K.Control)-        -- Movement keys are more important than leader picking,-        -- so disabling the latter and interpreting the keypad numbers-        -- as movement:-      | c `elem` ['1'..'9'] -> (K.KP c,              K.NoModifier)-      | otherwise           -> (K.Char c,            K.NoModifier)

+ Game/LambdaHack/Client/UI/Frontend/Teletype.hs view

@@ -0,0 +1,84 @@+-- | Line terimanl text frontend based on stdin/stdout, intended for logging+-- tests, but may be used for a teletype terminal, or keyboard and printer.+module Game.LambdaHack.Client.UI.Frontend.Teletype+  ( startup, frontendName+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , shutdown, display+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Control.Concurrent.Async+import Data.Char (chr, ord)+import qualified Data.Char as Char+import qualified System.IO as SIO++import Game.LambdaHack.Client.UI.Frame+import Game.LambdaHack.Client.UI.Frontend.Common+import qualified Game.LambdaHack.Client.UI.Key as K+import Game.LambdaHack.Common.ClientOptions+import qualified Game.LambdaHack.Common.Color as Color+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray++-- No session data maintained by this frontend++-- | The name of the frontend.+frontendName :: String+frontendName = "teletype"++-- | Set up the frontend input and output.+startup :: DebugModeCli -> IO RawFrontend+startup _sdebugCli = do+  rf <- createRawFrontend display shutdown+  let storeKeys :: IO ()+      storeKeys = do+        l <- SIO.getLine  -- blocks here, so no polling+        let c = case l of+              [] -> '\n'  -- empty line counts as RET+              hd : _ -> hd+            K.KM{..} = keyTranslate c+        saveKMP rf modifier key originPoint+        storeKeys+  void $ async storeKeys+  return $! rf++shutdown :: IO ()+shutdown = SIO.hFlush SIO.stdout >> SIO.hFlush SIO.stderr++-- | Output to the screen via the frontend.+display :: SingleFrame  -- ^ the screen frame to draw+        -> IO ()+display SingleFrame{singleFrame} =+  let f w l =+        let acCharRaw = Color.charFromW32 w+            acChar = if Char.ord acCharRaw == 183 then '.' else acCharRaw+        in acChar : l+      levelChar = chunk $ PointArray.foldrA f [] singleFrame+      lxsize = fst normalLevelBound + 1+      chunk [] = []+      chunk l = let (ch, r) = splitAt lxsize l+                in ch : chunk r+  in SIO.hPutStrLn SIO.stderr $ unlines levelChar++keyTranslate :: Char -> K.KM+keyTranslate e = (\(key, modifier) -> K.KM modifier key) $+  case e of+    '\ESC' -> (K.Esc,     K.NoModifier)+    '\n'   -> (K.Return,  K.NoModifier)+    '\r'   -> (K.Return,  K.NoModifier)+    ' '    -> (K.Space,   K.NoModifier)+    '\t'   -> (K.Tab,     K.NoModifier)+    c | ord '\^A' <= ord c && ord c <= ord '\^Z' ->+        -- Alas, only lower-case letters.+        (K.Char $ chr $ ord c - ord '\^A' + ord 'a', K.Control)+        -- Movement keys are more important than leader picking,+        -- so disabling the latter and interpreting the keypad numbers+        -- as movement:+      | c `elem` ['1'..'9'] -> (K.KP c,              K.NoModifier)+      | otherwise           -> (K.Char c,            K.NoModifier)

Game/LambdaHack/Client/UI/Frontend/Vty.hs view

@@ -1,35 +1,28 @@ -- | Text frontend based on Vty. module Game.LambdaHack.Client.UI.Frontend.Vty-  ( -- * Session data type for the frontend-    FrontendSession(sescMVar)-    -- * The output and input operations-  , fdisplay, fpromptGetKey, fsyncFrames-    -- * Frontend administration tools-  , frontendName, startup+  ( startup, frontendName   ) where -import Control.Concurrent+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Control.Concurrent.Async-import qualified Control.Concurrent.STM as STM-import qualified Control.Exception as Ex hiding (handle)-import Control.Monad-import Data.Default-import Data.Maybe import Graphics.Vty import qualified Graphics.Vty as Vty -import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.UI.Animation+import Game.LambdaHack.Client.UI.Frame+import Game.LambdaHack.Client.UI.Frontend.Common+import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Common.ClientOptions import qualified Game.LambdaHack.Common.Color as Color-import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray  -- | 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+newtype FrontendSession = FrontendSession+  { svty :: Vty  -- ^ internal vty session   }  -- | The name of the frontend.@@ -37,83 +30,39 @@ frontendName = "vty"  -- | Starts the main program loop using the frontend input and output.-startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()-startup sdebugCli k = do-  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-          !pointer = Nothing-          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 ->-          when (key == K.Esc) $ do-            void $ tryPutMVar escMVar ()-            readAll-        Nothing -> return ()-      -- Store the key in the channel.-      STM.atomically $ STM.writeTQueue schanKey K.KM{..}-    _ -> return ()-  storeKeys sess+startup :: DebugModeCli -> IO RawFrontend+startup _sdebugCli = do+  svty <- mkVty mempty+  let sess = FrontendSession{..}+  rf <- createRawFrontend (display sess) (Vty.shutdown svty)+  let storeKeys :: IO ()+      storeKeys = do+        e <- nextEvent svty  -- blocks here, so no polling+        case e of+          EvKey n mods ->+            saveKMP rf (modTranslate mods) (keyTranslate n) originPoint+          _ -> return ()+        storeKeys+  void $ async storeKeys+  return $! rf  -- | Output to the screen via the frontend.-fdisplay :: FrontendSession    -- ^ frontend session data-         -> Maybe SingleFrame  -- ^ the screen frame to draw-         -> IO ()-fdisplay _ Nothing = return ()-fdisplay FrontendSession{svty} (Just rawSF) =-  let SingleFrame{sfLevel} = overlayOverlay rawSF-      img = (foldr (<->) emptyImage-             . map (foldr (<|>) emptyImage-                      . map (\ Color.AttrChar{..} ->-                                char (setAttr acAttr) acChar)))-            $ map decodeLine sfLevel+display :: FrontendSession    -- ^ frontend session data+        -> SingleFrame  -- ^ the screen frame to draw+        -> IO ()+display FrontendSession{svty} SingleFrame{singleFrame} =+  let img = foldr (<->) emptyImage+            . map (foldr (<|>) emptyImage+                     . map (\w -> char (setAttr $ Color.attrFromW32 w)+                                       (Color.charFromW32 w)))+            $ chunk $ PointArray.toListA singleFrame       pic = picForImage img+      lxsize = fst normalLevelBound + 1+      chunk [] = []+      chunk l = let (ch, r) = splitAt lxsize l+                in ch : chunk r   in update svty pic --- | Input key via the frontend.-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 ()---- | Display a prompt, wait for any key.-fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM-fpromptGetKey sess frame = do-  fdisplay sess $ Just frame-  nextKeyEvent sess---- TODO: Ctrl-m is RET keyTranslate :: Key -> K.Key keyTranslate n =   case n of@@ -134,21 +83,19 @@     KBegin        -> K.Begin     KCenter       -> K.Begin     KIns          -> K.Insert-    -- Ctrl-Home and Ctrl-End are the same in vty as Home and End+    -- C-Home and C-End are the same in vty as Home and End     -- on some terminals so we have to use 1--9 for movement instead of     -- leader change.     (KChar c)       | c `elem` ['1'..'9'] -> K.KP c  -- movement, not leader change       | otherwise           -> K.Char c-    _             -> K.Unknown (tshow n)+    _             -> K.Unknown (show n)  -- | Translates modifiers to our own encoding.-modifierTranslate :: [Modifier] -> K.Modifier-modifierTranslate mods-  | MCtrl `elem` mods = K.Control-  | MAlt `elem` mods = K.Alt-  | MShift `elem` mods = K.Shift-  | otherwise = K.NoModifier+modTranslate :: [Modifier] -> K.Modifier+modTranslate mods =+  modifierTranslate+    (MCtrl `elem` mods) (MShift `elem` mods) (MAlt `elem` mods) False  -- A hack to get bright colors via the bold attribute. Depending on terminal -- settings this is needed or not and the characters really get bold or not.@@ -157,14 +104,29 @@ hack c a = if Color.isBright c then withStyle a bold else a  setAttr :: Color.Attr -> Attr-setAttr Color.Attr{fg, bg} =+setAttr Color.Attr{..} = -- This optimization breaks display for white background terminals: --  if (fg, bg) == Color.defAttr --  then def_attr --  else-  hack fg $ hack bg $-    defAttr { attrForeColor = SetTo (aToc fg)-            , attrBackColor = SetTo (aToc bg) }+  let (fg1, bg1) = case bg of+        Color.HighlightNone -> (fg, Color.Black)+        Color.HighlightRed -> (Color.Black, Color.defFG)+        Color.HighlightBlue ->+          if fg /= Color.Blue+          then (fg, Color.Blue)+          else (fg, Color.BrBlack)+        Color.HighlightYellow ->+          if fg /= Color.Brown+          then (fg, Color.Brown)+          else (fg, Color.defFG)+        Color.HighlightGrey ->+          if fg /= Color.BrBlack+          then (fg, Color.BrBlack)+          else (fg, Color.defFG)+  in hack fg1 $ hack bg1 $+       defAttr { attrForeColor = SetTo (aToc fg1)+               , attrBackColor = SetTo (aToc bg1) }  aToc :: Color.Color -> Color aToc Color.Black     = black

+ Game/LambdaHack/Client/UI/HandleHelperM.hs view

@@ -0,0 +1,320 @@+-- | Helper functions for both inventory management and human commands.+module Game.LambdaHack.Client.UI.HandleHelperM+  ( MError, FailOrCmd+  , showFailError, mergeMError, failWith, failSer, failMsg, weaveJust+  , sortSlots, memberCycle, memberBack, partyAfterLeader+  , pickLeader, pickLeaderWithPointer+  , itemOverlay, statsOverlay, pickNumber+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.Char as Char+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import Data.Function+import Data.Ord+import qualified Data.Text as T+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Client.CommonM+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Client.UI.ActorUI+import Game.LambdaHack.Client.UI.EffectDescription+import Game.LambdaHack.Client.UI.ItemDescription+import Game.LambdaHack.Client.UI.ItemSlot+import qualified Game.LambdaHack.Client.UI.Key as K+import Game.LambdaHack.Client.UI.MonadClientUI+import Game.LambdaHack.Client.UI.MsgM+import Game.LambdaHack.Client.UI.Overlay+import Game.LambdaHack.Client.UI.OverlayM+import Game.LambdaHack.Client.UI.SessionUI+import Game.LambdaHack.Client.UI.Slideshow+import Game.LambdaHack.Client.UI.SlideshowM+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.ItemStrongest+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Content.ItemKind as IK++newtype FailError = FailError {failError :: Text}+  deriving Show++showFailError :: FailError -> Text+showFailError (FailError err) = "*" <> err <> "*"++type MError = Maybe FailError++mergeMError :: MError -> MError -> MError+mergeMError Nothing Nothing = Nothing+mergeMError merr1@Just{} Nothing = merr1+mergeMError Nothing merr2@Just{} = merr2+mergeMError (Just err1) (Just err2) =+  Just $ FailError $ failError err1 <+> "and" <+> failError err2++type FailOrCmd a = Either FailError a++failWith :: MonadClientUI m => Text -> m (FailOrCmd a)+failWith err = assert (not $ T.null err) $ return $ Left $ FailError err++failSer :: MonadClientUI m => ReqFailure -> m (FailOrCmd a)+failSer = failWith . showReqFailure++failMsg :: MonadClientUI m => Text -> m MError+failMsg err = assert (not $ T.null err) $ return $ Just $ FailError err++weaveJust :: FailOrCmd a -> Either MError a+weaveJust (Left ferr) = Left $ Just ferr+weaveJust (Right a) = Right a++sortSlots :: MonadClientUI m => FactionId -> Maybe Actor -> m ()+sortSlots fid mbody = do+  itemToF <- itemToFullClient+  s <- getState+  let -- If apperance the same, keep the order from before sort.+      apperance ItemFull{itemBase} =+        (jsymbol itemBase, jname itemBase, jflavour itemBase)+      compareItemFull itemFull1 itemFull2 =+        case ( jsymbol (itemBase itemFull1)+             , jsymbol (itemBase itemFull2) ) of+          ('$', '$') -> EQ+          ('$', _) -> LT+          (_, '$') -> GT+          _ -> case (itemDisco itemFull1, itemDisco itemFull2) of+            (Nothing, Nothing) -> comparing apperance itemFull1 itemFull2+            (Nothing, Just{}) -> LT+            (Just{}, Nothing) -> GT+            (Just id1, Just id2) ->+              case compare (itemKindId id1) (itemKindId id2) of+                EQ -> comparing itemAspect id1 id2+                ot -> ot+      sortSlotMap :: Bool -> EM.EnumMap SlotChar ItemId+                  -> EM.EnumMap SlotChar ItemId+      sortSlotMap onlyOrgans em =+        let onPerson = sharedAllOwnedFid onlyOrgans fid s+            onGround = maybe EM.empty+                         -- consider floor only under the acting actor+                       (\b -> getFloorBag (blid b) (bpos b) s)+                       mbody+            inBags = ES.unions $ map EM.keysSet+                     $ onPerson : [ onGround | not onlyOrgans]+            f = (`ES.member` inBags)+            (nearItems, farItems) = partition f $ EM.elems em+            g iid = (iid, itemToF iid (1, []))+            sortItemIds l =+              map fst $ sortBy (compareItemFull `on` snd) $ map g l+            nearItemAsc = zip newSlots $ sortItemIds nearItems+            farLen = if isNothing mbody then 0 else length allZeroSlots+            farSlots = drop (length nearItemAsc + farLen) newSlots+            farItemAsc = zip farSlots $ sortItemIds farItems+            newSlots = concatMap allSlots [0..]+        in EM.fromDistinctAscList $ nearItemAsc ++ farItemAsc+  ItemSlots itemSlots organSlots <- getsSession sslots+  let newSlots = ItemSlots (sortSlotMap False itemSlots)+                           (sortSlotMap True organSlots)+  modifySession $ \sess -> sess {sslots = newSlots}++-- | Switches current member to the next on the level, if any, wrapping.+memberCycle :: MonadClientUI m => Bool -> m MError+memberCycle verbose = do+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  lidV <- viewedLevelUI+  leader <- getLeaderUI+  body <- getsState $ getActorBody leader+  hs <- partyAfterLeader leader+  let (autoDun, _) = autoDungeonLevel fact+  case filter (\(_, b, _) -> blid b == lidV) hs of+    _ | autoDun && lidV /= blid body ->+      failMsg $ showReqFailure NoChangeDunLeader+    [] -> failMsg "cannot pick any other member on this level"+    (np, b, _) : _ -> do+      success <- pickLeader verbose np+      let !_A = assert (success `blame` "same leader"+                                `twith` (leader, np, b)) ()+      return Nothing++-- | Switches current member to the previous in the whole dungeon, wrapping.+memberBack :: MonadClientUI m => Bool -> m MError+memberBack verbose = do+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  leader <- getLeaderUI+  hs <- partyAfterLeader leader+  let (autoDun, _) = autoDungeonLevel fact+  case reverse hs of+    _ | autoDun -> failMsg $ showReqFailure NoChangeDunLeader+    [] -> failMsg "no other member in the party"+    (np, b, _) : _ -> do+      success <- pickLeader verbose np+      let !_A = assert (success `blame` "same leader"+                                `twith` (leader, np, b)) ()+      return Nothing++partyAfterLeader :: MonadClientUI m => ActorId -> m [(ActorId, Actor, ActorUI)]+partyAfterLeader leader = do+  side <- getsState $ bfid . getActorBody leader+  sactorUI <- getsSession sactorUI+  allA <- getsState $ EM.assocs . sactorD  -- not only on one level+  let allOurs = filter (\(_, body) ->+        not (bproj body) && bfid body == side) allA+      allOursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) allOurs+      hs = sortBy (comparing keySelected) allOursUI+      i = fromMaybe (-1) $ findIndex (\(aid, _, _) -> aid == leader) hs+      (lt, gt) = (take i hs, drop (i + 1) hs)+  return $! gt ++ lt++-- | Select a faction leader. False, if nothing to do.+pickLeader :: MonadClientUI m => Bool -> ActorId -> m Bool+pickLeader verbose aid = do+  leader <- getLeaderUI+  saimMode <- getsSession saimMode+  if leader == aid+    then return False -- already picked+    else do+      body <- getsState $ getActorBody aid+      bodyUI <- getsSession $ getActorUI aid+      let !_A = assert (not (bproj body)+                        `blame` "projectile chosen as the leader"+                        `twith` (aid, body)) ()+      -- Even if it's already the leader, give his proper name, not 'you'.+      let subject = partActor bodyUI+      when verbose $ msgAdd $ makeSentence [subject, "picked as a leader"]+      -- Update client state.+      s <- getState+      modifyClient $ updateLeader aid s+      -- Move the xhair, if active, to the new level.+      case saimMode of+        Nothing -> return ()+        Just _ ->+          modifySession $ \sess -> sess {saimMode = Just $ AimMode $ blid body}+      -- Inform about items, etc.+      lookMsg <- lookAt False "" True (bpos body) aid ""+      when verbose $ msgAdd lookMsg+      return True++pickLeaderWithPointer :: MonadClientUI m => m MError+pickLeaderWithPointer = do+  lidV <- viewedLevelUI+  Level{lysize} <- getLevel lidV+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  arena <- getArenaUI+  sactorUI <- getsSession sactorUI+  ours <- getsState $ filter (not . bproj . snd)+                      . actorAssocs (== side) lidV+  let oursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) ours+      viewed = sortBy (comparing keySelected) oursUI+      (autoDun, _) = autoDungeonLevel fact+      pick (aid, b) =+        if | blid b /= arena && autoDun ->+               failMsg $ showReqFailure NoChangeDunLeader+           | otherwise -> do+               void $ pickLeader True aid+               return Nothing+  Point{..} <- getsSession spointer+  -- Pick even if no space in status line for the actor's symbol.+  if | py == lysize + 2 && px == 0 -> memberBack True+     | py == lysize + 2 ->+         case drop (px - 1) viewed of+           [] -> return Nothing  -- relaxed, due to subtleties of selected display+           (aid, b, _) : _ -> pick (aid, b)+     | otherwise ->+         case find (\(_, b, _) -> bpos b == Point px (py - mapStartY)) oursUI of+           Nothing -> failMsg "not pointing at an actor"+           Just (aid, b, _) -> pick (aid, b)++-- | Create a list of item names.+itemOverlay :: MonadClientUI m => CStore -> LevelId -> ItemBag -> m OKX+itemOverlay store lid bag = do+  localTime <- getsState $ getLocalTime lid+  itemToF <- itemToFullClient+  ItemSlots itemSlots organSlots <- getsSession sslots+  side <- getsClient sside+  factionD <- getsState sfactionD+  sEqp <- getsState $ sharedEqp side+  let isOrgan = store == COrgan+      lSlots = if isOrgan then organSlots else itemSlots+      !_A = assert (all (`elem` EM.elems lSlots) (EM.keys bag)+                    `blame` (store, lid, bag, lSlots)) ()+      markEqp iid t =+        if store /= CEqp && not isOrgan && iid `EM.member` sEqp+        then T.snoc (T.init t) '>'+        else t+      pr (l, iid) =+        case EM.lookup iid bag of+          Nothing -> Nothing+          Just kit@(k, _) ->+            let itemFull = itemToF iid kit+                colorSymbol = viewItem $ itemBase itemFull+                phrase =+                  makePhrase [partItemWsRanged side factionD+                                               k store localTime itemFull]+                al = textToAL (markEqp iid $ slotLabel l)+                     <+:> [colorSymbol]+                     <+:> textToAL phrase+                kx = (Right l, (undefined, 0, length al))+            in Just ([al], kx)+      (ts, kxs) = unzip $ mapMaybe pr $ EM.assocs lSlots+      renumber y (km, (_, x1, x2)) = (km, (y, x1, x2))+  return (concat ts, zipWith renumber [0..] kxs)++statsOverlay :: MonadClient m => ActorId -> m OKX+statsOverlay aid = do+  b <- getsState $ getActorBody aid+  actorAspect <- getsClient sactorAspect+  let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect)+      prSlot :: (Y, SlotChar) -> IK.EqpSlot -> (Text, KYX)+      prSlot (y, c) eqpSlot =+        let statName = slotToName eqpSlot+            fullText t =+              makePhrase [ MU.Text $ slotLabel c+                         , MU.Text $ T.justifyLeft 22 ' ' statName+                         , MU.Text t ]+            valueText = slotToDecorator eqpSlot b $ prEqpSlot eqpSlot ar+            ft = fullText valueText+        in (ft, (Right c, (y, 0, T.length ft)))+      (ts, kxs) = unzip $ zipWith prSlot (zip [0..] allZeroSlots) statSlots+  return (map textToAL ts, kxs)++pickNumber :: MonadClientUI m => Bool -> Int -> m (Either MError Int)+pickNumber askNumber kAll = do+  let shownKeys = [ K.returnKM, K.mkChar '+', K.mkChar '-'+                  , K.spaceKM, K.escKM ]+      frontKeyKeys = K.backspaceKM : shownKeys ++ map K.mkChar ['0'..'9']+      gatherNumber pointer kCurRaw = do+        let kCur = min kAll $ max 1 kCurRaw+            kprompt = "Choose number:" <+> tshow kCur+        promptAdd kprompt+        sli <- reportToSlideshow shownKeys+        (Left kkm, pointer2) <-+          displayChoiceScreen ColorFull False pointer sli frontKeyKeys+        case K.key kkm of+          K.Char '+' ->+            gatherNumber pointer2 $ if kCur + 1 > kAll then 1 else kCur + 1+          K.Char '-' ->+            gatherNumber pointer2 $ if kCur - 1 < 1 then kAll else kCur - 1+          K.Char l | kCur == kAll ->  gatherNumber pointer2 $ Char.digitToInt l+          K.Char l -> gatherNumber pointer2 $ kCur * 10 + Char.digitToInt l+          K.BackSpace -> gatherNumber pointer2 $ kCur `div` 10+          K.Return -> return $ Right kCur+          K.Esc -> weaveJust <$> failWith "never mind"+          K.Space -> return $ Left Nothing+          _ -> assert `failure` "unexpected key:" `twith` kkm+  if | kAll == 0 -> weaveJust <$> failWith "no number of items can be chosen"+     | kAll == 1 || not askNumber -> return $ Right kAll+     | otherwise -> do+         res <- gatherNumber 0 kAll+         case res of+           Right k | k <= 0 -> assert `failure` (res, kAll)+           _ -> return res

− Game/LambdaHack/Client/UI/HandleHumanClient.hs

@@ -1,95 +0,0 @@--- | Semantics of human player commands.-module Game.LambdaHack.Client.UI.HandleHumanClient-  ( cmdHumanSem-  ) where--import Control.Applicative-import Data.Monoid--import Game.LambdaHack.Client.UI.HandleHumanGlobalClient-import Game.LambdaHack.Client.UI.HandleHumanLocalClient-import Game.LambdaHack.Client.UI.HumanCmd-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Client.UI.MsgClient-import Game.LambdaHack.Common.Request---- | The semantics of human player commands in terms of the @Action@ monad.--- Decides if the action takes time and what action to perform.--- Some time cosuming commands are enabled in targeting mode, but cannot be--- invoked in targeting mode on a remote level (level different than--- the level of the leader).-cmdHumanSem :: MonadClientUI m => HumanCmd -> m (SlideOrCmd RequestUI)-cmdHumanSem cmd =-  if noRemoteHumanCmd cmd then do-    -- If in targeting mode, check if the current level is the same-    -- as player level and refuse performing the action otherwise.-    arena <- getArenaUI-    lidV <- viewedLevel-    if arena /= lidV then-      failWith "command disabled on a remote level, press ESC to switch back"-    else cmdAction cmd-  else cmdAction cmd---- | Compute the basic action for a command and mark whether it takes time.-cmdAction :: MonadClientUI m => HumanCmd -> m (SlideOrCmd RequestUI)-cmdAction cmd = case cmd of-  -- Global.-  Move v -> fmap anyToUI <$> moveRunHuman True True False False v-  Run v -> fmap anyToUI <$> moveRunHuman True True True True v-  Wait -> Right <$> fmap ReqUITimed waitHuman-  MoveItem cLegalRaw toCStore mverb _ auto ->-    fmap ReqUITimed <$> moveItemHuman cLegalRaw toCStore mverb auto-  DescribeItem cstore -> fmap ReqUITimed <$> describeItemHuman cstore-  Project ts -> fmap ReqUITimed <$> projectHuman ts-  Apply ts -> fmap ReqUITimed <$> applyHuman ts-  AlterDir ts -> fmap ReqUITimed <$> alterDirHuman ts-  TriggerTile ts -> fmap ReqUITimed <$> triggerTileHuman ts-  RunOnceAhead -> fmap anyToUI <$> runOnceAheadHuman-  MoveOnceToCursor -> fmap anyToUI <$> moveOnceToCursorHuman-  RunOnceToCursor  -> fmap anyToUI <$> runOnceToCursorHuman-  ContinueToCursor -> fmap anyToUI <$> continueToCursorHuman--  GameRestart t -> gameRestartHuman t-  GameExit -> gameExitHuman-  GameSave -> fmap Right gameSaveHuman-  Tactic -> tacticHuman-  Automate -> automateHuman--  -- Local.-  GameDifficultyCycle -> addNoSlides gameDifficultyCycle-  PickLeader k -> Left <$> pickLeaderHuman k-  MemberCycle -> Left <$> memberCycleHuman-  MemberBack -> Left <$> memberBackHuman-  SelectActor -> addNoSlides selectActorHuman-  SelectNone -> addNoSlides selectNoneHuman-  Clear -> addNoSlides clearHuman-  StopIfTgtMode -> addNoSlides stopIfTgtModeHuman-  SelectWithPointer -> addNoSlides selectWithPointer-  Repeat n -> addNoSlides $ repeatHuman n-  Record -> Left <$> recordHuman-  History -> Left <$> historyHuman-  MarkVision -> addNoSlides markVisionHuman-  MarkSmell -> addNoSlides markSmellHuman-  MarkSuspect -> addNoSlides markSuspectHuman-  Help -> Left <$> helpHuman-  MainMenu -> Left <$> mainMenuHuman-  Macro _ kms -> addNoSlides $ macroHuman kms--  MoveCursor v k -> Left <$> moveCursorHuman v k-  TgtFloor -> Left <$> tgtFloorHuman-  TgtEnemy -> Left <$> tgtEnemyHuman-  TgtAscend k -> Left <$> tgtAscendHuman k-  EpsIncr b -> Left <$> epsIncrHuman b-  TgtClear -> Left <$> tgtClearHuman-  CursorUnknown -> Left <$> cursorUnknownHuman-  CursorItem -> Left <$> cursorItemHuman-  CursorStair up -> Left <$> cursorStairHuman up-  Cancel -> Left <$> cancelHuman mainMenuHuman-  Accept -> Left <$> acceptHuman helpHuman-  CursorPointerFloor -> addNoSlides cursorPointerFloorHuman-  CursorPointerEnemy -> addNoSlides cursorPointerEnemyHuman-  TgtPointerFloor -> Left <$> tgtPointerFloorHuman-  TgtPointerEnemy -> Left <$> tgtPointerEnemyHuman--addNoSlides :: Monad m => m () -> m (SlideOrCmd RequestUI)-addNoSlides cmdCli = cmdCli >> return (Left mempty)

− Game/LambdaHack/Client/UI/HandleHumanGlobalClient.hs

@@ -1,872 +0,0 @@-{-# 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-    moveRunHuman, waitHuman, moveItemHuman, describeItemHuman-  , projectHuman, applyHuman, alterDirHuman, triggerTileHuman-  , runOnceAheadHuman, moveOnceToCursorHuman-  , runOnceToCursorHuman, continueToCursorHuman-    -- * Commands that never take time-  , gameRestartHuman, gameExitHuman, gameSaveHuman, tacticHuman, automateHuman-  ) where--import Control.Applicative-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.List-import Data.Maybe-import Data.Monoid-import Data.Text (Text)-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Client.BfsClient-import Game.LambdaHack.Client.CommonClient-import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.Config-import Game.LambdaHack.Client.UI.HandleHumanLocalClient-import Game.LambdaHack.Client.UI.HumanCmd (Trigger (..))-import Game.LambdaHack.Client.UI.InventoryClient-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Client.UI.MsgClient-import Game.LambdaHack.Client.UI.RunClient-import Game.LambdaHack.Client.UI.WidgetClient-import Game.LambdaHack.Common.Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.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.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Vector-import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.TileKind (TileKind)-import qualified Game.LambdaHack.Content.TileKind as TK---- * Move and Run--moveRunHuman :: MonadClientUI m-             => Bool -> Bool -> Bool -> Bool -> Vector-             -> m (SlideOrCmd RequestAnyAbility)-moveRunHuman initialStep finalGoal run runAhead dir = do-  tgtMode <- getsClient stgtMode-  if isJust tgtMode then-    Left <$> moveCursorHuman dir (if run then 10 else 1)-  else do-    arena <- getArenaUI-    leader <- getLeaderUI-    sb <- getsState $ getActorBody leader-    fact <- getsState $ (EM.! bfid sb) . sfactionD-    -- Start running in the given direction. The first turn of running-    -- succeeds much more often than subsequent turns, because we ignore-    -- most of the disturbances, since the player is mostly aware of them-    -- and still explicitly requests a run, knowing how it behaves.-    sel <- getsClient sselected-    let runMembers = if runAhead || noRunWithMulti fact-                     then [leader]  -- TODO: warn?-                     else ES.toList (ES.delete leader sel) ++ [leader]-        runParams = RunParams { runLeader = leader-                              , runMembers-                              , runInitial = True-                              , runStopMsg = Nothing-                              , runWaiting = 0 }-        macroRun25 = ["CTRL-comma", "CTRL-V"]-    when (initialStep && run) $ do-      modifyClient $ \cli ->-        cli {srunning = Just runParams}-      when runAhead $-        modifyClient $ \cli ->-          cli {slastPlay = map K.mkKM macroRun25 ++ slastPlay cli}-    -- When running, the invisible actor is hit (not displaced!),-    -- so that running in the presence of roving invisible-    -- actors is equivalent to moving (with visible actors-    -- this is not a problem, since runnning stops early enough).-    -- TODO: stop running at invisible actor-    let tpos = bpos sb `shift` dir-    -- We start by checking actors at the the target position,-    -- which gives a partial information (actors can be invisible),-    -- as opposed to accessibility (and items) which are always accurate-    -- (tiles can't be invisible).-    tgts <- getsState $ posToActors tpos arena-    case tgts of-      [] -> do  -- move or search or alter-        runStopOrCmd <- moveSearchAlterAid leader dir-        case runStopOrCmd of-          Left stopMsg -> failWith stopMsg-          Right runCmd ->-            -- Don't check @initialStep@ and @finalGoal@-            -- and don't stop going to target: door opening is mundane enough.-            return $ Right runCmd-      [(target, _)] | run && initialStep ->-        -- No @stopPlayBack@: initial displace is benign enough.-        -- Displacing requires accessibility, but it's checked later on.-        fmap RequestAnyAbility <$> displaceAid target-      _ : _ : _ | run && initialStep -> do-        let !_A = assert (all (bproj . snd) tgts) ()-        failSer DisplaceProjectiles-      (target, tb) : _ | initialStep && finalGoal -> do-        stopPlayBack  -- don't ever auto-repeat melee-        -- No problem if there are many projectiles at the spot. We just-        -- attack the first one.-        -- We always see actors from our own faction.-        if bfid tb == bfid sb && not (bproj tb) then do-          let autoLvl = snd $ autoDungeonLevel fact-          if autoLvl then failSer NoChangeLvlLeader-          else do-            -- Select adjacent actor by bumping into him. Takes no time.-            success <- pickLeader True target-            let !_A = assert (success `blame` "bump self"-                                      `twith` (leader, target, tb)) ()-            return $ Left mempty-        else-          -- Attacking does not require full access, adjacency is enough.-          fmap RequestAnyAbility <$> meleeAid target-      _ : _ -> failWith "actor in the way"---- | Actor atttacks an enemy actor or his own projectile.-meleeAid :: MonadClientUI m-         => ActorId -> m (SlideOrCmd (RequestTimed 'AbMelee))-meleeAid target = do-  leader <- getLeaderUI-  sb <- getsState $ getActorBody leader-  tb <- getsState $ getActorBody target-  sfact <- getsState $ (EM.! bfid sb) . sfactionD-  mel <- pickWeaponClient leader target-  case mel of-    Nothing -> failWith "nothing to melee with"-    Just wp -> do-      let returnCmd = return $ Right wp-          res | bproj tb || isAtWar sfact (bfid tb) = returnCmd-              | isAllied sfact (bfid tb) = do-                go1 <- displayYesNo ColorBW-                         "You are bound by an alliance. Really attack?"-                if not go1 then failWith "attack canceled" else returnCmd-              | otherwise = do-                go2 <- displayYesNo ColorBW-                         "This attack will start a war. Are you sure?"-                if not go2 then failWith "attack canceled" else returnCmd-      res-  -- Seeing the actor prevents altering a tile under it, but that-  -- does not limit the player, he just doesn't waste a turn-  -- on a failed altering.---- | Actor swaps position with another.-displaceAid :: MonadClientUI m-            => ActorId -> m (SlideOrCmd (RequestTimed 'AbDisplace))-displaceAid target = do-  cops <- getsState scops-  leader <- getLeaderUI-  sb <- getsState $ getActorBody leader-  tb <- getsState $ getActorBody target-  tfact <- getsState $ (EM.! bfid tb) . sfactionD-  activeItems <- activeItemsClient target-  disp <- getsState $ dispEnemy leader target activeItems-  let actorMaxSk = sumSkills activeItems-      immobile = EM.findWithDefault 0 AbMove actorMaxSk <= 0-      spos = bpos sb-      tpos = bpos tb-      adj = checkAdjacent sb tb-      atWar = isAtWar tfact (bfid sb)-  if not adj then failSer DisplaceDistant-  else if not (bproj tb) && atWar-          && actorDying tb then failSer DisplaceDying-  else if not (bproj tb) && atWar-          && braced tb then failSer DisplaceBraced-  else if not (bproj tb) && atWar-          && immobile then failSer DisplaceImmobile-  else if not disp && atWar then failSer DisplaceSupported-  else do-    let lid = blid sb-    lvl <- getLevel lid-    -- Displacing requires full access.-    if accessible cops lvl spos tpos then do-      tgts <- getsState $ posToActors tpos lid-      case tgts of-        [] -> assert `failure` (leader, sb, target, tb)-        [_] -> return $ Right $ ReqDisplace target-        _ -> failSer DisplaceProjectiles-    else failSer DisplaceAccess---- | Actor moves or searches or alters. No visible actor at the position.-moveSearchAlterAid :: MonadClient m-                   => ActorId -> Vector -> m (Either Msg RequestAnyAbility)-moveSearchAlterAid source dir = do-  cops@Kind.COps{cotile} <- getsState scops-  sb <- getsState $ getActorBody source-  actorSk <- actorSkillsClient source-  lvl <- getLevel $ blid sb-  let skill = EM.findWithDefault 0 AbAlter actorSk-      spos = bpos sb           -- source position-      tpos = spos `shift` dir  -- target position-      t = lvl `at` tpos-      runStopOrCmd-        -- Movement requires full access.-        | accessible cops lvl spos tpos =-            -- A potential invisible actor is hit. War started without asking.-            Right $ RequestAnyAbility $ ReqMove dir-        -- No access, so search and/or alter the tile. Non-walkability is-        -- not implied by the lack of access.-        | not (Tile.isWalkable cotile t)-          && (not (knownLsecret lvl)-              || (isSecretPos lvl tpos  -- possible secrets here-                  && (Tile.isSuspect cotile t  -- not yet searched-                      || Tile.hideAs cotile t /= t))  -- search again-              || Tile.isOpenable cotile t-              || Tile.isClosable cotile t-              || Tile.isChangeable cotile t)-          = if skill < 1 then-              Left $ showReqFailure AlterUnskilled-            else if EM.member tpos $ lfloor lvl then-              Left $ showReqFailure AlterBlockItem-            else-              Right $ RequestAnyAbility $ ReqAlter tpos Nothing-            -- We don't use MoveSer, because we don't hit invisible actors.-            -- The potential invisible actor, e.g., in a wall or in-            -- an inaccessible doorway, is made known, taking a turn.-            -- If server performed an attack for free-            -- on the invisible actor anyway, the player (or AI)-            -- would be tempted to repeatedly hit random walls-            -- in hopes of killing a monster lurking within.-            -- If the action had a cost, misclicks would incur the cost, too.-            -- Right now the player may repeatedly alter tiles trying to learn-            -- about invisible pass-wall actors, but when an actor detected,-            -- it costs a turn and does not harm the invisible actors,-            -- so it's not so tempting.-        -- Ignore a known boring, not accessible tile.-        | otherwise = Left "never mind"-  return $! runStopOrCmd---- * Wait---- | Leader waits a turn (and blocks, etc.).-waitHuman :: MonadClientUI m => m (RequestTimed 'AbWait)-waitHuman = do-  modifyClient $ \cli -> cli {swaitTimes = abs (swaitTimes cli) + 1}-  return ReqWait---- * MoveItem--moveItemHuman :: forall m. MonadClientUI m-              => [CStore] -> CStore -> Maybe MU.Part -> Bool-              -> m (SlideOrCmd (RequestTimed 'AbMoveItem))-moveItemHuman cLegalRaw destCStore mverb auto = do-  let !_A = assert (destCStore `notElem` cLegalRaw) ()-  let verb = fromMaybe (MU.Text $ verbCStore destCStore) mverb-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  activeItems <- activeItemsClient leader-  -- This calmE is outdated when one of the items increases max Calm-  -- (e.g., in pickup, which handles many items at once), but this is OK,-  -- the server accepts item movement based on calm at the start, not end-  -- or in the middle.-  -- The calmE is inaccurate also if an item not IDed, but that's intended-  -- and the server will ignore and warn (and content may avoid that,-  -- e.g., making all rings identified)-  let calmE = calmEnough b activeItems-      cLegal | calmE = cLegalRaw-             | destCStore == CSha = []-             | otherwise = delete CSha cLegalRaw-      ret4 :: MonadClientUI m-           => CStore -> [(ItemId, ItemFull)]-           -> Int -> [(ItemId, Int, CStore, CStore)]-           -> m (Either Slideshow [(ItemId, Int, CStore, CStore)])-      ret4 _ [] _ acc = return $ Right $ reverse acc-      ret4 fromCStore ((iid, itemFull) : rest) oldN acc = do-        let k = itemK itemFull-            retRec toCStore =-              let n = oldN + if toCStore == CEqp then k else 0-              in ret4 fromCStore rest n ((iid, k, fromCStore, toCStore) : acc)-        if cLegalRaw == [CGround]  -- normal pickup-        then case destCStore of-          CEqp | calmE && goesIntoSha itemFull ->-            retRec CSha-          CEqp | not $ goesIntoEqp itemFull ->-            retRec CInv-          CEqp | eqpOverfull b (oldN + k) -> do-            -- If this stack doesn't fit, we don't equip any part of it,-            -- but we may equip a smaller stack later in the same pickup.-            -- TODO: try to ask for a number of items, thus giving the player-            -- the option of picking up a part.-            let fullWarn = if eqpOverfull b (oldN + 1)-                           then EqpOverfull-                           else EqpStackFull-            msgAdd $ "Warning:" <+> showReqFailure fullWarn <> "."-            retRec $ if calmE then CSha else CInv-          _ ->-            retRec destCStore-        else case destCStore of-          CEqp | eqpOverfull b (oldN + k) -> do-            -- If the chosen number from the stack doesn't fit,-            -- we don't equip any part of it and we exit item manipulation.-            let fullWarn = if eqpOverfull b (oldN + 1)-                           then EqpOverfull-                           else EqpStackFull-            failSer fullWarn-          _ -> retRec destCStore-      prompt = makePhrase ["What to", verb]-      promptEqp = makePhrase ["What consumable to", verb]-      p :: CStore -> (Text, m Suitability)-      p cstore = if cstore `elem` [CEqp, CSha] && cLegalRaw /= [CGround]-                 then (promptEqp, return $ SuitsSomething goesIntoEqp)-                 else (prompt, return SuitsEverything)-      (promptGeneric, psuit) = p destCStore-  ggi <--    if auto-    then getAnyItems psuit prompt promptGeneric cLegalRaw cLegal False False-    else getAnyItems psuit prompt promptGeneric cLegalRaw cLegal True True-  case ggi of-    Right (l, MStore fromCStore) -> do-      leader2 <- getLeaderUI-      b2 <- getsState $ getActorBody leader2-      activeItems2 <- activeItemsClient leader2-      let calmE2 = calmEnough b2 activeItems2-      -- This is not ideal, because the failure message comes late,-      -- but it's simple and good enough.-      if not calmE2 && destCStore == CSha then failSer ItemNotCalm-      else do-        l4 <- ret4 fromCStore l 0 []-        return $! case l4 of-          Left sli -> Left sli-          Right [] -> assert `failure` ggi-          Right lr -> Right $ ReqMoveItems lr-    Left slides -> return $ Left slides-    _ -> assert `failure` ggi---- * DescribeItem---- | Display items from a given container store and describe the chosen one.-describeItemHuman :: MonadClientUI m-                  => ItemDialogMode -> m (SlideOrCmd (RequestTimed 'AbMoveItem))-describeItemHuman = describeItemC---- * Project--projectHuman :: forall m. MonadClientUI m-             => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbProject))-projectHuman ts = do-  leader <- getLeaderUI-  lidV <- viewedLevel-  oldTgtMode <- getsClient stgtMode-  -- Show the targeting line, temporarily.-  modifyClient $ \cli -> cli {stgtMode = Just $ TgtMode lidV}-  -- Set cursor to the personal target, permanently.-  tgt <- getsClient $ getTarget leader-  modifyClient $ \cli -> cli {scursor = fromMaybe (scursor cli) tgt}-  -- Let the user pick the item to fling.-  let posFromCursor :: m (Either Msg Point)-      posFromCursor = do-        canAim <- aidTgtAims leader lidV Nothing-        case canAim of-          Right newEps -> do-            -- Modify @seps@, permanently.-            modifyClient $ \cli -> cli {seps = newEps}-            mpos <- aidTgtToPos leader lidV Nothing-            case mpos of-              Nothing -> assert `failure` (tgt, leader, lidV)-              Just pos -> do-                munit <- projectCheck pos-                case munit of-                  Nothing -> return $ Right pos-                  Just reqFail -> return $ Left $ showReqFailure reqFail-          Left cause -> return $ Left cause-  mitem <- projectItem ts posFromCursor-  outcome <- case mitem of-    Right (iid, fromCStore) -> do-      mpos <- posFromCursor-      case mpos of-        Right pos -> do-          eps <- getsClient seps-          return $ Right $ ReqProject pos eps iid fromCStore-        Left cause -> failWith cause-    Left sli -> return $ Left sli-  modifyClient $ \cli -> cli {stgtMode = oldTgtMode}-  return outcome--projectCheck :: MonadClientUI m => Point -> m (Maybe ReqFailure)-projectCheck tpos = do-  Kind.COps{cotile} <- getsState scops-  leader <- getLeaderUI-  eps <- getsClient seps-  sb <- getsState $ getActorBody leader-  let lid = blid sb-      spos = bpos sb-  Level{lxsize, lysize} <- getLevel lid-  case bla lxsize lysize eps spos tpos of-    Nothing -> return $ Just ProjectAimOnself-    Just [] -> assert `failure` "project from the edge of level"-                      `twith` (spos, tpos, sb)-    Just (pos : _) -> do-      lvl <- getLevel lid-      let t = lvl `at` pos-      if not $ Tile.isWalkable cotile t-        then return $ Just ProjectBlockTerrain-        else do-          lab <- getsState $ posToActors pos lid-          if all (bproj . snd) lab-          then return Nothing-          else return $ Just ProjectBlockActor--projectItem :: forall m. MonadClientUI m-            => [Trigger] -> m (Either Msg Point)-            -> m (SlideOrCmd (ItemId, CStore))-projectItem ts posFromCursor = do-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  activeItems <- activeItemsClient leader-  actorSk <- actorSkillsClient leader-  let skill = EM.findWithDefault 0 AbProject actorSk-      calmE = calmEnough b activeItems-      cLegalRaw = [CGround, CInv, CEqp, CSha]-      cLegal | calmE = cLegalRaw-             | otherwise = delete CSha cLegalRaw-      (verb1, object1) = case ts of-        [] -> ("aim", "item")-        tr : _ -> (verb tr, object tr)-      triggerSyms = triggerSymbols ts-      psuitReq :: m (Either Msg (ItemFull -> Either ReqFailure Bool))-      psuitReq = do-        mpos <- posFromCursor-        case mpos of-          Left err -> return $ Left err-          Right pos -> return $ Right $ \itemFull@ItemFull{itemBase} -> do-            let legal = permittedProject triggerSyms False skill-                                         itemFull b activeItems-            case legal of-              Left{} -> legal-              Right False -> legal-              Right True ->-                Right $ totalRange itemBase >= chessDist (bpos b) pos-      psuit :: m Suitability-      psuit = do-        mpsuitReq <- psuitReq-        case mpsuitReq of-          -- If target invalid, no item is considered a (suitable) missile.-          Left err -> return $ SuitsNothing err-          Right psuitReqFun -> return $ SuitsSomething $ \itemFull ->-            case psuitReqFun itemFull of-              Left _ -> False-              Right suit -> suit-      prompt = makePhrase ["What", object1, "to", verb1]-      promptGeneric = "What to fling"-  ggi <- getGroupItem psuit prompt promptGeneric True-                      cLegalRaw cLegal-  case ggi of-    Right ((iid, itemFull), MStore fromCStore) -> do-      mpsuitReq <- psuitReq-      case mpsuitReq of-        Left err -> failWith err-        Right psuitReqFun ->-          case psuitReqFun itemFull of-            Left reqFail -> failSer reqFail-            Right _ -> return $ Right (iid, fromCStore)-    Left slides -> return $ Left slides-    _ -> assert `failure` ggi--triggerSymbols :: [Trigger] -> [Char]-triggerSymbols [] = []-triggerSymbols (ApplyItem{symbol} : ts) = symbol : triggerSymbols ts-triggerSymbols (_ : ts) = triggerSymbols ts---- * Apply--applyHuman :: MonadClientUI m-           => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbApply))-applyHuman ts = do-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  actorSk <- actorSkillsClient leader-  let skill = EM.findWithDefault 0 AbApply actorSk-  activeItems <- activeItemsClient leader-  localTime <- getsState $ getLocalTime (blid b)-  let calmE = calmEnough b activeItems-      cLegalRaw = [CGround, CInv, CEqp, CSha]-      cLegal | calmE = cLegalRaw-             | otherwise = delete CSha cLegalRaw-      (verb1, object1) = case ts of-        [] -> ("apply", "item")-        tr : _ -> (verb tr, object tr)-      triggerSyms = triggerSymbols ts-      p itemFull =-        permittedApply triggerSyms localTime skill itemFull b activeItems-      prompt = makePhrase ["What", object1, "to", verb1]-      promptGeneric = "What to apply"-  ggi <- getGroupItem (return $ SuitsSomething $ either (const False) id . p)-                      prompt promptGeneric False cLegalRaw cLegal-  case ggi of-    Right ((iid, itemFull), MStore fromCStore) ->-      case p itemFull of-        Left reqFail -> failSer reqFail-        Right _ -> return $ Right $ ReqApply iid fromCStore-    Left slides -> return $ Left slides-    _ -> assert `failure` ggi---- * AlterDir---- TODO: accept mouse, too--- | Ask for a direction and alter a tile, if possible.-alterDirHuman :: MonadClientUI m-              => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbAlter))-alterDirHuman ts = do-  Config{configVi, configLaptop} <- askConfig-  let verb1 = case ts of-        [] -> "alter"-        tr : _ -> verb tr-      keys = map (K.toKM K.NoModifier) (K.dirAllKey configVi configLaptop)-      prompt = makePhrase ["What to", verb1 <> "? [movement key"]-  me <- displayChoiceUI prompt emptyOverlay keys-  case me of-    Left slides -> failSlides slides-    Right e -> K.handleDir configVi configLaptop e (`alterTile` ts)-                                                   (failWith "never mind")---- | Player tries to alter a tile using a feature.-alterTile :: MonadClientUI m-          => Vector -> [Trigger] -> m (SlideOrCmd (RequestTimed 'AbAlter))-alterTile dir ts = do-  cops@Kind.COps{cotile} <- getsState scops-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  actorSk <- actorSkillsClient leader-  lvl <- getLevel $ blid b-  as <- getsState $ actorList (const True) (blid b)-  let skill = EM.findWithDefault 0 AbAlter actorSk-      tpos = bpos b `shift` dir-      t = lvl `at` tpos-      alterFeats = alterFeatures ts-  case filter (\feat -> Tile.hasFeature cotile feat t) alterFeats of-    _ | skill < 1 -> failSer AlterUnskilled-    [] -> failWith $ guessAlter cops alterFeats t-    feat : _ ->-      if EM.notMember tpos $ lfloor lvl then-        if unoccupied as tpos then-          return $ Right $ ReqAlter tpos $ Just feat-        else failSer AlterBlockActor-      else failSer AlterBlockItem--alterFeatures :: [Trigger] -> [TK.Feature]-alterFeatures [] = []-alterFeatures (AlterFeature{feature} : ts) = feature : alterFeatures ts-alterFeatures (_ : ts) = alterFeatures ts---- | Guess and report why the bump command failed.-guessAlter :: Kind.COps -> [TK.Feature] -> Kind.Id TileKind -> Msg-guessAlter Kind.COps{cotile} (TK.OpenTo _ : _) t-  | Tile.isClosable cotile t = "already open"-guessAlter _ (TK.OpenTo _ : _) _ = "cannot be opened"-guessAlter Kind.COps{cotile} (TK.CloseTo _ : _) t-  | Tile.isOpenable cotile t = "already closed"-guessAlter _ (TK.CloseTo _ : _) _ = "cannot be closed"-guessAlter _ _ _ = "never mind"---- * TriggerTile---- | Leader tries to trigger the tile he's standing on.-triggerTileHuman :: MonadClientUI m-                 => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbTrigger))-triggerTileHuman ts = do-  tgtMode <- getsClient stgtMode-  if isJust tgtMode then do-    let getK tfs = case tfs of-          TriggerFeature {feature = TK.Cause (IK.Ascend k)} : _ -> Just k-          _ : rest -> getK rest-          [] -> Nothing-        mk = getK ts-    case mk of-      Nothing -> failWith "never mind"-      Just k -> Left <$> tgtAscendHuman k-  else triggerTile ts---- | Player tries to trigger a tile using a feature.-triggerTile :: MonadClientUI m-            => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbTrigger))-triggerTile ts = do-  cops@Kind.COps{cotile} <- getsState scops-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  lvl <- getLevel $ blid b-  let t = lvl `at` bpos b-      triggerFeats = triggerFeatures ts-  case filter (\feat -> Tile.hasFeature cotile feat t) triggerFeats of-    [] -> failWith $ guessTrigger cops triggerFeats t-    feat : _ -> do-      go <- verifyTrigger leader feat-      case go of-        Right () -> return $ Right $ ReqTrigger $ Just feat-        Left slides -> return $ Left slides--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 -> TK.Feature -> m (SlideOrCmd ())-verifyTrigger leader feat = case feat of-  TK.Cause IK.Escape{} -> do-    b <- getsState $ getActorBody leader-    side <- getsClient sside-    fact <- getsState $ (EM.! side) . sfactionD-    if not (fcanEscape $ gplayer fact) then failWith-      "This is the way out, but where would you go in this alien world?"-    else do-      go <- displayYesNo ColorFull "This is the way out. Really leave now?"-      if not go then failWith "game resumed"-      else do-        (_, total) <- getsState $ calculateTotal b-        if total == 0 then do-          -- The player can back off at each of these steps.-          go1 <- displayMore ColorBW-                   "Afraid of the challenge? Leaving so soon and empty-handed?"-          if not go1 then failWith "brave soul!"-          else do-             go2 <- displayMore ColorBW-                     "Next time try to grab some loot before escape!"-             if not go2 then failWith "here's your chance!"-             else return $ Right ()-        else return $ Right ()-  _ -> return $ Right ()---- | Guess and report why the bump command failed.-guessTrigger :: Kind.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@(TK.Cause (IK.Ascend k) : _) _ =-    if k > 0 then "cannot ascend"-    else if k < 0 then "cannot descend"-    else assert `failure` fs-guessTrigger _ _ _ = "never mind"---- * RunOnceAhead--runOnceAheadHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)-runOnceAheadHuman = do-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  leader <- getLeaderUI-  srunning <- getsClient srunning-  -- When running, stop if disturbed. If not running, stop at once.-  case srunning of-    Nothing -> do-      stopPlayBack-      return $ Left mempty-    Just RunParams{runMembers}-      | noRunWithMulti fact && runMembers /= [leader] -> do-      stopPlayBack-      Config{configRunStopMsgs} <- askConfig-      if configRunStopMsgs-      then failWith "run stop: automatic leader change"-      else return $ Left mempty-    Just runParams -> do-      arena <- getArenaUI-      runOutcome <- continueRun arena runParams-      case runOutcome of-        Left stopMsg -> do-          stopPlayBack-          Config{configRunStopMsgs} <- askConfig-          if configRunStopMsgs-          then failWith $ "run stop:" <+> stopMsg-          else return $ Left mempty-        Right runCmd ->-          return $ Right runCmd---- * MoveOnceToCursor--moveOnceToCursorHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)-moveOnceToCursorHuman = goToCursor True False--goToCursor :: MonadClientUI m-           => Bool -> Bool -> m (SlideOrCmd RequestAnyAbility)-goToCursor initialStep run = do-  tgtMode <- getsClient stgtMode-  -- Movement is legal only outside targeting mode.-  if isJust tgtMode then failWith "cannot move in aiming mode"-  else do-    leader <- getLeaderUI-    b <- getsState $ getActorBody leader-    cursorPos <- cursorToPos-    case cursorPos of-      Nothing -> failWith "crosshair position invalid"-      Just c | c == bpos b ->-        if initialStep-        then return $ Right $ RequestAnyAbility ReqWait-        else do-          report <- getsClient sreport-          if nullReport report-          then return $ Left mempty-          -- Mark that the messages are accumulated, not just from last move.-          else failWith "crosshair now reached"-      Just c -> do-        running <- getsClient srunning-        case running of-          -- Don't use running params from previous run or goto-cursor.-          Just paramOld | not initialStep -> do-            arena <- getArenaUI-            runOutcome <- multiActorGoTo arena c paramOld-            case runOutcome of-              Left stopMsg -> failWith stopMsg-              Right (finalGoal, dir) ->-                moveRunHuman initialStep finalGoal run False dir-          _ -> do-            let !_A = assert (initialStep || not run) ()-            (_, mpath) <- getCacheBfsAndPath leader c-            case mpath of-              Nothing -> failWith "no route to crosshair"-              Just [] -> assert `failure` (leader, b, c)-              Just (p1 : _) -> do-                let finalGoal = p1 == c-                    dir = towards (bpos b) p1-                moveRunHuman initialStep finalGoal run False dir--multiActorGoTo :: MonadClient m-               => LevelId -> Point -> RunParams-               -> m (Either Msg (Bool, Vector))-multiActorGoTo arena c paramOld =-  case paramOld of-    RunParams{runMembers = []} ->-      return $ Left "selected actors no longer there"-    RunParams{runMembers = r : rs, runWaiting} -> do-      onLevel <- getsState $ memActor r arena-      if not onLevel then do-        let paramNew = paramOld {runMembers = rs}-        multiActorGoTo arena c paramNew-      else do-        s <- getState-        modifyClient $ updateLeader r s-        let runMembersNew = rs ++ [r]-            paramNew = paramOld { runMembers = runMembersNew-                                , runWaiting = 0}-        b <- getsState $ getActorBody r-        (_, mpath) <- getCacheBfsAndPath r c-        case mpath of-          Nothing -> return $ Left "no route to crosshair"-          Just [] ->-            -- This actor already at goal; will be caught in goToCursor.-            return $ Left ""-          Just (p1 : _) -> do-            let finalGoal = p1 == c-                dir = towards (bpos b) p1-                tpos = bpos b `shift` dir-            tgts <- getsState $ posToActors tpos arena-            case tgts of-              [] -> do-                modifyClient $ \cli -> cli {srunning = Just paramNew}-                return $ Right (finalGoal, dir)-              [(target, _)]-                | target `elem` rs || runWaiting <= length rs ->-                -- Let r wait until all others move. Mark it in runWaiting-                -- to avoid cycles. When all wait for each other, fail.-                multiActorGoTo arena c paramNew{runWaiting=runWaiting + 1}-              _ ->-                 return $ Left "actor in the way"---- * RunOnceToCursor--runOnceToCursorHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)-runOnceToCursorHuman = goToCursor True True---- * ContinueToCursor--continueToCursorHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)-continueToCursorHuman = goToCursor False False{-irrelevant-}---- * GameRestart; does not take time--gameRestartHuman :: MonadClientUI m => GroupName ModeKind -> m (SlideOrCmd RequestUI)-gameRestartHuman t = do-  let restart = do-        leader <- getLeaderUI-        snxtDiff <- getsClient snxtDiff-        Config{configHeroNames} <- askConfig-        return $ Right-               $ ReqUIGameRestart leader t snxtDiff configHeroNames-  escAI <- getsClient sescAI-  if escAI == EscAIExited then restart-  else do-    let msg = "You just requested a new" <+> tshow t <+> "game."-    b1 <- displayMore ColorFull msg-    if not b1 then failWith "never mind"-    else do-      b2 <- displayYesNo ColorBW-              "Current progress will be lost! Really restart the game?"-      msg2 <- rndToAction $ oneOf-                [ "yea, would be a pity to leave them all to die"-                , "yea, a shame to get your own team stranded" ]-      if not b2 then failWith msg2-      else restart---- * GameExit; does not take time--gameExitHuman :: MonadClientUI m => m (SlideOrCmd RequestUI)-gameExitHuman = do-  go <- displayYesNo ColorFull "Really save and exit?"-  if go then do-    leader <- getLeaderUI-    return $ Right $ ReqUIGameExit leader-  else failWith "save and exit canceled"---- * GameSave; does not take time--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---- * Tactic; does not take time---- Note that the difference between seek-target and follow-the-leader tactic--- can influence even a faction with passive actors. E.g., if a passive actor--- has an extra active skill from equipment, he moves every turn.--- TODO: set tactic for allied passive factions, too or all allied factions--- and perhaps even factions with a leader should follow our leader--- and his target, not their leader.-tacticHuman :: MonadClientUI m => m (SlideOrCmd RequestUI)-tacticHuman = do-  fid <- getsClient sside-  fromT <- getsState $ ftactic . gplayer . (EM.! fid) . sfactionD-  let toT = if fromT == maxBound then minBound else succ fromT-  go <- displayMore ColorFull-        $ "Current tactic is '" <> tshow fromT-          <> "'. Switching tactic to '" <> tshow toT-          <> "'. (This clears targets.)"-  if not go-    then failWith "tactic change canceled"-    else return $ Right $ ReqUITactic toT---- * Automate; does not take time--automateHuman :: MonadClientUI m => m (SlideOrCmd RequestUI)-automateHuman = do-  -- BFS is not updated while automated, which would lead to corruption.-  modifyClient $ \cli -> cli {stgtMode = Nothing}-  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

+ Game/LambdaHack/Client/UI/HandleHumanGlobalM.hs view

@@ -0,0 +1,1375 @@+{-# 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.+module Game.LambdaHack.Client.UI.HandleHumanGlobalM+  ( -- * Meta commands+    byAreaHuman, byAimModeHuman, byItemModeHuman+  , composeIfLocalHuman, composeUnlessErrorHuman, compose2ndLocalHuman+  , loopOnNothingHuman+    -- * Global commands that usually take time+  , waitHuman, waitHuman10, moveRunHuman+  , runOnceAheadHuman, moveOnceToXhairHuman+  , runOnceToXhairHuman, continueToXhairHuman+  , moveItemHuman, projectHuman, applyHuman+  , alterDirHuman, alterWithPointerHuman+  , helpHuman, itemMenuHuman, chooseItemMenuHuman+  , mainMenuHuman, settingsMenuHuman, challengesMenuHuman+  , gameDifficultyIncr, gameWolfToggle, gameFishToggle, gameScenarioIncr+    -- * Global commands that never take time+  , gameRestartHuman, gameExitHuman, gameSaveHuman+  , tacticHuman, automateHuman+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++-- Cabal+import qualified Paths_LambdaHack as Self (version)++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.Map.Strict as M+import qualified Data.Text as T+import Data.Version+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Client.Bfs+import Game.LambdaHack.Client.BfsM+import Game.LambdaHack.Client.CommonM+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Client.UI.ActorUI+import Game.LambdaHack.Client.UI.Config+import Game.LambdaHack.Client.UI.FrameM+import Game.LambdaHack.Client.UI.Frontend (frontendName)+import Game.LambdaHack.Client.UI.HandleHelperM+import Game.LambdaHack.Client.UI.HandleHumanLocalM+import Game.LambdaHack.Client.UI.HumanCmd (CmdArea (..), Trigger (..))+import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd+import Game.LambdaHack.Client.UI.InventoryM+import qualified Game.LambdaHack.Client.UI.Key as K+import Game.LambdaHack.Client.UI.KeyBindings+import Game.LambdaHack.Client.UI.MonadClientUI+import Game.LambdaHack.Client.UI.Msg+import Game.LambdaHack.Client.UI.MsgM+import Game.LambdaHack.Client.UI.Overlay+import Game.LambdaHack.Client.UI.RunM+import Game.LambdaHack.Client.UI.SessionUI+import Game.LambdaHack.Client.UI.Slideshow+import Game.LambdaHack.Client.UI.SlideshowM+import Game.LambdaHack.Common.Ability+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Content.TileKind (TileKind)+import qualified Game.LambdaHack.Content.TileKind as TK++-- * ByArea++-- | Pick command depending on area the mouse pointer is in.+-- The first matching area is chosen. If none match, only interrupt.+byAreaHuman :: MonadClientUI m+            => (HumanCmd.HumanCmd -> m (Either MError ReqUI))+            -> [(HumanCmd.CmdArea, HumanCmd.HumanCmd)]+            -> m (Either MError ReqUI)+byAreaHuman cmdAction l = do+  pointer <- getsSession spointer+  let pointerInArea a = do+        rs <- areaToRectangles a+        return $! any (inside pointer) rs+  cmds <- filterM (pointerInArea . fst) l+  case cmds of+    [] -> do+      stopPlayBack+      return $ Left Nothing+    (_, cmd) : _ ->+      cmdAction cmd++areaToRectangles :: MonadClientUI m => HumanCmd.CmdArea -> m [(X, Y, X, Y)]+areaToRectangles ca = case ca of+  CaMessage -> return [(0, 0, fst normalLevelBound, 0)]+  CaMapLeader -> do  -- takes preference over @CaMapParty@ and @CaMap@+    leader <- getLeaderUI+    b <- getsState $ getActorBody leader+    let Point{..} = bpos b+    return [(px, mapStartY + py, px, mapStartY + py)]+  CaMapParty -> do  -- takes preference over @CaMap@+    lidV <- viewedLevelUI+    side <- getsClient sside+    ours <- getsState $ filter (not . bproj) . map snd+                        . actorAssocs (== side) lidV+    let rectFromB Point{..} = (px, mapStartY + py, px, mapStartY + py)+    return $! map (rectFromB . bpos) ours+  CaMap -> return+    [( 0, mapStartY, fst normalLevelBound, mapStartY + snd normalLevelBound )]+  CaLevelNumber -> let y = snd normalLevelBound + 2+                   in return [(0, y, 1, y)]+  CaArenaName -> let y = snd normalLevelBound + 2+                     x = fst normalLevelBound `div` 2 - 11+                 in return [(3, y, x, y)]+  CaPercentSeen -> let y = snd normalLevelBound + 2+                       x = fst normalLevelBound `div` 2+                   in return [(x - 9, y, x, y)]+  CaXhairDesc -> let y = snd normalLevelBound + 2+                     x = fst normalLevelBound `div` 2 + 2+                 in return [(x, y, fst normalLevelBound, y)]+  CaSelected -> let y = snd normalLevelBound + 3+                    x = fst normalLevelBound `div` 2+                in return [(0, y, x - 24, y)]+  CaCalmGauge -> let y = snd normalLevelBound + 3+                     x = fst normalLevelBound `div` 2+                 in return [(x - 22, y, x - 11, y)]+  CaHPGauge -> let y = snd normalLevelBound + 3+                   x = fst normalLevelBound `div` 2+               in return [(x - 9, y, x, y)]+  CaTargetDesc -> let y = snd normalLevelBound + 3+                      x = fst normalLevelBound `div` 2 + 2+                  in return [(x, y, fst normalLevelBound, y)]++-- * ByAimMode++byAimModeHuman :: MonadClientUI m+               => m (Either MError ReqUI) -> m (Either MError ReqUI)+               -> m (Either MError ReqUI)+byAimModeHuman cmdNotAimingM cmdAimingM = do+  aimMode <- getsSession saimMode+  if isNothing aimMode then cmdNotAimingM else cmdAimingM++-- * ByItemMode++byItemModeHuman :: MonadClientUI m+                => [Trigger]+                -> m (Either MError ReqUI) -> m (Either MError ReqUI)+                -> m (Either MError ReqUI)+byItemModeHuman ts cmdNotChosenM cmdChosenM = do+  itemSel <- getsSession sitemSel+  let triggerSyms = triggerSymbols ts+  case itemSel of+    Just (fromCStore, iid) -> do+      leader <- getLeaderUI+      b <- getsState $ getActorBody leader+      bag <- getsState $ getBodyStoreBag b fromCStore+      itemBase <- getsState $ getItemBody iid+      case iid `EM.lookup` bag of+        Just _ | ' ' `elem` triggerSyms+                 || jsymbol itemBase `elem` triggerSyms -> cmdChosenM+        _ -> cmdNotChosenM+    Nothing -> cmdNotChosenM++-- * ComposeIfLeft++composeIfLocalHuman :: MonadClientUI m+                    => m (Either MError ReqUI) -> m (Either MError ReqUI)+                    -> m (Either MError ReqUI)+composeIfLocalHuman c1 c2 = do+  slideOrCmd1 <- c1+  case slideOrCmd1 of+    Left merr1 -> do+      slideOrCmd2 <- c2+      case slideOrCmd2 of+        Left merr2 -> return $ Left $ mergeMError merr1 merr2+        _ -> return slideOrCmd2+    _ -> return slideOrCmd1++-- * ComposeUnlessError++composeUnlessErrorHuman :: MonadClientUI m+                        => m (Either MError ReqUI) -> m (Either MError ReqUI)+                        -> m (Either MError ReqUI)+composeUnlessErrorHuman c1 c2 = do+  slideOrCmd1 <- c1+  case slideOrCmd1 of+    Left Nothing -> c2+    _ -> return slideOrCmd1++-- * Compose2ndLocal++compose2ndLocalHuman :: MonadClientUI m+                     => m (Either MError ReqUI) -> m (Either MError ReqUI)+                     -> m (Either MError ReqUI)+compose2ndLocalHuman c1 c2 = do+  slideOrCmd1 <- c1+  case slideOrCmd1 of+    Left merr1 -> do+      slideOrCmd2 <- c2+      case slideOrCmd2 of+        Left merr2 -> return $ Left $ mergeMError merr1 merr2+        _ -> return slideOrCmd1  -- ignore second request, keep effect+    req -> do+      void c2  -- ignore second request, keep effect+      return req++-- * LoopOnNothing++loopOnNothingHuman :: MonadClientUI m+                   => m (Either MError ReqUI)+                   -> m (Either MError ReqUI)+loopOnNothingHuman cmd = do+  res <- cmd+  case res of+    Left Nothing -> loopOnNothingHuman cmd+    _ -> return res++-- * Wait++-- | Leader waits a turn (and blocks, etc.).+waitHuman :: MonadClientUI m => m (RequestTimed 'AbWait)+waitHuman = do+  modifySession $ \sess -> sess {swaitTimes = abs (swaitTimes sess) + 1}+  return ReqWait++-- * Wait10++-- | Leader waits a 1/10th of a turn (and doesn't block, etc.).+waitHuman10 :: MonadClientUI m => m (RequestTimed 'AbWait)+waitHuman10 = do+  modifySession $ \sess -> sess {swaitTimes = abs (swaitTimes sess) + 1}+  return ReqWait10++-- * MoveDir and RunDir++moveRunHuman :: MonadClientUI m+             => Bool -> Bool -> Bool -> Bool -> Vector+             -> m (FailOrCmd RequestAnyAbility)+moveRunHuman initialStep finalGoal run runAhead dir = do+  arena <- getArenaUI+  leader <- getLeaderUI+  sb <- getsState $ getActorBody leader+  fact <- getsState $ (EM.! bfid sb) . sfactionD+  -- Start running in the given direction. The first turn of running+  -- succeeds much more often than subsequent turns, because we ignore+  -- most of the disturbances, since the player is mostly aware of them+  -- and still explicitly requests a run, knowing how it behaves.+  sel <- getsSession sselected+  let runMembers = if runAhead || noRunWithMulti fact+                   then [leader]+                   else ES.toList (ES.delete leader sel) ++ [leader]+      runParams = RunParams { runLeader = leader+                            , runMembers+                            , runInitial = True+                            , runStopMsg = Nothing+                            , runWaiting = 0 }+      macroRun25 = ["C-comma", "C-V"]+  when (initialStep && run) $ do+    modifySession $ \cli ->+      cli {srunning = Just runParams}+    when runAhead $+      modifySession $ \cli ->+        cli {slastPlay = map K.mkKM macroRun25 ++ slastPlay cli}+  -- When running, the invisible actor is hit (not displaced!),+  -- so that running in the presence of roving invisible+  -- actors is equivalent to moving (with visible actors+  -- this is not a problem, since runnning stops early enough).+  let tpos = bpos sb `shift` dir+  -- We start by checking actors at the target position,+  -- which gives a partial information (actors can be invisible),+  -- as opposed to accessibility (and items) which are always accurate+  -- (tiles can't be invisible).+  tgts <- getsState $ posToAssocs tpos arena+  case tgts of+    [] -> do  -- move or search or alter+      runStopOrCmd <- moveSearchAlter dir+      case runStopOrCmd of+        Left stopMsg -> return $ Left stopMsg+        Right runCmd ->+          -- Don't check @initialStep@ and @finalGoal@+          -- and don't stop going to target: door opening is mundane enough.+          return $ Right runCmd+    [(target, _)] | run && initialStep ->+      -- No @stopPlayBack@: initial displace is benign enough.+      -- Displacing requires accessibility, but it's checked later on.+      RequestAnyAbility <$$> displaceAid target+    _ : _ : _ | run && initialStep -> do+      let !_A = assert (all (bproj . snd) tgts) ()+      failSer DisplaceProjectiles+    (target, tb) : _ | initialStep && finalGoal -> do+      stopPlayBack  -- don't ever auto-repeat melee+      -- No problem if there are many projectiles at the spot. We just+      -- attack the first one.+      -- We always see actors from our own faction.+      if bfid tb == bfid sb && not (bproj tb) then do+        -- Select adjacent actor by bumping into him. Takes no time.+        success <- pickLeader True target+        let !_A = assert (success `blame` "bump self"+                                  `twith` (leader, target, tb)) ()+        failWith "by bumping"+      else+        -- Attacking does not require full access, adjacency is enough.+        RequestAnyAbility <$$> meleeAid target+    _ : _ -> failWith "actor in the way"++-- | Actor attacks an enemy actor or his own projectile.+meleeAid :: MonadClientUI m+         => ActorId -> m (FailOrCmd (RequestTimed 'AbMelee))+meleeAid target = do+  leader <- getLeaderUI+  sb <- getsState $ getActorBody leader+  tb <- getsState $ getActorBody target+  sfact <- getsState $ (EM.! bfid sb) . sfactionD+  mel <- pickWeaponClient leader target+  case mel of+    Nothing -> failWith "nothing to melee with"+    Just wp -> do+      let returnCmd = do+            -- Set personal target to the enemy position,+            -- to easily him with a ranged attack when he flees.+            let f (Just (TEnemy _ b)) = Just $ TEnemy target b+                f (Just (TPoint (TEnemyPos _ b) _ _)) = Just $ TEnemy target b+                f _ = Just $ TEnemy target False+            modifyClient $ updateTarget leader f+            return $ Right wp+          res | bproj tb || isAtWar sfact (bfid tb) = returnCmd+              | isAllied sfact (bfid tb) = do+                go1 <- displayYesNo ColorBW+                         "You are bound by an alliance. Really attack?"+                if not go1 then failWith "attack canceled" else returnCmd+              | otherwise = do+                go2 <- displayYesNo ColorBW+                         "This attack will start a war. Are you sure?"+                if not go2 then failWith "attack canceled" else returnCmd+      res+  -- Seeing the actor prevents altering a tile under it, but that+  -- does not limit the player, he just doesn't waste a turn+  -- on a failed altering.++-- | Actor swaps position with another.+displaceAid :: MonadClientUI m+            => ActorId -> m (FailOrCmd (RequestTimed 'AbDisplace))+displaceAid target = do+  Kind.COps{coTileSpeedup} <- getsState scops+  leader <- getLeaderUI+  sb <- getsState $ getActorBody leader+  tb <- getsState $ getActorBody target+  tfact <- getsState $ (EM.! bfid tb) . sfactionD+  actorMaxSk <- maxActorSkillsClient target+  disp <- getsState $ dispEnemy leader target actorMaxSk+  let immobile = EM.findWithDefault 0 AbMove actorMaxSk <= 0+      tpos = bpos tb+      adj = checkAdjacent sb tb+      atWar = isAtWar tfact (bfid sb)+  if | not adj -> failSer DisplaceDistant+     | not (bproj tb) && atWar+       && actorDying tb ->+       failSer DisplaceDying+     | not (bproj tb) && atWar+       && braced tb ->+       failSer DisplaceBraced+     | not (bproj tb) && atWar+       && immobile ->+       failSer DisplaceImmobile+     | not disp && atWar ->+       failSer DisplaceSupported+     | otherwise -> do+       let lid = blid sb+       lvl <- getLevel lid+       -- Displacing requires full access.+       if Tile.isWalkable coTileSpeedup $ lvl `at` tpos then+         case posToAidsLvl tpos lvl of+           [] -> assert `failure` (leader, sb, target, tb)+           [_] -> return $ Right $ ReqDisplace target+           _ -> failSer DisplaceProjectiles+       else failSer DisplaceAccess++-- | Leader moves or searches or alters. No visible actor at the position.+moveSearchAlter :: MonadClientUI m => Vector -> m (FailOrCmd RequestAnyAbility)+moveSearchAlter dir = do+  Kind.COps{coTileSpeedup} <- getsState scops+  leader <- getLeaderUI+  sb <- getsState $ getActorBody leader+  actorSk <- leaderSkillsClientUI+  lvl <- getLevel $ blid sb+  let alterSkill = EM.findWithDefault 0 AbAlter actorSk+      spos = bpos sb           -- source position+      tpos = spos `shift` dir  -- target position+      t = lvl `at` tpos+      alterMinSkill = Tile.alterMinSkill coTileSpeedup t+  runStopOrCmd <-+    -- Movement requires full access.+    if | Tile.isWalkable coTileSpeedup t ->+         -- A potential invisible actor is hit. War started without asking.+         return $ Right $ RequestAnyAbility $ ReqMove dir+       -- No access, so search and/or alter the tile.+       | Tile.isSuspect coTileSpeedup t  -- not yet searched+         || Tile.isHideAs coTileSpeedup t  -- search again, could be swapped+         || alterMinSkill < 10+         || alterMinSkill >= 10 && alterSkill >= alterMinSkill ->+         if | alterSkill < alterMinSkill -> failSer AlterUnwalked+            | EM.member tpos $ lfloor lvl -> failSer AlterBlockItem+            | otherwise -> do+              verAlters <- verifyAlters (blid sb) tpos+              case verAlters of+                Right() ->+                  return $ Right $ RequestAnyAbility $ ReqAlter tpos+                Left err -> return $ Left err+            -- We don't use MoveSer, because we don't hit invisible actors.+            -- The potential invisible actor, e.g., in a wall,+            -- making the player use a turn.+            -- If server performed an attack for free+            -- on the invisible actor anyway, the player (or AI)+            -- would be tempted to repeatedly hit random walls+            -- in hopes of killing a monster lurking within.+            -- If the action had a cost, misclicks would incur the cost, too.+            -- Right now the player may repeatedly alter tiles trying to learn+            -- about invisible pass-wall actors, but when an actor detected,+            -- it costs a turn and does not harm the invisible actors,+            -- so it's not so tempting.+       -- Ignore a known boring, not accessible tile.+       | otherwise -> failWith "never mind"+  return $! runStopOrCmd++-- * RunOnceAhead++runOnceAheadHuman :: MonadClientUI m => m (Either MError ReqUI)+runOnceAheadHuman = do+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  leader <- getLeaderUI+  Config{configRunStopMsgs} <- getsSession sconfig+  keyPressed <- anyKeyPressed+  srunning <- getsSession srunning+  -- When running, stop if disturbed. If not running, stop at once.+  case srunning of+    Nothing -> do+      stopPlayBack+      return $ Left Nothing+    Just RunParams{runMembers}+      | noRunWithMulti fact && runMembers /= [leader] -> do+      stopPlayBack+      if configRunStopMsgs+      then weaveJust <$> failWith "run stop: automatic leader change"+      else return $ Left Nothing+    Just _runParams | keyPressed -> do+      discardPressedKey+      stopPlayBack+      if configRunStopMsgs+      then weaveJust <$> failWith "run stop: key pressed"+      else weaveJust <$> failWith "interrupted"+    Just runParams -> do+      arena <- getArenaUI+      runOutcome <- continueRun arena runParams+      case runOutcome of+        Left stopMsg -> do+          stopPlayBack+          if configRunStopMsgs+          then weaveJust <$> failWith ("run stop:" <+> stopMsg)+          else return $ Left Nothing+        Right runCmd ->+          return $ Right $ ReqUITimed runCmd++-- * MoveOnceToXhair++moveOnceToXhairHuman :: MonadClientUI m => m (FailOrCmd RequestAnyAbility)+moveOnceToXhairHuman = goToXhair True False++goToXhair :: MonadClientUI m+          => Bool -> Bool -> m (FailOrCmd RequestAnyAbility)+goToXhair initialStep run = do+  aimMode <- getsSession saimMode+  -- Movement is legal only outside aiming mode.+  if isJust aimMode then failWith "cannot move in aiming mode"+  else do+    leader <- getLeaderUI+    b <- getsState $ getActorBody leader+    xhairPos <- xhairToPos+    case xhairPos of+      Nothing -> failWith "crosshair position invalid"+      Just c | c == bpos b ->+        if initialStep+        then return $ Right $ RequestAnyAbility ReqWait+        else failWith "position reached"+      Just c -> do+        running <- getsSession srunning+        case running of+          -- Don't use running params from previous run or goto-xhair.+          Just paramOld | not initialStep -> do+            arena <- getArenaUI+            runOutcome <- multiActorGoTo arena c paramOld+            case runOutcome of+              Left stopMsg -> failWith stopMsg+              Right (finalGoal, dir) ->+                moveRunHuman initialStep finalGoal run False dir+          _ -> do+            let !_A = assert (initialStep || not run) ()+            (bfs, mpath) <- getCacheBfsAndPath leader c+            xhairMoused <- getsSession sxhairMoused+            case mpath of+              _ | xhairMoused && isNothing (accessBfs bfs c) ->+                failWith "no route to crosshair"+              _ | initialStep && adjacent (bpos b) c -> do+                let dir = towards (bpos b) c+                moveRunHuman initialStep True run False dir+              NoPath -> failWith "no route to crosshair"+              AndPath{pathList=[]} -> failWith "almost there"+              AndPath{pathList = p1 : _} -> do+                let finalGoal = p1 == c+                    dir = towards (bpos b) p1+                moveRunHuman initialStep finalGoal run False dir++multiActorGoTo :: MonadClientUI m+               => LevelId -> Point -> RunParams+               -> m (Either Text (Bool, Vector))+multiActorGoTo arena c paramOld =+  case paramOld of+    RunParams{runMembers = []} ->+      return $ Left "selected actors no longer there"+    RunParams{runMembers = r : rs, runWaiting} -> do+      onLevel <- getsState $ memActor r arena+      if not onLevel then do+        let paramNew = paramOld {runMembers = rs}+        multiActorGoTo arena c paramNew+      else do+        s <- getState+        modifyClient $ updateLeader r s+        let runMembersNew = rs ++ [r]+            paramNew = paramOld { runMembers = runMembersNew+                                , runWaiting = 0}+        b <- getsState $ getActorBody r+        (bfs, mpath) <- getCacheBfsAndPath r c+        xhairMoused <- getsSession sxhairMoused+        case mpath of+          _ | xhairMoused && isNothing (accessBfs bfs c) ->+            return $ Left "no route to crosshair"+          NoPath -> return $ Left "no route to crosshair"+          AndPath{pathList=[]} ->+            -- This actor already at goal; will be caught in goToXhair.+            return $ Left ""+          AndPath{pathList = p1 : _} -> do+            let finalGoal = p1 == c+                dir = towards (bpos b) p1+            tgts <- getsState $ posToAids p1 arena+            case tgts of+              [] -> do+                modifySession $ \sess -> sess {srunning = Just paramNew}+                return $ Right (finalGoal, dir)+              [target] | target `elem` rs || runWaiting <= length rs ->+                -- Let r wait until all others move. Mark it in runWaiting+                -- to avoid cycles. When all wait for each other, fail.+                multiActorGoTo arena c paramNew{runWaiting=runWaiting + 1}+              _ ->+                return $ Left "actor in the way"++-- * RunOnceToXhair++runOnceToXhairHuman :: MonadClientUI m => m (FailOrCmd RequestAnyAbility)+runOnceToXhairHuman = goToXhair True True++-- * ContinueToXhair++continueToXhairHuman :: MonadClientUI m => m (FailOrCmd RequestAnyAbility)+continueToXhairHuman = goToXhair False False{-irrelevant-}++-- * MoveItem++-- This cannot be structured as projecting or applying, with @ByItemMode@+-- and @ChooseItemToMove@, because at least in case of grabbing items,+-- more than one item is chosen, which doesn't fit @sitemSel@. Separating+-- grabbing of multiple items as a distinct command is too high a proce.+moveItemHuman :: forall m. MonadClientUI m+              => [CStore] -> CStore -> Maybe MU.Part -> Bool+              -> m (FailOrCmd (RequestTimed 'AbMoveItem))+moveItemHuman cLegalRaw destCStore mverb auto = do+  itemSel <- getsSession sitemSel+  modifySession $ \sess -> sess {sitemSel = Nothing}  -- prevent surprise+  case itemSel of+    Just (fromCStore, iid) | fromCStore /= destCStore+                             && fromCStore `elem` cLegalRaw -> do+      leader <- getLeaderUI+      b <- getsState $ getActorBody leader+      bag <- getsState $ getBodyStoreBag b fromCStore+      case iid `EM.lookup` bag of+        Nothing ->  -- the case of old selection or selection from another actor+          moveItemHuman cLegalRaw destCStore mverb auto+        Just (k, it) -> do+          itemToF <- itemToFullClient+          let eqpFree = eqpFreeN b+              kToPick | destCStore == CEqp = min eqpFree k+                      | otherwise = k+          socK <- pickNumber (not auto) kToPick+          case socK of+            Left Nothing -> moveItemHuman cLegalRaw destCStore mverb auto+            Left (Just err) -> return $ Left err+            Right kChosen ->+              let is = ( fromCStore+                       , [(iid, itemToF iid (kChosen, take kChosen it))] )+              in moveItems cLegalRaw is destCStore+    _ -> do+      mis <- selectItemsToMove cLegalRaw destCStore mverb auto+      case mis of+        Left err -> return $ Left err+        Right (fromCStore, [(iid, _)]) | cLegalRaw /= [CGround] -> do+          modifySession $ \sess -> sess {sitemSel = Just (fromCStore, iid)}+          moveItemHuman cLegalRaw destCStore mverb auto+        Right is -> moveItems cLegalRaw is destCStore++selectItemsToMove :: forall m. MonadClientUI m+                  => [CStore] -> CStore -> Maybe MU.Part -> Bool+                  -> m (FailOrCmd (CStore, [(ItemId, ItemFull)]))+selectItemsToMove cLegalRaw destCStore mverb auto = do+  let !_A = assert (destCStore `notElem` cLegalRaw) ()+  let verb = fromMaybe (MU.Text $ verbCStore destCStore) mverb+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  -- This calmE is outdated when one of the items increases max Calm+  -- (e.g., in pickup, which handles many items at once), but this is OK,+  -- the server accepts item movement based on calm at the start, not end+  -- or in the middle.+  -- The calmE is inaccurate also if an item not IDed, but that's intended+  -- and the server will ignore and warn (and content may avoid that,+  -- e.g., making all rings identified)+  actorAspect <- getsClient sactorAspect+  let ar = fromMaybe (assert `failure` leader) (EM.lookup leader actorAspect)+      calmE = calmEnough b ar+      cLegal | calmE = cLegalRaw+             | destCStore == CSha = []+             | otherwise = delete CSha cLegalRaw+      prompt = makePhrase ["What to", verb]+      promptEqp = makePhrase ["What consumable to", verb]+      (promptGeneric, psuit) =+        -- We prune item list only for eqp, because other stores don't have+        -- so clear cut heuristics. So when picking up a stash, either grab+        -- it to auto-store things, or equip first using the pruning+        -- and then pack/stash the rest selectively or en masse.+        if destCStore == CEqp && cLegalRaw /= [CGround]+        then (promptEqp, return $ SuitsSomething $ \itemFull ->+               goesIntoEqp $ itemBase itemFull)+        else (prompt, return SuitsEverything)+  ggi <- getFull psuit+                 (\_ _ _ cCur -> prompt <+> ppItemDialogModeFrom cCur)+                 (\_ _ _ cCur -> promptGeneric <+> ppItemDialogModeFrom cCur)+                 cLegalRaw cLegal (not auto) True+  case ggi of+    Right (l, (MStore fromCStore, _)) -> return $ Right (fromCStore, l)+    Left err -> failWith err+    _ -> assert `failure` ggi++moveItems :: forall m. MonadClientUI m+          => [CStore] -> (CStore, [(ItemId, ItemFull)]) -> CStore+          -> m (FailOrCmd (RequestTimed 'AbMoveItem))+moveItems cLegalRaw (fromCStore, l) destCStore = do+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  actorAspect <- getsClient sactorAspect+  discoBenefit <- getsClient sdiscoBenefit+  let ar = fromMaybe (assert `failure` leader) (EM.lookup leader actorAspect)+      calmE = calmEnough b ar+      ret4 :: MonadClientUI m+           => [(ItemId, ItemFull)]+           -> Int -> [(ItemId, Int, CStore, CStore)]+           -> m (FailOrCmd [(ItemId, Int, CStore, CStore)])+      ret4 [] _ acc = return $ Right $ reverse acc+      ret4 ((iid, itemFull) : rest) oldN acc = do+        let k = itemK itemFull+            !_A = assert (k > 0) ()+            retRec toCStore =+              let n = oldN + if toCStore == CEqp then k else 0+              in ret4 rest n ((iid, k, fromCStore, toCStore) : acc)+            inEqp = maybe (goesIntoEqp $ itemBase itemFull) benInEqp+                          (EM.lookup iid discoBenefit)+        if cLegalRaw == [CGround]  -- normal pickup+        then case destCStore of  -- @CEqp@ is the implicit default; refine:+          CEqp | calmE && goesIntoSha (itemBase itemFull) ->+            retRec CSha+          CEqp | inEqp && eqpOverfull b (oldN + k) -> do+            -- If this stack doesn't fit, we don't equip any part of it,+            -- but we may equip a smaller stack later in the same pickup.+            let fullWarn = if eqpOverfull b (oldN + 1)+                           then EqpOverfull+                           else EqpStackFull+            msgAdd $ "Warning:" <+> showReqFailure fullWarn <> "."+            retRec $ if calmE then CSha else CInv+          CEqp | inEqp ->+            retRec CEqp+          CEqp ->+            retRec CInv+          _ ->+            retRec destCStore+        else case destCStore of  -- player forces store, so @inEqp@ ignored+          CEqp | eqpOverfull b (oldN + k) -> do+            -- If the chosen number from the stack doesn't fit,+            -- we don't equip any part of it and we exit item manipulation.+            let fullWarn = if eqpOverfull b (oldN + 1)+                           then EqpOverfull+                           else EqpStackFull+            failSer fullWarn+          _ -> retRec destCStore+  if not calmE && CSha `elem` [fromCStore, destCStore]+  then failSer ItemNotCalm+  else do+    l4 <- ret4 l 0 []+    return $! case l4 of+      Left err -> Left err+      Right [] -> assert `failure` l+      Right lr -> Right $ ReqMoveItems lr++-- * Project++projectHuman :: MonadClientUI m+             => [Trigger] -> m (FailOrCmd (RequestTimed 'AbProject))+projectHuman ts = do+  itemSel <- getsSession sitemSel+  case itemSel of+    Just (fromCStore, iid) -> do+      leader <- getLeaderUI+      b <- getsState $ getActorBody leader+      bag <- getsState $ getBodyStoreBag b fromCStore+      case iid `EM.lookup` bag of+        Nothing -> failWith "no item to fling"+        Just kit -> do+          itemToF <- itemToFullClient+          let i = (fromCStore, (iid, itemToF iid kit))+          projectItem ts i+    Nothing -> failWith "no item to fling"++projectItem :: MonadClientUI m+            => [Trigger] -> (CStore, (ItemId, ItemFull))+            -> m (FailOrCmd (RequestTimed 'AbProject))+projectItem ts (fromCStore, (iid, itemFull)) = do+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  actorAspect <- getsClient sactorAspect+  let ar = fromMaybe (assert `failure` leader) (EM.lookup leader actorAspect)+      calmE = calmEnough b ar+  if not calmE && fromCStore == CSha then failSer ItemNotCalm+  else do+    mpsuitReq <- psuitReq ts+    case mpsuitReq of+      Left err -> failWith err+      Right psuitReqFun ->+        case psuitReqFun itemFull of+          Left reqFail -> failSer reqFail+          Right (pos, _) -> do+            -- Set personal target to the aim position, to easily repeat.+            mposTgt <- leaderTgtToPos+            unless (Just pos == mposTgt) $ do+              sxhair <- getsSession sxhair+              modifyClient $ updateTarget leader (const $ Just sxhair)+            -- Project.+            eps <- getsClient seps+            return $ Right $ ReqProject pos eps iid fromCStore++-- * Apply++applyHuman :: MonadClientUI m+           => [Trigger] -> m (FailOrCmd (RequestTimed 'AbApply))+applyHuman ts = do+  itemSel <- getsSession sitemSel+  case itemSel of+    Just (fromCStore, iid) -> do+      leader <- getLeaderUI+      b <- getsState $ getActorBody leader+      bag <- getsState $ getBodyStoreBag b fromCStore+      case iid `EM.lookup` bag of+        Nothing -> failWith "no item to apply"+        Just kit -> do+          itemToF <- itemToFullClient+          let i = (fromCStore, (iid, itemToF iid kit))+          applyItem ts i+    Nothing -> failWith "no item to apply"++applyItem :: MonadClientUI m+          => [Trigger] -> (CStore, (ItemId, ItemFull))+          -> m (FailOrCmd (RequestTimed 'AbApply))+applyItem ts (fromCStore, (iid, itemFull)) = do+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  actorAspect <- getsClient sactorAspect+  let ar = fromMaybe (assert `failure` leader) (EM.lookup leader actorAspect)+      calmE = calmEnough b ar+  if not calmE && fromCStore == CSha then failSer ItemNotCalm+  else do+    p <- permittedApplyClient $ triggerSymbols ts+    case p itemFull of+      Left reqFail -> failSer reqFail+      Right _ -> return $ Right $ ReqApply iid fromCStore++-- * AlterDir++-- | Ask for a direction and alter a tile in the specified way, if possible.+alterDirHuman :: MonadClientUI m+              => [Trigger] -> m (FailOrCmd (RequestTimed 'AbAlter))+alterDirHuman ts = do+  Config{configVi, configLaptop} <- getsSession sconfig+  let verb1 = case ts of+        [] -> "alter"+        tr : _ -> verb tr+      keys = K.escKM+             : K.leftButtonReleaseKM+             : map (K.KM K.NoModifier) (K.dirAllKey configVi configLaptop)+      prompt = makePhrase+        ["Where to", verb1 <> "? [movement key] [pointer]"]+  promptAdd prompt+  slides <- reportToSlideshow [K.escKM]+  km <- getConfirms ColorFull keys slides+  case K.key km of+    K.LeftButtonRelease -> do+      leader <- getLeaderUI+      b <- getsState $ getActorBody leader+      Point x y <- getsSession spointer+      let dir = Point x (y -  mapStartY) `vectorToFrom` bpos b+      if isUnit dir+      then alterTile ts dir+      else failWith "never mind"+    _ ->+      case K.handleDir configVi configLaptop km of+        Nothing -> failWith "never mind"+        Just dir -> alterTile ts dir++-- | Try to alter a tile using a feature in the given direction.+alterTile :: MonadClientUI m+          => [Trigger] -> Vector -> m (FailOrCmd (RequestTimed 'AbAlter))+alterTile ts dir = do+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  let tpos = bpos b `shift` dir+      pText = compassText dir+  alterTileAtPos ts tpos pText++-- | Try to alter a tile using a feature in at the given position.+alterTileAtPos :: MonadClientUI m+               => [Trigger] -> Point -> Text+               -> m (FailOrCmd (RequestTimed 'AbAlter))+alterTileAtPos ts tpos pText = do+  cops@Kind.COps{cotile, coTileSpeedup} <- getsState scops+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  actorSk <- leaderSkillsClientUI+  lvl <- getLevel $ blid b+  let alterSkill = EM.findWithDefault 0 AbAlter actorSk+      t = lvl `at` tpos+      hasFeat AlterFeature{feature} = Tile.hasFeature cotile feature t+      hasFeat _ = False+  case filter hasFeat ts of+    _ : _ | alterSkill < Tile.alterMinSkill coTileSpeedup t ->+      failSer AlterUnskilled+    [] -> failWith $ guessAlter cops ts t+    tr : _ ->+      if EM.notMember tpos $ lfloor lvl then+        if null (posToAidsLvl tpos lvl) then do+          verAlters <- verifyAlters (blid b) tpos+          case verAlters of+            Right() -> do+              let msg = makeSentence ["you", verb tr, MU.Text pText]+              msgAdd msg+              return $ Right $ ReqAlter tpos+            Left err -> return $ Left err+        else failSer AlterBlockActor+      else failSer AlterBlockItem++-- | Verify important effects, such as fleeing the dungeon.+--+-- This is contrived for now, the embedded items are not analyzed,+-- but only recognized by name.+verifyAlters :: MonadClientUI m => LevelId -> Point -> m (FailOrCmd ())+verifyAlters lid p = do+  Kind.COps{coTileSpeedup} <- getsState scops+  lvl <- getLevel lid+  let t = lvl `at` p+  bag <- getsState $ getEmbedBag lid p+  is <- mapM (getsState . getItemBody) $ EM.keys bag+  let isE Item{jname} = jname == "escape"+  if | any isE is -> verifyEscape+     | null is && not (Tile.isDoor coTileSpeedup t+                       || Tile.isChangable coTileSpeedup t) ->+         failWith "never mind"+     | otherwise -> return $ Right ()++verifyEscape :: MonadClientUI m => m (FailOrCmd ())+verifyEscape = do+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  if not (fcanEscape $ gplayer fact)+  then failWith+        "This is the way out, but where would you go in this alien world?"+  else do+    go <- displayYesNo ColorFull+            "This is the way out. Really leave now?"+    if not go then failWith "game resumed"+    else do+      (_, total) <- getsState $ calculateTotal side+      if total == 0 then do+        -- The player can back off at each of these steps.+        go1 <- displaySpaceEsc ColorBW+                 "Afraid of the challenge? Leaving so soon and empty-handed?"+        if not go1 then failWith "brave soul!"+        else do+           go2 <- displaySpaceEsc ColorBW+                   "Next time try to grab some loot before escape!"+           if not go2 then failWith "here's your chance!"+           else return $ Right ()+      else return $ Right ()++-- | Guess and report why the bump command failed.+guessAlter :: Kind.COps -> [Trigger] -> Kind.Id TileKind -> Text+guessAlter Kind.COps{cotile} (AlterFeature{feature=TK.OpenTo _} : _) t+  | Tile.isClosable cotile t = "already open"+guessAlter _ (AlterFeature{feature=TK.OpenTo _} : _) _ = "cannot be opened"+guessAlter Kind.COps{cotile} (AlterFeature{feature=TK.CloseTo _} : _) t+  | Tile.isOpenable cotile t = "already closed"+guessAlter _ (AlterFeature{feature=TK.CloseTo _} : _) _ = "cannot be closed"+guessAlter _ _ _ = "never mind"++-- * AlterWithPointer++-- | Try to alter a tile using a feature under the pointer.+alterWithPointerHuman :: MonadClientUI m+                      => [Trigger] -> m (FailOrCmd (RequestTimed 'AbAlter))+alterWithPointerHuman ts = do+  lidV <- viewedLevelUI+  Level{lxsize, lysize} <- getLevel lidV+  Point{..} <- getsSession spointer+  if px >= 0 && py - mapStartY >= 0+     && px < lxsize && py - mapStartY < lysize+  then do+    let tpos = Point px (py - mapStartY)+    alterTileAtPos ts tpos "the door"+  else do+    stopPlayBack+    failWith "never mind"++-- * Help++-- | Display command help.+helpHuman :: MonadClientUI m+          => (HumanCmd.HumanCmd -> m (Either MError ReqUI))+          -> m (Either MError ReqUI)+helpHuman cmdAction = do+  lidV <- viewedLevelUI+  Level{lxsize, lysize} <- getLevel lidV+  keyb <- getsSession sbinding+  menuIxMap <- getsSession smenuIxMap+  let menuName = "help"+      menuIx = fromMaybe 0 (M.lookup menuName menuIxMap)+      keyH = keyHelp keyb 1+      splitHelp (t, okx) =+        splitOKX lxsize (lysize + 3) (textToAL t) [K.spaceKM, K.escKM] okx+      sli = toSlideshow $ concat $ map splitHelp keyH+  (ekm, pointer) <-+    displayChoiceScreen ColorFull True menuIx sli [K.spaceKM, K.escKM]+  modifySession $ \sess ->+    sess { smenuIxMap = M.insert menuName pointer menuIxMap+         , skeysHintMode = KeysHintBlocked }+  case ekm of+    Left km -> case km `M.lookup` bcmdMap keyb of+      _ | km == K.escKM -> return $ Left Nothing+      Just (_desc, _cats, cmd) -> cmdAction cmd+      Nothing -> weaveJust <$> failWith "never mind"+    Right _slot -> assert `failure` ekm++-- * ItemMenu++itemMenuHuman :: MonadClientUI m+              => (HumanCmd.HumanCmd -> m (Either MError ReqUI))+              -> m (Either MError ReqUI)+itemMenuHuman cmdAction = do+  itemSel <- getsSession sitemSel+  case itemSel of+    Just (fromCStore, iid) -> do+      leader <- getLeaderUI+      b <- getsState $ getActorBody leader+      bUI <- getsSession $ getActorUI leader+      bag <- getsState $ getBodyStoreBag b fromCStore+      case iid `EM.lookup` bag of+        Nothing -> weaveJust <$> failWith "no item to open Item Menu for"+        Just kit -> do+          actorAspect <- getsClient sactorAspect+          let ar = fromMaybe (assert `failure` leader)+                             (EM.lookup leader actorAspect)+          itemToF <- itemToFullClient+          lidV <- viewedLevelUI+          Level{lxsize, lysize} <- getLevel lidV+          localTime <- getsState $ getLocalTime (blid b)+          found <- getsState $ findIid leader (bfid b) iid+          factionD <- getsState sfactionD+          sactorUI <- getsSession sactorUI+          let !_A = assert (not (null found) || fromCStore == CGround+                            `blame` (iid, leader)) ()+              fAlt (aid, (_, store)) = aid /= leader || store /= fromCStore+              foundAlt = filter fAlt found+              foundUI = map (\(aid, bs) ->+                               (aid, bs, sactorUI EM.! aid)) foundAlt+              foundKeys = map (K.KM K.NoModifier . K.Fun)+                              [1 .. length foundUI]  -- starting from 1!+              ppLoc bUI2 store =+                let phr = makePhrase $ ppCStoreWownW False store+                                     $ partActor bUI2+                in "[" ++ T.unpack phr ++ "]"+              foundTexts = map (\(_, (_, store), bUI2) ->+                                  ppLoc bUI2 store) foundUI+              foundPrefix = textToAL $+                if null foundTexts then "" else "The item is also in:"+              itemFull = itemToF iid kit+              desc = itemDesc (bfid b) factionD (aHurtMelee ar)+                              fromCStore localTime itemFull+              alPrefix = splitAttrLine lxsize $ desc <+:> foundPrefix+              ystart = length alPrefix - 1+              xstart = length (last alPrefix) + 1+              ks = zip foundKeys $ map (\(_, (_, store), bUI2) ->+                                          ppLoc bUI2 store) foundUI+              (ovFoundRaw, kxsFound) = wrapOKX ystart xstart lxsize ks+              ovFound = glueLines alPrefix ovFoundRaw+          report <- getReportUI+          keyb <- getsSession sbinding+          let calmE = calmEnough b ar+              greyedOut cmd = not calmE && fromCStore == CSha || case cmd of+                HumanCmd.MoveItem stores destCStore _ _ ->+                  fromCStore `notElem` stores+                  || not calmE && CSha == destCStore+                  || destCStore == CEqp && eqpOverfull b 1+                _ -> False  -- project and apply commands are too complex+              fmt n k h = " " <> T.justifyLeft n ' ' k <+> h+              keyL = 11+              keyCaption = fmt keyL "keys" "command"+              offset = 1 + length ovFound+              (ov0, kxs0) = okxsN keyb offset keyL greyedOut+                                  HumanCmd.CmdItemMenu [keyCaption] []+              t0 = makeSentence [ MU.SubjectVerbSg (partActor bUI) "choose"+                                , "an item", MU.Text $ ppCStoreIn fromCStore ]+              al1 = renderReport report <+:> textToAL t0+              splitHelp (al, okx) =+                splitOKX lxsize (lysize + 1) al [K.spaceKM, K.escKM] okx+              sli = toSlideshow+                    $ splitHelp (al1, (ovFound ++ ov0, kxsFound ++ kxs0))+              ix = 2 + length foundKeys+              extraKeys = [K.spaceKM, K.escKM] ++ foundKeys+          recordHistory  -- report shown, remove it to history+          (ekm, _) <- displayChoiceScreen ColorFull False ix sli extraKeys+          case ekm of+            Left km -> case km `M.lookup` bcmdMap keyb of+              _ | km == K.escKM -> weaveJust <$> failWith "never mind"+              _ | km == K.spaceKM -> return $ Left Nothing+              _ | km `elem` foundKeys -> case km of+                K.KM{key=K.Fun n} -> do+                  let (newAid, (bNew, newCStore)) = foundAlt !! (n - 1)+                  fact <- getsState $ (EM.! bfid bNew) . sfactionD+                  let (autoDun, _) = autoDungeonLevel fact+                  if | blid bNew /= blid b && autoDun ->+                       weaveJust <$> failSer NoChangeDunLeader+                     | otherwise -> do+                       void $ pickLeader True newAid+                       modifySession $ \sess ->+                         sess {sitemSel = Just (newCStore, iid)}+                       itemMenuHuman cmdAction+                _ -> assert `failure` km+              Just (_desc, _cats, cmd) -> cmdAction cmd+              Nothing -> weaveJust <$> failWith "never mind"+            Right _slot -> assert `failure` ekm+    Nothing -> weaveJust <$> failWith "no item to open Item Menu for"++-- * ChooseItemMenu++chooseItemMenuHuman :: MonadClientUI m+                    => (HumanCmd.HumanCmd -> m (Either MError ReqUI))+                    -> ItemDialogMode+                    -> m (Either MError ReqUI)+chooseItemMenuHuman cmdAction c = do+  res <- chooseItemDialogMode c+  case res of+    Right c2 -> do+      res2 <- itemMenuHuman cmdAction+      case res2 of+        Left Nothing -> chooseItemMenuHuman cmdAction c2+        _ -> return res2+    Left err -> return $ Left $ Just err++-- * MainMenu++-- We detect the place for the version string by searching for 'Version'+-- in the last line of the picture. If it doesn't fit, we shift, if everything+-- else fails, only then we crop. We don't assume 80 character in a line.+artWithVersion :: MonadClientUI m => m [String]+artWithVersion = do+  Kind.COps{corule} <- getsState scops+  let stdRuleset = Kind.stdRuleset corule+      pasteVersion :: [Text] -> [String]+      pasteVersion art =+        let exeVersion = rexeVersion stdRuleset+            libVersion = Self.version+            version = "Version " ++ showVersion exeVersion+                      ++ " (frontend: " ++ frontendName+                      ++ ", engine: LambdaHack " ++ showVersion libVersion+                      ++ ") "+            versionLen = length version+            lastOriginal = last art+            (prefix, versionSuffix) = T.breakOn "Version" lastOriginal+            suffix = drop versionLen $ T.unpack versionSuffix+            overfillLen = versionLen - T.length versionSuffix+            prefixModified = T.unpack $ T.dropEnd overfillLen prefix+            lastModified = prefixModified ++ version ++ suffix+        in map T.unpack (init art) ++ [lastModified]+      mainMenuArt = rmainMenuArt stdRuleset+  return $! pasteVersion $ T.lines mainMenuArt++generateMenu :: MonadClientUI m+             => (HumanCmd.HumanCmd -> m (Either MError ReqUI))+             -> [(K.KM, (Text, HumanCmd.HumanCmd))] -> [String] -> String+             -> m (Either MError ReqUI)+generateMenu cmdAction kds gameInfo menuName = do+  art <- artWithVersion+  let bindingLen = 30+      emptyInfo = repeat $ replicate bindingLen ' '+      bindings =  -- key bindings to display+        let fmt (k, (d, _)) =+              ( Just k+              , T.unpack+                $ T.justifyLeft bindingLen ' '+                    $ T.justifyLeft 3 ' ' (T.pack $ K.showKM k) <> " " <> d )+        in map fmt kds+      overwrite :: [(Int, String)] -> [(String, Maybe KYX)]+      overwrite =  -- overwrite the art with key bindings and other lines+        let over [] (_, line) = ([], (line, Nothing))+            over bs@((mkey, binding) : bsRest) (y, line) =+              let (prefix, lineRest) = break (=='{') line+                  (braces, suffix)   = span  (=='{') lineRest+              in if length braces >= bindingLen+                 then+                   let lenB = length binding+                       post = drop (lenB - length braces) suffix+                       len = length prefix+                       yxx key = (Left [key], (y, len, len + lenB))+                       myxx = yxx <$> mkey+                   in (bsRest, (prefix <> binding <> post, myxx))+                 else (bs, (line, Nothing))+        in snd . mapAccumL over (zip (repeat Nothing) gameInfo+                                 ++ bindings+                                 ++ zip (repeat Nothing) emptyInfo)+      menuOverwritten = overwrite $ zip [0..] art+      (menuOvLines, mkyxs) = unzip menuOverwritten+      kyxs = catMaybes mkyxs+      ov = map stringToAL menuOvLines+  menuIxMap <- getsSession smenuIxMap+  let menuIx = fromMaybe 0 (M.lookup menuName menuIxMap)+  (ekm, pointer) <- displayChoiceScreen ColorFull True menuIx+                                        (menuToSlideshow (ov, kyxs)) [K.escKM]+  modifySession $ \sess ->+    sess {smenuIxMap = M.insert menuName pointer menuIxMap}+  case ekm of+    Left km -> case km `lookup` kds of+      Just (_desc, cmd) -> cmdAction cmd+      Nothing -> weaveJust <$> failWith "never mind"+    Right _slot -> assert `failure` ekm++-- | Display the main menu.+mainMenuHuman :: MonadClientUI m+              => (HumanCmd.HumanCmd -> m (Either MError ReqUI))+              -> m (Either MError ReqUI)+mainMenuHuman cmdAction = do+  cops <- getsState scops+  Binding{bcmdList} <- getsSession sbinding+  gameMode <- getGameMode+  snxtScenario <- getsClient snxtScenario+  let nxtGameName = mname $ nxtGameMode cops snxtScenario+      tnextScenario = "new scenario:" <+> nxtGameName+      -- Key-description-command tuples.+      kds = (K.mkKM "s", (tnextScenario, HumanCmd.GameScenarioIncr))+            : [ (km, (desc, cmd))+              | (km, ([HumanCmd.CmdMainMenu], desc, cmd)) <- bcmdList ]+      bindingLen = 30+      gameName = mname gameMode+      gameInfo = map T.unpack+                   [ T.justifyLeft bindingLen ' ' ""+                   , T.justifyLeft bindingLen ' '+                     $ "Now playing:" <+> gameName+                   , T.justifyLeft bindingLen ' ' "" ]+  generateMenu cmdAction kds gameInfo "main"++-- * SettingsMenu++-- | Display the settings menu.+settingsMenuHuman :: MonadClientUI m+                  => (HumanCmd.HumanCmd -> m (Either MError ReqUI))+                  -> m (Either MError ReqUI)+settingsMenuHuman cmdAction = do+  markSuspect <- getsClient smarkSuspect+  markVision <- getsSession smarkVision+  markSmell <- getsSession smarkSmell+  side <- getsClient sside+  factTactic <- getsState $ ftactic . gplayer . (EM.! side) . sfactionD+  let offOn b = if b then "on" else "off"+      offOnAll n = case n of+        0 -> "off"+        1 -> "on"+        2 -> "all"+        _ -> assert `failure` n+      tsuspect = "suspect terrain:" <+> offOnAll markSuspect+      tvisible = "visible zone:" <+> offOn markVision+      tsmell = "smell clues:" <+> offOn  markSmell+      thenchmen = "tactic:" <+> tshow factTactic+      -- Key-description-command tuples.+      kds = [ (K.mkKM "s", (tsuspect, HumanCmd.MarkSuspect))+            , (K.mkKM "v", (tvisible, HumanCmd.MarkVision))+            , (K.mkKM "c", (tsmell, HumanCmd.MarkSmell))+            , (K.mkKM "t", (thenchmen, HumanCmd.Tactic))+            , (K.mkKM "Escape", ("back to main menu", HumanCmd.MainMenu)) ]+      bindingLen = 30+      gameInfo = map T.unpack+                   [ T.justifyLeft bindingLen ' ' ""+                   , T.justifyLeft bindingLen ' ' "Game settings:"+                   , T.justifyLeft bindingLen ' ' "" ]+  generateMenu cmdAction kds gameInfo "settings"++-- * ChallengesMenu++-- | Display the challenges menu.+challengesMenuHuman :: MonadClientUI m+                    => (HumanCmd.HumanCmd -> m (Either MError ReqUI))+                    -> m (Either MError ReqUI)+challengesMenuHuman cmdAction = do+  curChal <- getsClient scurChal+  nxtChal <- getsClient snxtChal+  let offOn b = if b then "on" else "off"+      tcurDiff = "*   difficulty:" <+> tshow (cdiff curChal)+      tnextDiff = "difficulty:" <+> tshow (cdiff nxtChal)+      tcurWolf = "*   lone wolf:"+                 <+> offOn (cwolf curChal)+      tnextWolf = "lone wolf:"+                  <+> offOn (cwolf nxtChal)+      tcurFish = "*   cold fish:"+                 <+> offOn (cfish curChal)+      tnextFish = "cold fish:"+                  <+> offOn (cfish nxtChal)+      -- Key-description-command tuples.+      kds = [ (K.mkKM "d", (tnextDiff, HumanCmd.GameDifficultyIncr))+            , (K.mkKM "w", (tnextWolf, HumanCmd.GameWolfToggle))+            , (K.mkKM "f", (tnextFish, HumanCmd.GameFishToggle))+            , (K.mkKM "Escape", ("back to main menu", HumanCmd.MainMenu)) ]+      bindingLen = 30+      gameInfo = map T.unpack+                   [ T.justifyLeft bindingLen ' ' "Current challenges:"+                   , T.justifyLeft bindingLen ' ' ""+                   , T.justifyLeft bindingLen ' ' tcurDiff+                   , T.justifyLeft bindingLen ' ' tcurWolf+                   , T.justifyLeft bindingLen ' ' tcurFish+                   , T.justifyLeft bindingLen ' ' ""+                   , T.justifyLeft bindingLen ' ' "New game challenges:"+                   , T.justifyLeft bindingLen ' ' "" ]+  generateMenu cmdAction kds gameInfo "challenge"++-- * GameScenarioIncr++gameScenarioIncr :: MonadClientUI m => m ()+gameScenarioIncr =+  modifyClient $ \cli -> cli {snxtScenario = snxtScenario cli + 1}++-- * GameDifficultyIncr++gameDifficultyIncr :: MonadClientUI m => m ()+gameDifficultyIncr = do+  nxtDiff <- getsClient $ cdiff . snxtChal+  let delta = 1+      d | nxtDiff + delta > difficultyBound = 1+        | nxtDiff + delta < 1 = difficultyBound+        | otherwise = nxtDiff + delta+  modifyClient $ \cli -> cli {snxtChal = (snxtChal cli) {cdiff = d} }++-- * GameWolfToggle++gameWolfToggle :: MonadClientUI m => m ()+gameWolfToggle =+  modifyClient $ \cli ->+    cli {snxtChal = (snxtChal cli) {cwolf = not (cwolf (snxtChal cli))} }++-- * GameFishToggle++gameFishToggle :: MonadClientUI m => m ()+gameFishToggle =+    modifyClient $ \cli ->+    cli {snxtChal = (snxtChal cli) {cfish = not (cfish (snxtChal cli))} }++-- * GameRestart++gameRestartHuman :: MonadClientUI m => m (FailOrCmd ReqUI)+gameRestartHuman = do+  cops <- getsState scops+  isNoConfirms <- isNoConfirmsGame+  gameMode <- getGameMode+  snxtScenario <- getsClient snxtScenario+  let nxtGameName = mname $ nxtGameMode cops snxtScenario+  b <- if isNoConfirms+       then return True+       else displayYesNo ColorBW+            $ "You just requested a new" <+> nxtGameName+              <+> "game. The progress of the ongoing" <+> mname gameMode+              <+> "game will be lost! Are you sure?"+  if b+  then do+    snxtChal <- getsClient snxtChal+    let nxtGameGroup = toGroupName nxtGameName  -- a tiny bit hacky+    return $ Right $ ReqUIGameRestart nxtGameGroup snxtChal+  else do+    msg2 <- rndToActionForget $ oneOf+              [ "yea, would be a pity to leave them all to die"+              , "yea, a shame to get your team stranded" ]+    failWith msg2++nxtGameMode :: Kind.COps -> Int -> ModeKind+nxtGameMode Kind.COps{comode=Kind.Ops{ofoldlGroup'}} snxtScenario =+  let f acc _p _i a = a : acc+      campaignModes = ofoldlGroup' "campaign scenario" f []+  in campaignModes !! (snxtScenario `mod` length campaignModes)++-- * GameExit++gameExitHuman :: MonadClientUI m => m ReqUI+gameExitHuman = do+  -- Announce before the saving started, since it can take a while.+  promptAdd "Saving game. The program stops now."+  return ReqUIGameExit++-- * GameSave++gameSaveHuman :: MonadClientUI m => m ReqUI+gameSaveHuman = do+  -- Announce before the saving started, since it can take a while.+  promptAdd "Saving game backup."+  return ReqUIGameSave++-- * Tactic++-- Note that the difference between seek-target and follow-the-leader tactic+-- can influence even a faction with passive actors. E.g., if a passive actor+-- has an extra active skill from equipment, he moves every turn.+tacticHuman :: MonadClientUI m => m (FailOrCmd ReqUI)+tacticHuman = do+  fid <- getsClient sside+  fromT <- getsState $ ftactic . gplayer . (EM.! fid) . sfactionD+  let toT = if fromT == maxBound then minBound else succ fromT+  go <- displaySpaceEsc ColorFull+        $ "(Beware, work in progress!)"+          <+> "Current henchmen tactic is" <+> tshow fromT+          <+> "(" <> describeTactic fromT <> ")."+          <+> "Switching tactic to" <+> tshow toT+          <+> "(" <> describeTactic toT <> ")."+          <+> "This clears targets of all henchmen (non-leader teammates)."+          <+> "New targets will be picked according to new tactic."+  if not go+  then failWith "tactic change canceled"+  else return $ Right $ ReqUITactic toT++-- * Automate++automateHuman :: MonadClientUI m => m (FailOrCmd ReqUI)+automateHuman = do+  -- BFS is not updated while automated, which would lead to corruption.+  clearAimMode+  go <- displaySpaceEsc ColorBW+          "Ceding control to AI (press ESC to regain)."+  if not go+    then failWith "automation canceled"+    else return $ Right ReqUIAutomate

− Game/LambdaHack/Client/UI/HandleHumanLocalClient.hs

@@ -1,517 +0,0 @@--- | Semantics of 'HumanCmd' client commands that do not return--- server commands. None of such commands takes game time.--- TODO: document-module Game.LambdaHack.Client.UI.HandleHumanLocalClient-  ( -- * Assorted commands-    gameDifficultyCycle-  , pickLeaderHuman, memberCycleHuman, memberBackHuman-  , selectActorHuman, selectNoneHuman, clearHuman-  , stopIfTgtModeHuman, selectWithPointer, repeatHuman, recordHuman-  , historyHuman, markVisionHuman, markSmellHuman, markSuspectHuman-  , helpHuman, mainMenuHuman, macroHuman-    -- * Commands specific to targeting-  , moveCursorHuman, tgtFloorHuman, tgtEnemyHuman-  , tgtAscendHuman, epsIncrHuman, tgtClearHuman-  , cursorUnknownHuman, cursorItemHuman, cursorStairHuman-  , cancelHuman, acceptHuman-  , cursorPointerFloorHuman, cursorPointerEnemyHuman-  , tgtPointerFloorHuman, tgtPointerEnemyHuman-  ) where---- Cabal-import qualified Paths_LambdaHack as Self (version)--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.List-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Monoid-import Data.Ord-import qualified Data.Text as T-import Data.Version-import Game.LambdaHack.Client.UI.Frontend (frontendName)-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Client.BfsClient-import Game.LambdaHack.Client.CommonClient-import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd-import Game.LambdaHack.Client.UI.InventoryClient-import Game.LambdaHack.Client.UI.KeyBindings-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Client.UI.MsgClient-import Game.LambdaHack.Client.UI.WidgetClient-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Frequency-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.RuleKind-import qualified Game.LambdaHack.Content.TileKind as TK---- * GameDifficultyCycle--gameDifficultyCycle :: MonadClientUI m => m ()-gameDifficultyCycle = do-  snxtDiff <- getsClient snxtDiff-  let d = if snxtDiff >= difficultyBound then 1 else snxtDiff + 1-  modifyClient $ \cli -> cli {snxtDiff = d}-  msgAdd $ "Next game difficulty set to" <+> tshow d <> "."---- * PickLeader--pickLeaderHuman :: MonadClientUI m => Int -> m Slideshow-pickLeaderHuman k = do-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  arena <- getArenaUI-  mhero <- getsState $ tryFindHeroK side k-  allA <- getsState $ EM.assocs . sactorD-  let mactor = let factionA = filter (\(_, body) ->-                     not (bproj body) && bfid body == side) allA-                   hs = sortBy (comparing keySelected) factionA-               in case drop k hs of-                 [] -> Nothing-                 aidb : _ -> Just aidb-      mchoice = mhero `mplus` mactor-      (autoDun, autoLvl) = autoDungeonLevel fact-  case mchoice of-    Nothing -> failMsg "no such member of the party"-    Just (aid, b)-      | blid b /= arena && autoDun ->-          failMsg $ showReqFailure NoChangeDunLeader-      | autoLvl ->-          failMsg $ showReqFailure NoChangeLvlLeader-      | otherwise -> do-          void $ pickLeader True aid-          return mempty---- * MemberCycle---- | Switches current member to the next on the level, if any, wrapping.-memberCycleHuman :: MonadClientUI m => m Slideshow-memberCycleHuman = memberCycle True---- * MemberBack---- | Switches current member to the previous in the whole dungeon, wrapping.-memberBackHuman :: MonadClientUI m => m Slideshow-memberBackHuman = memberBack True---- * SelectActor---- TODO: make the message (and for selectNoneHuman, pickLeader, etc.)--- optional, since they have a clear representation in the UI elsewhere.-selectActorHuman :: MonadClientUI m => m ()-selectActorHuman = do-  leader <- getLeaderUI-  selectAidHuman leader--selectAidHuman :: MonadClientUI m => ActorId -> m ()-selectAidHuman leader = do-  body <- getsState $ getActorBody leader-  wasMemeber <- getsClient $ ES.member leader . sselected-  let upd = if wasMemeber-            then ES.delete leader  -- already selected, deselect instead-            else ES.insert leader-  modifyClient $ \cli -> cli {sselected = upd $ sselected cli}-  let subject = partActor body-  msgAdd $ makeSentence [subject, if wasMemeber-                                  then "deselected"-                                  else "selected"]---- * SelectNone--selectNoneHuman :: (MonadClientUI m, MonadClient m) => m ()-selectNoneHuman = do-  side <- getsClient sside-  lidV <- viewedLevel-  oursAssocs <- getsState $ actorRegularAssocs (== side) lidV-  let ours = ES.fromList $ map fst oursAssocs-  oldSel <- getsClient sselected-  let wasNone = ES.null $ ES.intersection ours oldSel-      upd = if wasNone-            then ES.union  -- already all deselected; select all instead-            else ES.difference-  modifyClient $ \cli -> cli {sselected = upd (sselected cli) ours}-  let subject = "all party members on the level"-  msgAdd $ makeSentence [subject, if wasNone-                                  then "selected"-                                  else "deselected"]---- * Clear---- | Clear current messages, show the next screen if any.-clearHuman :: Monad m => m ()-clearHuman = return ()---- * StopIfTgtMode--stopIfTgtModeHuman :: MonadClientUI m => m ()-stopIfTgtModeHuman = do-  tgtMode <- getsClient stgtMode-  when (isJust tgtMode) stopPlayBack---- * SelectWithPointer--selectWithPointer:: MonadClientUI m => m ()-selectWithPointer = do-  km <- getsClient slastKM-  lidV <- viewedLevel-  Level{lysize} <- getLevel lidV-  side <- getsClient sside-  ours <- getsState $ filter (not . bproj . snd)-                      . actorAssocs (== side) lidV-  -- Select even if no space in status line for the actor's symbol.-  let viewed = sortBy (comparing keySelected) ours-  case K.pointer km of-    Just(Point{..}) | py == lysize + 1 && px <= length viewed && px >= 0 -> do-      if px == 0 then-        selectNoneHuman-      else-        selectAidHuman $ fst $ viewed !! (px - 1)-      stopPlayBack-    _ -> return ()---- * Repeat---- Note that walk followed by repeat should not be equivalent to run,--- because the player can really use a command that does not stop--- at terrain change or when walking over items.-repeatHuman :: MonadClient m => Int -> m ()-repeatHuman n = do-  (_, seqPrevious, k) <- getsClient slastRecord-  let macro = concat $ replicate n $ reverse seqPrevious-  modifyClient $ \cli -> cli {slastPlay = macro ++ slastPlay cli}-  let slastRecord = ([], [], if k == 0 then 0 else maxK)-  modifyClient $ \cli -> cli {slastRecord}--maxK :: Int-maxK = 100---- * Record--recordHuman :: MonadClientUI m => m Slideshow-recordHuman = do-  (_seqCurrent, seqPrevious, k) <- getsClient slastRecord-  case k of-    0 -> do-      let slastRecord = ([], [], maxK)-      modifyClient $ \cli -> cli {slastRecord}-      promptToSlideshow $ "Macro will be recorded for up to"-                          <+> tshow maxK <+> "actions."  -- no MU, poweruser-    _ -> do-      let slastRecord = (seqPrevious, [], 0)-      modifyClient $ \cli -> cli {slastRecord}-      promptToSlideshow $ "Macro recording interrupted after"-                          <+> tshow (maxK - k - 1) <+> "actions."---- * History--historyHuman :: MonadClientUI m => m Slideshow-historyHuman = do-  history <- getsClient shistory-  arena <- getArenaUI-  local <- getsState $ getLocalTime arena-  global <- getsState stime-  let turnsGlobal = global `timeFitUp` timeTurn-      turnsLocal = local `timeFitUp` timeTurn-      msg = makeSentence-        [ "You survived for"-        , MU.CarWs turnsGlobal "half-second turn"-        , "(this level:"-        , MU.Text (tshow turnsLocal) <> ")" ]-        <+> "Past messages:"-  overlayToBlankSlideshow False msg $ renderHistory history---- * MarkVision, MarkSmell, MarkSuspect--markVisionHuman :: MonadClientUI m => m ()-markVisionHuman = do-  modifyClient toggleMarkVision-  cur <- getsClient smarkVision-  msgAdd $ "Visible area display toggled" <+> if cur then "on." else "off."--markSmellHuman :: MonadClientUI m => m ()-markSmellHuman = do-  modifyClient toggleMarkSmell-  cur <- getsClient smarkSmell-  msgAdd $ "Smell display toggled" <+> if cur then "on." else "off."--markSuspectHuman :: MonadClientUI m => m ()-markSuspectHuman = do-  -- @condBFS@ depends on the setting we change here.-  modifyClient $ \cli -> cli {sbfsD = EM.empty}-  modifyClient toggleMarkSuspect-  cur <- getsClient smarkSuspect-  msgAdd $ "Suspect terrain display toggled" <+> if cur then "on." else "off."---- * Help---- | Display command help.-helpHuman :: MonadClientUI m => m Slideshow-helpHuman = do-  keyb <- askBinding-  return $! keyHelp keyb---- * MainMenu---- TODO: merge with the help screens better--- | Display the main menu.-mainMenuHuman :: MonadClientUI m => m Slideshow-mainMenuHuman = do-  Kind.COps{corule} <- getsState scops-  escAI <- getsClient sescAI-  Binding{brevMap, bcmdList} <- askBinding-  scurDiff <- getsClient scurDiff-  snxtDiff <- getsClient snxtDiff-  let stripFrame t = map (T.tail . T.init) $ tail . init $ T.lines t-      pasteVersion art =-        let pathsVersion = rpathsVersion $ Kind.stdRuleset corule-            version = " Version " ++ showVersion pathsVersion-                      ++ " (frontend: " ++ frontendName-                      ++ ", engine: LambdaHack " ++ showVersion Self.version-                      ++ ") "-            versionLen = length version-        in init art ++ [take (80 - versionLen) (last art) ++ version]-      kds =  -- key-description pairs-        let showKD cmd km = (K.showKM km, HumanCmd.cmdDescription cmd)-            revLookup cmd = maybe ("", "") (showKD cmd) $ M.lookup cmd brevMap-            cmds = [ (K.showKM km, desc)-                   | (km, (desc, [HumanCmd.CmdMenu], cmd)) <- bcmdList,-                     cmd /= HumanCmd.GameDifficultyCycle ]-        in [-             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-           ++ [ (fst ( revLookup HumanCmd.GameDifficultyCycle)-                     , "next game difficulty"-                       <+> tshow snxtDiff-                       <+> "(current"-                       <+> tshow scurDiff <> ")" ) ]-      bindingLen = 25-      bindings =  -- key bindings to display-        let fmt (k, d) = T.justifyLeft bindingLen ' '-                         $ T.justifyLeft 7 ' ' k <> " " <> d-        in map fmt kds-      overwrite =  -- overwrite the art with key bindings-        let over [] line = ([], T.pack line)-            over bs@(binding : bsRest) line =-              let (prefix, lineRest) = break (=='{') line-                  (braces, suffix)   = span  (=='{') lineRest-              in if length braces == 25-                 then (bsRest, T.pack prefix <> binding-                               <> T.drop (T.length binding - bindingLen)-                                         (T.pack suffix))-                 else (bs, T.pack line)-        in snd . mapAccumL over bindings-      mainMenuArt = rmainMenuArt $ Kind.stdRuleset corule-      menuOverlay =  -- TODO: switch to Text and use T.justifyLeft-        overwrite $ pasteVersion $ map T.unpack $ stripFrame mainMenuArt-  case menuOverlay of-    [] -> assert `failure` "empty Main Menu overlay" `twith` mainMenuArt-    hd : tl -> overlayToBlankSlideshow True hd (toOverlay tl)-               -- TODO: keys don't work if tl/=[]---- * Macro--macroHuman :: MonadClient m => [String] -> m ()-macroHuman kms =-  modifyClient $ \cli -> cli {slastPlay = map K.mkKM kms ++ slastPlay cli}---- * MoveCursor---- in InventoryClient---- * TgtFloor---- in InventoryClient---- * TgtEnemy---- in InventoryClient---- * TgtAscend---- | Change the displayed level in targeting mode to (at most)--- k levels shallower. Enters targeting mode, if not already in one.-tgtAscendHuman :: MonadClientUI m => Int -> m Slideshow-tgtAscendHuman k = do-  Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops-  dungeon <- getsState sdungeon-  scursorOld <- getsClient scursor-  cursorPos <- cursorToPos-  lidV <- viewedLevel-  lvl <- getLevel lidV-  let rightStairs = case cursorPos of-        Nothing -> Nothing-        Just cpos ->-          let tile = lvl `at` cpos-          in if Tile.hasFeature cotile (TK.Cause $ IK.Ascend k) tile-             then Just cpos-             else Nothing-  case rightStairs of-    Just cpos -> do  -- stairs, in the right direction-      (nln, npos) <- getsState $ whereTo lidV cpos k . sdungeon-      let !_A = assert (nln /= lidV `blame` "stairs looped" `twith` nln) ()-      nlvl <- getLevel nln-      -- Do not freely reveal the other end of the stairs.-      let ascDesc (TK.Cause (IK.Ascend _)) = True-          ascDesc _ = False-          scursor =-            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)}-      doLook False-    Nothing ->  -- no stairs in the right direction-      case ascendInBranch dungeon k lidV of-        [] -> failMsg "no more levels in this direction"-        nln : _ -> do-          modifyClient $ \cli -> cli {stgtMode = Just (TgtMode nln)}-          doLook False---- * EpsIncr---- in InventoryClient---- * TgtClear---- in InventoryClient---- * CursorUnknown--cursorUnknownHuman :: MonadClientUI m => m Slideshow-cursorUnknownHuman = do-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  mpos <- closestUnknown leader-  case mpos of-    Nothing -> failMsg "no more unknown spots left"-    Just p -> do-      let tgt = TPoint (blid b) p-      modifyClient $ \cli -> cli {scursor = tgt}-      doLook False---- * CursorItem--cursorItemHuman :: MonadClientUI m => m Slideshow-cursorItemHuman = do-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  items <- closestItems leader-  case items of-    [] -> failMsg "no more items remembered or visible"-    (_, (p, _)) : _ -> do-      let tgt = TPoint (blid b) p-      modifyClient $ \cli -> cli {scursor = tgt}-      doLook False---- * CursorStair--cursorStairHuman :: MonadClientUI m => Bool -> m Slideshow-cursorStairHuman up = do-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  stairs <- closestTriggers (Just up) leader-  case sortBy (flip compare) $ runFrequency stairs of-    [] -> failMsg $ "no stairs" <+> if up then "up" else "down"-    (_, p) : _ -> do-      let tgt = TPoint (blid b) p-      modifyClient $ \cli -> cli {scursor = tgt}-      doLook False---- * Cancel---- | Cancel something, e.g., targeting mode, resetting the cursor--- to the position of the leader. Chosen target is not invalidated.-cancelHuman :: MonadClientUI m => m Slideshow -> m Slideshow-cancelHuman h = do-  stgtMode <- getsClient stgtMode-  if isJust stgtMode-    then targetReject-    else h  -- nothing to cancel right now, treat this as a command invocation---- | End targeting mode, rejecting the current position.-targetReject :: MonadClientUI m => m Slideshow-targetReject = do-  modifyClient $ \cli -> cli {stgtMode = Nothing}-  failMsg "target not set"---- * Accept---- | Accept something, e.g., targeting mode, keeping cursor where it was.--- Or perform the default action, if nothing needs accepting.-acceptHuman :: MonadClientUI m => m Slideshow -> m Slideshow-acceptHuman h = do-  stgtMode <- getsClient stgtMode-  if isJust stgtMode-    then do-      targetAccept-      return mempty-    else h  -- nothing to accept right now, treat this as a command invocation---- | End targeting mode, accepting the current position.-targetAccept :: MonadClientUI m => m ()-targetAccept = do-  endTargeting-  endTargetingMsg-  modifyClient $ \cli -> cli {stgtMode = Nothing}---- | End targeting mode, accepting the current position.-endTargeting :: MonadClientUI m => m ()-endTargeting = do-  leader <- getLeaderUI-  scursor <- getsClient scursor-  modifyClient $ updateTarget leader $ const $ Just scursor--endTargetingMsg :: MonadClientUI m => m ()-endTargetingMsg = do-  leader <- getLeaderUI-  (targetMsg, _) <- targetDescLeader leader-  subject <- partAidLeader leader-  msgAdd $ makeSentence [MU.SubjectVerbSg subject "target", MU.Text targetMsg]---- * CursorPointerFloor--cursorPointerFloorHuman :: MonadClientUI m => m ()-cursorPointerFloorHuman = do-  look <- cursorPointerFloor False False-  let !_A = assert (look == mempty `blame` look) ()-  modifyClient $ \cli -> cli {stgtMode = Nothing}---- * CursorPointerEnemy--cursorPointerEnemyHuman :: MonadClientUI m => m ()-cursorPointerEnemyHuman = do-  look <- cursorPointerEnemy False False-  let !_A = assert (look == mempty `blame` look) ()-  modifyClient $ \cli -> cli {stgtMode = Nothing}---- * TgtPointerFloor--tgtPointerFloorHuman :: MonadClientUI m => m Slideshow-tgtPointerFloorHuman = cursorPointerFloor True False---- * TgtPointerEnemy--tgtPointerEnemyHuman :: MonadClientUI m => m Slideshow-tgtPointerEnemyHuman = cursorPointerEnemy True False

+ Game/LambdaHack/Client/UI/HandleHumanLocalM.hs view

@@ -0,0 +1,1065 @@+-- | Semantics of 'HumanCmd' client commands that do not return+-- server commands. None of such commands takes game time.+module Game.LambdaHack.Client.UI.HandleHumanLocalM+  ( -- * Meta commands+    macroHuman+    -- * Local commands+  , clearHuman, sortSlotsHuman, chooseItemHuman, chooseItemDialogMode+  , chooseItemProjectHuman, chooseItemApplyHuman+  , psuitReq, triggerSymbols, permittedApplyClient+  , pickLeaderHuman, pickLeaderWithPointerHuman+  , memberCycleHuman, memberBackHuman+  , selectActorHuman, selectNoneHuman, selectWithPointerHuman+  , repeatHuman, recordHuman, historyHuman+  , markVisionHuman, markSmellHuman, markSuspectHuman+    -- * Commands specific to aiming+  , cancelHuman, acceptHuman, tgtClearHuman, itemClearHuman+  , moveXhairHuman, aimTgtHuman, aimFloorHuman, aimEnemyHuman, aimItemHuman+  , aimAscendHuman, epsIncrHuman+  , xhairUnknownHuman, xhairItemHuman, xhairStairHuman+  , xhairPointerFloorHuman, xhairPointerEnemyHuman+  , aimPointerFloorHuman, aimPointerEnemyHuman+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++-- Cabal++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.Map.Strict as M+import Data.Ord+import qualified Data.Text as T+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Client.BfsM+import Game.LambdaHack.Client.CommonM+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Client.UI.ActorUI+import Game.LambdaHack.Client.UI.Animation+import Game.LambdaHack.Client.UI.Config+import Game.LambdaHack.Client.UI.DrawM+import Game.LambdaHack.Client.UI.EffectDescription+import Game.LambdaHack.Client.UI.FrameM+import Game.LambdaHack.Client.UI.HandleHelperM+import Game.LambdaHack.Client.UI.HumanCmd (Trigger (..))+import Game.LambdaHack.Client.UI.InventoryM+import Game.LambdaHack.Client.UI.ItemSlot+import qualified Game.LambdaHack.Client.UI.Key as K+import Game.LambdaHack.Client.UI.MonadClientUI+import Game.LambdaHack.Client.UI.Msg+import Game.LambdaHack.Client.UI.MsgM+import Game.LambdaHack.Client.UI.Overlay+import Game.LambdaHack.Client.UI.OverlayM+import Game.LambdaHack.Client.UI.SessionUI+import Game.LambdaHack.Client.UI.SlideshowM+import Game.LambdaHack.Common.Ability+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.ItemStrongest+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Perception+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Vector+import qualified Game.LambdaHack.Content.ItemKind as IK+import Game.LambdaHack.Content.TileKind (isUknownSpace)++-- * Macro++macroHuman :: MonadClientUI m => [String] -> m ()+macroHuman kms = do+  modifySession $ \sess -> sess {slastPlay = map K.mkKM kms ++ slastPlay sess}+  Config{configRunStopMsgs} <- getsSession sconfig+  when configRunStopMsgs $+    promptAdd $ "Macro activated:" <+> T.pack (intercalate " " kms)++-- * Clear++-- | Clear current messages, cycle key hints mode.+clearHuman :: MonadClientUI m => m ()+clearHuman = do+  keysHintMode <- getsSession skeysHintMode+  when (keysHintMode == KeysHintPresent) historyHuman+  modifySession $ \sess -> sess {skeysHintMode =+    let n = fromEnum (skeysHintMode sess) + 1+    in toEnum $ if n > fromEnum (maxBound :: KeysHintMode) then 0 else n}++-- * SortSlots++sortSlotsHuman :: MonadClientUI m => m ()+sortSlotsHuman = do+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  sortSlots (bfid b) (Just b)+  promptAdd "Items sorted by kind and stats."++-- * ChooseItem++-- | Display items from a given container store and possibly let the user+-- chose one.+chooseItemHuman :: MonadClientUI m => ItemDialogMode -> m MError+chooseItemHuman c = either Just (const Nothing) <$> chooseItemDialogMode c++chooseItemDialogMode :: MonadClientUI m+                     => ItemDialogMode -> m (FailOrCmd ItemDialogMode)+chooseItemDialogMode c = do+  let subject = partActor+      verbSha body ar = if calmEnough body ar+                        then "notice"+                        else "paw distractedly"+      prompt body bodyUI ar c2 =+        let (tIn, t) = ppItemDialogMode c2+        in case c2 of+        MStore CGround ->+          makePhrase+            [ MU.Capitalize $ MU.SubjectVerbSg (subject bodyUI) "notice"+            , MU.Text "at"+            , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text "feet" ]+        MStore CSha ->+          makePhrase+            [ MU.Capitalize+              $ MU.SubjectVerbSg (subject bodyUI) (verbSha body ar)+            , MU.Text tIn+            , MU.Text t ]+        MStore COrgan ->+          makePhrase+            [ MU.Capitalize $ MU.SubjectVerbSg (subject bodyUI) "feel"+            , MU.Text tIn+            , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ]+        MOwned ->+          makePhrase+            [ MU.Capitalize $ MU.SubjectVerbSg (subject bodyUI) "recall"+            , MU.Text tIn+            , MU.Text t ]+        MStats ->+          makePhrase+            [ MU.Capitalize $ MU.SubjectVerbSg (subject bodyUI) "estimate"+            , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ]+        MLoreItem ->+          makePhrase+            [ MU.Capitalize $ MU.SubjectVerbSg (subject bodyUI) "recall"+            , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ]+        MLoreOrgan ->+          makePhrase+            [ MU.Capitalize $ MU.SubjectVerbSg (subject bodyUI) "recall"+            , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ]+        _ ->+          makePhrase+            [ MU.Capitalize $ MU.SubjectVerbSg (subject bodyUI) "see"+            , MU.Text tIn+            , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ]+  ggi <- getStoreItem prompt c+  recordHistory  -- item chosen, wipe out already shown msgs+  case ggi of+    (Right (iid, itemFull), (c2, _)) -> do+      leader <- getLeaderUI+      b <- getsState $ getActorBody leader+      bUI <- getsSession $ getActorUI leader+      let displayLore store prompt2 = do+            promptAdd prompt2+            lidV <- viewedLevelUI+            Level{lxsize, lysize} <- getLevel lidV+            localTime <- getsState $ getLocalTime (blid b)+            factionD <- getsState sfactionD+            actorAspect <- getsClient sactorAspect+            let ar = fromMaybe (assert `failure` leader)+                               (EM.lookup leader actorAspect)+                attrLine = itemDesc (bfid b) factionD (aHurtMelee ar)+                                    store localTime itemFull+                ov = splitAttrLine lxsize attrLine+            slides <-+              overlayToSlideshow (lysize + 1) [K.spaceKM, K.escKM] (ov, [])+            km <- getConfirms ColorFull [K.spaceKM, K.escKM] slides+            if km == K.spaceKM+            then chooseItemDialogMode c2+            else failWith "never mind"+      case c2 of+        MStore COrgan -> do+          let symbol = jsymbol (itemBase itemFull)+              blurb | symbol == '+' = "temporary condition"+                    | otherwise = "organ"+              prompt2 = makeSentence [ partActor bUI, "can't choose"+                                     , MU.AW blurb ]+          displayLore COrgan prompt2+        MStore fromCStore -> do+          modifySession $ \sess -> sess {sitemSel = Just (fromCStore, iid)}+          return $ Right c2+        MOwned -> do+          found <- getsState $ findIid leader (bfid b) iid+          let (newAid, bestStore) = case leader `lookup` found of+                Just (_, store) -> (leader, store)+                Nothing -> case found of+                  (aid, (_, store)) : _ -> (aid, store)+                  [] -> assert `failure` iid+          modifySession $ \sess -> sess {sitemSel = Just (bestStore, iid)}+          arena <- getArenaUI+          b2 <- getsState $ getActorBody newAid+          fact <- getsState $ (EM.! bfid b2) . sfactionD+          let (autoDun, _) = autoDungeonLevel fact+          if | blid b2 /= arena && autoDun ->+               failSer NoChangeDunLeader+             | otherwise -> do+               void $ pickLeader True newAid+               return $ Right c2+        MStats -> assert `failure` ggi+        MLoreItem -> displayLore CGround+          (makeSentence [ MU.SubjectVerbSg (partActor bUI) "remember"+                        , "item lore" ])+        MLoreOrgan -> displayLore COrgan+          (makeSentence [ MU.SubjectVerbSg (partActor bUI) "remember"+                        , "organ lore" ])+    (Left _, (MStats, ekm)) -> case ekm of+      Right slot -> do+        let eqpSlot = statSlots !! fromJust (elemIndex slot allZeroSlots)+        leader <- getLeaderUI+        b <- getsState $ getActorBody leader+        bUI <- getsSession $ getActorUI leader+        actorAspect <- getsClient sactorAspect+        let ar = fromMaybe (assert `failure` leader)+                           (EM.lookup leader actorAspect)+            valueText = slotToDecorator eqpSlot b $ prEqpSlot eqpSlot ar+            prompt2 = makeSentence+              [ MU.WownW (partActor bUI) (MU.Text $ slotToName eqpSlot)+              , "is", MU.Text valueText ]+              <+> slotToDesc eqpSlot+        go <- displaySpaceEsc ColorFull prompt2+        if go+        then chooseItemDialogMode MStats+        else failWith "never mind"+      Left _ -> failWith "never mind"+    (Left err, _) -> failWith err++-- * ChooseItemProject++chooseItemProjectHuman :: forall m. MonadClientUI m => [Trigger] -> m MError+chooseItemProjectHuman ts = do+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  actorAspect <- getsClient sactorAspect+  let ar = fromMaybe (assert `failure` leader) (EM.lookup leader actorAspect)+  let calmE = calmEnough b ar+      cLegalRaw = [CGround, CInv, CSha, CEqp]+      cLegal | calmE = cLegalRaw+             | otherwise = delete CSha cLegalRaw+      (verb1, object1) = case ts of+        [] -> ("aim", "item")+        tr : _ -> (verb tr, object tr)+  mpsuitReq <- psuitReq ts+  case mpsuitReq of+    -- If xhair aim invalid, no item is considered a (suitable) missile.+    Left err -> failMsg err+    Right psuitReqFun -> do+      let psuit =+            return $ SuitsSomething $ either (const False) snd . psuitReqFun+          prompt = makePhrase ["What", object1, "to", verb1]+          promptGeneric = "What to fling"+      ggi <- getGroupItem psuit prompt promptGeneric cLegalRaw cLegal+      case ggi of+        Right ((iid, _itemFull), (MStore fromCStore, _)) -> do+          modifySession $ \sess -> sess {sitemSel = Just (fromCStore, iid)}+          return Nothing+        Left err -> failMsg err+        _ -> assert `failure` ggi++permittedProjectClient :: MonadClientUI m+                       => [Char] -> m (ItemFull -> Either ReqFailure Bool)+permittedProjectClient triggerSyms = do+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  actorSk <- leaderSkillsClientUI+  let skill = EM.findWithDefault 0 AbProject actorSk+  actorAspect <- getsClient sactorAspect+  let ar = fromMaybe (assert `failure` leader) (EM.lookup leader actorAspect)+      calmE = calmEnough b ar+  return $ permittedProject False skill calmE triggerSyms++projectCheck :: MonadClientUI m => Point -> m (Maybe ReqFailure)+projectCheck tpos = do+  Kind.COps{coTileSpeedup} <- getsState scops+  leader <- getLeaderUI+  eps <- getsClient seps+  sb <- getsState $ getActorBody leader+  let lid = blid sb+      spos = bpos sb+  Level{lxsize, lysize} <- getLevel lid+  case bla lxsize lysize eps spos tpos of+    Nothing -> return $ Just ProjectAimOnself+    Just [] -> assert `failure` "project from the edge of level"+                      `twith` (spos, tpos, sb)+    Just (pos : _) -> do+      lvl <- getLevel lid+      let t = lvl `at` pos+      if not $ Tile.isWalkable coTileSpeedup t+        then return $ Just ProjectBlockTerrain+        else do+          lab <- getsState $ posToAssocs pos lid+          if all (bproj . snd) lab+          then return Nothing+          else return $ Just ProjectBlockActor++-- | Check whether one is permitted to aim (for projecting) at a target+-- (this is only checked for actor targets so that the player doesn't miss+-- enemy getting out of sight; but for positions we let player+-- shoot at obstacles, e.g., to destroy them, and shoot at a lying item+-- and then at its posision, after enemy picked up the item).+-- Returns a different @seps@ if needed to reach the target actor.+--+-- Note: Perception is not enough for the check,+-- because the target actor can be obscured by a glass wall+-- or be out of sight range, but in weapon range.+xhairLegalEps :: MonadClientUI m => m (Either Text Int)+xhairLegalEps = do+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  lidV <- viewedLevelUI+  let !_A = assert (lidV == blid b) ()+      findNewEps onlyFirst pos = do+        oldEps <- getsClient seps+        mnewEps <- makeLine onlyFirst b pos oldEps+        case mnewEps of+          Just newEps -> return $ Right newEps+          Nothing ->+            return $ Left+                   $ if onlyFirst+                     then "aiming blocked at the first step"+                     else "aiming line to the opponent blocked somewhere"+  xhair <- getsSession sxhair+  case xhair of+    TEnemy a _ -> do+      body <- getsState $ getActorBody a+      let pos = bpos body+      if blid body == lidV+      then findNewEps False pos+      else assert `failure` (xhair, body, lidV)+    TPoint TEnemyPos{} _ _ ->+      return $ Left "selected opponent not visible"+    TPoint _ lid pos ->+      if lid == lidV+      then findNewEps True pos+      else assert `failure` (xhair, lidV)+    TVector v -> do+      Level{lxsize, lysize} <- getLevel lidV+      let shifted = shiftBounded lxsize lysize (bpos b) v+      if shifted == bpos b && v /= Vector 0 0+      then return $ Left "selected translation is void"+      else findNewEps True shifted++posFromXhair :: MonadClientUI m => m (Either Text Point)+posFromXhair = do+  canAim <- xhairLegalEps+  case canAim of+    Right newEps -> do+      -- Modify @seps@, permanently.+      modifyClient $ \cli -> cli {seps = newEps}+      sxhair <- getsSession sxhair+      mpos <- xhairToPos+      case mpos of+        Nothing -> assert `failure` sxhair+        Just pos -> do+          munit <- projectCheck pos+          case munit of+            Nothing -> return $ Right pos+            Just reqFail -> return $ Left $ showReqFailure reqFail+    Left cause -> return $ Left cause++psuitReq :: MonadClientUI m+         => [Trigger]+         -> m (Either Text (ItemFull -> Either ReqFailure (Point, Bool)))+psuitReq ts = do+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  lidV <- viewedLevelUI+  if lidV /= blid b+  then return $ Left "can't project on remote levels"+  else do+    mpos <- posFromXhair+    p <- permittedProjectClient $ triggerSymbols ts+    case mpos of+      Left err -> return $ Left err+      Right pos -> return $ Right $ \itemFull@ItemFull{itemBase} ->+        case p itemFull of+          Left err -> Left err+          Right False -> Right (pos, False)+          Right True ->+            Right (pos, totalRange itemBase >= chessDist (bpos b) pos)++triggerSymbols :: [Trigger] -> [Char]+triggerSymbols [] = []+triggerSymbols (ApplyItem{symbol} : ts) = symbol : triggerSymbols ts+triggerSymbols (_ : ts) = triggerSymbols ts++-- * ChooseItemApply++chooseItemApplyHuman :: forall m. MonadClientUI m => [Trigger] -> m MError+chooseItemApplyHuman ts = do+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  actorAspect <- getsClient sactorAspect+  let ar = fromMaybe (assert `failure` leader) (EM.lookup leader actorAspect)+      calmE = calmEnough b ar+      cLegalRaw = [CGround, CInv, CSha, CEqp]+      cLegal | calmE = cLegalRaw+             | otherwise = delete CSha cLegalRaw+      (verb1, object1) = case ts of+        [] -> ("apply", "item")+        tr : _ -> (verb tr, object tr)+      prompt = makePhrase ["What", object1, "to", verb1]+      promptGeneric = "What to apply"+      psuit :: m Suitability+      psuit = do+        mp <- permittedApplyClient $ triggerSymbols ts+        return $ SuitsSomething $ either (const False) id . mp+  ggi <- getGroupItem psuit prompt promptGeneric cLegalRaw cLegal+  case ggi of+    Right ((iid, _itemFull), (MStore fromCStore, _)) -> do+      modifySession $ \sess -> sess {sitemSel = Just (fromCStore, iid)}+      return Nothing+    Left err -> failMsg err+    _ -> assert `failure` ggi++permittedApplyClient :: MonadClientUI m+                     => [Char] -> m (ItemFull -> Either ReqFailure Bool)+permittedApplyClient triggerSyms = do+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  actorSk <- leaderSkillsClientUI+  let skill = EM.findWithDefault 0 AbApply actorSk+  actorAspect <- getsClient sactorAspect+  let ar = fromMaybe (assert `failure` leader) (EM.lookup leader actorAspect)+      calmE = calmEnough b ar+  localTime <- getsState $ getLocalTime (blid b)+  return $ permittedApply localTime skill calmE triggerSyms++-- * PickLeader++pickLeaderHuman :: MonadClientUI m => Int -> m MError+pickLeaderHuman k = do+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  arena <- getArenaUI+  sactorUI <- getsSession sactorUI+  mhero <- getsState $ tryFindHeroK sactorUI side k+  allA <- getsState $ EM.assocs . sactorD  -- not only on one level+  let allOurs = filter (\(_, body) ->+        not (bproj body) && bfid body == side) allA+      allOursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) allOurs+      hs = sortBy (comparing keySelected) allOursUI+      mactor = case drop k hs of+                 [] -> Nothing+                 (aid, b, _) : _ -> Just (aid, b)+      mchoice = mhero `mplus` mactor+      (autoDun, _) = autoDungeonLevel fact+  case mchoice of+    Nothing -> failMsg "no such member of the party"+    Just (aid, b)+      | blid b /= arena && autoDun ->+          failMsg $ showReqFailure NoChangeDunLeader+      | otherwise -> do+          void $ pickLeader True aid+          return Nothing++-- * PickLeaderWithPointer++pickLeaderWithPointerHuman :: MonadClientUI m => m MError+pickLeaderWithPointerHuman = pickLeaderWithPointer++-- * MemberCycle++-- | Switches current member to the next on the viewed level, if any, wrapping.+memberCycleHuman :: MonadClientUI m => m MError+memberCycleHuman = memberCycle True++-- * MemberBack++-- | Switches current member to the previous in the whole dungeon, wrapping.+memberBackHuman :: MonadClientUI m => m MError+memberBackHuman = memberBack True++-- * SelectActor++selectActorHuman :: MonadClientUI m => m ()+selectActorHuman = do+  leader <- getLeaderUI+  selectAidHuman leader++selectAidHuman :: MonadClientUI m => ActorId -> m ()+selectAidHuman leader = do+  bodyUI <- getsSession $ getActorUI leader+  wasMemeber <- getsSession $ ES.member leader . sselected+  let upd = if wasMemeber+            then ES.delete leader  -- already selected, deselect instead+            else ES.insert leader+  modifySession $ \sess -> sess {sselected = upd $ sselected sess}+  let subject = partActor bodyUI+  promptAdd $ makeSentence [subject, if wasMemeber+                                     then "deselected"+                                     else "selected"]++-- * SelectNone++selectNoneHuman :: MonadClientUI m => m ()+selectNoneHuman = do+  side <- getsClient sside+  lidV <- viewedLevelUI+  oursIds <- getsState $ fidActorRegularIds side lidV+  let ours = ES.fromDistinctAscList oursIds+  oldSel <- getsSession sselected+  let wasNone = ES.null $ ES.intersection ours oldSel+      upd = if wasNone+            then ES.union  -- already all deselected; select all instead+            else ES.difference+  modifySession $ \sess -> sess {sselected = upd (sselected sess) ours}+  let subject = "all party members on the level"+  promptAdd $ makeSentence [subject, if wasNone+                                     then "selected"+                                     else "deselected"]++-- * SelectWithPointer++selectWithPointerHuman :: MonadClientUI m => m MError+selectWithPointerHuman = do+  lidV <- viewedLevelUI+  Level{lysize} <- getLevel lidV+  side <- getsClient sside+  ours <- getsState $ filter (not . bproj . snd)+                      . actorAssocs (== side) lidV+  sactorUI <- getsSession sactorUI+  let oursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) ours+      viewed = sortBy (comparing keySelected) oursUI+  Point{..} <- getsSession spointer+  -- Select even if no space in status line for the actor's symbol.+  if | py == lysize + 2 && px == 0 -> selectNoneHuman >> return Nothing+     | py == lysize + 2 ->+         case drop (px - 1) viewed of+           [] -> failMsg "not pointing at an actor"+           (aid, _, _) : _ -> selectAidHuman aid >> return Nothing+     | otherwise ->+         case find (\(_, b) -> bpos b == Point px (py - mapStartY)) ours of+           Nothing -> failMsg "not pointing at an actor"+           Just (aid, _) -> selectAidHuman aid >> return Nothing++-- * Repeat++-- Note that walk followed by repeat should not be equivalent to run,+-- because the player can really use a command that does not stop+-- at terrain change or when walking over items.+repeatHuman :: MonadClientUI m => Int -> m ()+repeatHuman n = do+  (_, seqPrevious, k) <- getsSession slastRecord+  let macro = concat $ replicate n $ reverse seqPrevious+  modifySession $ \sess -> sess {slastPlay = macro ++ slastPlay sess}+  let slastRecord = ([], [], if k == 0 then 0 else maxK)+  modifySession $ \sess -> sess {slastRecord}++maxK :: Int+maxK = 100++-- * Record++recordHuman :: MonadClientUI m => m ()+recordHuman = do+  (_seqCurrent, seqPrevious, k) <- getsSession slastRecord+  case k of+    0 -> do+      let slastRecord = ([], [], maxK)+      modifySession $ \sess -> sess {slastRecord}+      promptAdd $ "Macro will be recorded for up to"+                  <+> tshow maxK+                  <+> "actions. Stop recording with the same key."+    _ -> do+      let slastRecord = (seqPrevious, [], 0)+      modifySession $ \sess -> sess {slastRecord}+      promptAdd $ "Macro recording stopped after"+                  <+> tshow (maxK - k - 1) <+> "actions."++-- * History++historyHuman :: forall m. MonadClientUI m => m ()+historyHuman = do+  history <- getsSession shistory+  arena <- getArenaUI+  Level{lxsize, lysize} <- getLevel arena+  localTime <- getsState $ getLocalTime arena+  global <- getsState stime+  let rh = renderHistory history+      turnsGlobal = global `timeFitUp` timeTurn+      turnsLocal = localTime `timeFitUp` timeTurn+      msg = makeSentence+        [ "You survived for"+        , MU.CarWs turnsGlobal "half-second turn"+        , "(this level:"+        , MU.Text (tshow turnsLocal) <> ")" ]+      kxs = [ (Right sn, (slotPrefix sn, 0, lxsize))+            | sn <- take (length rh) intSlots ]+  promptAdd msg+  okxs <- overlayToSlideshow (lysize + 3) [K.escKM] (rh, kxs)+  let displayAllHistory = do+        menuIxMap <- getsSession smenuIxMap+        let menuName = "history"+            menuIx = fromMaybe 0 (M.lookup menuName menuIxMap)+        (ekm, pointer) <-+          displayChoiceScreen ColorFull True menuIx okxs [K.escKM]+        modifySession $ \sess ->+          sess {smenuIxMap = M.insert menuName pointer menuIxMap}+        case ekm of+          Left km | km == K.escKM ->+            promptAdd "Try to survive a few seconds more, if you can."+          Right SlotChar{..} | slotChar == 'a' ->+            displayOneReport slotPrefix+          _ -> assert `failure` ekm+      displayOneReport :: Int -> m ()+      displayOneReport histSlot = do+        let timeReport = case drop histSlot rh of+              [] -> assert `failure` histSlot+              tR : _ -> tR+            ov0 = splitReportForHistory lxsize timeReport+            prompt = makeSentence+              [ "the", MU.Ordinal $ histSlot + 1+              , "record of all history follows" ]+            histBound = lengthHistory history - 1+            keys = [K.spaceKM, K.escKM] ++ [K.upKM | histSlot /= 0]+                                        ++ [K.downKM | histSlot /= histBound]+        promptAdd prompt+        slides <- overlayToSlideshow (lysize + 1) keys (ov0, [])+        km <- getConfirms ColorFull keys slides+        case K.key km of+          K.Space -> displayAllHistory+          K.Up -> displayOneReport $ histSlot - 1+          K.Down -> displayOneReport $ histSlot + 1+          K.Esc -> promptAdd "Try to learn from your previous mistakes."+          _ -> assert `failure` km+  displayAllHistory++-- * MarkVision++markVisionHuman :: MonadClientUI m => m ()+markVisionHuman = modifySession toggleMarkVision++-- * MarkSmell++markSmellHuman :: MonadClientUI m => m ()+markSmellHuman = modifySession toggleMarkSmell++-- * MarkSuspect++markSuspectHuman :: MonadClientUI m => m ()+markSuspectHuman = do+  -- @condBFS@ depends on the setting we change here.+  invalidateBfsAll+  modifyClient cycleMarkSuspect++-- * Cancel++-- | End aiming mode, rejecting the current position.+cancelHuman :: MonadClientUI m => m ()+cancelHuman = do+  saimMode <- getsSession saimMode+  when (isJust saimMode) $ do+    clearAimMode+    promptAdd "Target not set."++-- * Accept++-- | Accept the current x-hair position as target, ending+-- aiming mode, if active.+acceptHuman :: MonadClientUI m => m ()+acceptHuman = do+  endAiming+  endAimingMsg+  clearAimMode++-- | End aiming mode, accepting the current position.+endAiming :: MonadClientUI m => m ()+endAiming = do+  leader <- getLeaderUI+  sxhair <- getsSession sxhair+  modifyClient $ updateTarget leader $ const $ Just sxhair++endAimingMsg :: MonadClientUI m => m ()+endAimingMsg = do+  leader <- getLeaderUI+  (mtargetMsg, _) <- targetDescLeader leader+  let targetMsg = fromJust mtargetMsg+  subject <- partAidLeader leader+  promptAdd $+    makeSentence [MU.SubjectVerbSg subject "target", MU.Text targetMsg]++-- * TgtClear++tgtClearHuman :: MonadClientUI m => m ()+tgtClearHuman = do+  leader <- getLeaderUI+  tgt <- getsClient $ getTarget leader+  case tgt of+    Just _ -> modifyClient $ updateTarget leader (const Nothing)+    Nothing -> do+      clearXhair+      doLook++-- * ItemClear++itemClearHuman :: MonadClientUI m => m ()+itemClearHuman = modifySession $ \sess -> sess {sitemSel = Nothing}++-- | Perform look around in the current position of the xhair.+-- Does nothing outside aiming mode.+doLook :: MonadClientUI m => m ()+doLook = do+  saimMode <- getsSession saimMode+  case saimMode of+    Nothing -> return ()+    Just aimMode -> do+      leader <- getLeaderUI+      let lidV = aimLevelId aimMode+      lvl <- getLevel lidV+      xhairPos <- xhairToPos+      per <- getPerFid lidV+      b <- getsState $ getActorBody leader+      let p = fromMaybe (bpos b) xhairPos+      inhabitants <- getsState $ posToAssocs p lidV+      sactorUI <- getsSession sactorUI+      let inhabitantsUI =+            map (\(aid2, b2) -> (aid2, b2, sactorUI EM.! aid2)) inhabitants+      seps <- getsClient seps+      mnewEps <- makeLine False b p seps+      itemToF <- itemToFullClient+      let aims = isJust mnewEps+          enemyMsg = case inhabitants of+            [] -> ""+            (_, body) : rest ->+                 -- Even if it's the leader, give his proper name, not 'you'.+                 let subjects = map (\(_, _, bUI) ->+                       partActor bUI) inhabitantsUI+                     subject = MU.WWandW subjects+                     verb = "be here"+                     desc =+                       if not (null rest)  -- many actors, only list names+                       then ""+                       else case itemDisco $ itemToF (btrunk body) (1, []) of+                         Nothing -> ""  -- no details, only show the name+                         Just ItemDisco{itemKind} -> IK.idesc itemKind+                     pdesc = if desc == "" then "" else "(" <> desc <> ")"+                 in makeSentence [MU.SubjectVerbSg subject verb] <+> pdesc+          canSee = ES.member p (totalVisible per)+          vis | isUknownSpace $ lvl `at` p = "that is"+              | not canSee = "you remember"+              | not aims = "you are aware of"+              | otherwise = "you see"+      -- Show general info about current position.+      lookMsg <- lookAt True vis canSee p leader enemyMsg+      promptAdd lookMsg++-- * MoveXhair++-- | Move the xhair. Assumes aiming mode.+moveXhairHuman :: MonadClientUI m => Vector -> Int -> m MError+moveXhairHuman dir n = do+  leader <- getLeaderUI+  saimMode <- getsSession saimMode+  let lidV = maybe (assert `failure` leader) aimLevelId saimMode+  Level{lxsize, lysize} <- getLevel lidV+  lpos <- getsState $ bpos . getActorBody leader+  sxhair <- getsSession sxhair+  xhairPos <- xhairToPos+  let cpos = fromMaybe lpos xhairPos+      shiftB pos = shiftBounded lxsize lysize pos dir+      newPos = iterate shiftB cpos !! n+  if newPos == cpos then failMsg "never mind"+  else do+    let tgt = case sxhair of+          TVector{} -> TVector $ newPos `vectorToFrom` lpos+          _ -> TPoint TAny lidV newPos+    modifySession $ \sess -> sess {sxhair = tgt}+    doLook+    return Nothing++-- * AimTgt++-- | Start aiming.+aimTgtHuman :: MonadClientUI m => m MError+aimTgtHuman = do+  -- (Re)start aiming at the current level.+  lidV <- viewedLevelUI+  modifySession $ \sess -> sess {saimMode = Just $ AimMode lidV}+  doLook+  failMsg "aiming started"++-- * AimFloor++-- | Cycle aiming mode. Do not change position of the xhair,+-- switch among things at that position.+aimFloorHuman :: MonadClientUI m => m ()+aimFloorHuman = do+  lidV <- viewedLevelUI+  leader <- getLeaderUI+  lpos <- getsState $ bpos . getActorBody leader+  xhairPos <- xhairToPos+  sxhair <- getsSession sxhair+  saimMode <- getsSession saimMode+  bsAll <- getsState $ actorAssocs (const True) lidV+  let xhair = fromMaybe lpos xhairPos+      tgt = case sxhair of+        _ | isNothing saimMode ->  -- first key press: keep target+          sxhair+        TEnemy a True -> TEnemy a False+        TEnemy{} -> TPoint TAny lidV xhair+        TPoint{} -> TVector $ xhair `vectorToFrom` lpos+        TVector{} ->+          -- For projectiles, we pick here the first that would be picked+          -- by '*', so that all other projectiles on the tile come next,+          -- without any intervening actors from other tiles.+          case find (\(_, m) -> Just (bpos m) == xhairPos) bsAll of+            Just (im, _) -> TEnemy im True+            Nothing -> TPoint TAny lidV xhair+  modifySession $ \sess -> sess {saimMode = Just $ AimMode lidV}+  modifySession $ \sess -> sess {sxhair = tgt}+  doLook++-- * AimEnemy++aimEnemyHuman :: MonadClientUI m => m ()+aimEnemyHuman = do+  lidV <- viewedLevelUI+  leader <- getLeaderUI+  lpos <- getsState $ bpos . getActorBody leader+  xhairPos <- xhairToPos+  sxhair <- getsSession sxhair+  saimMode <- getsSession saimMode+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  bsAll <- getsState $ actorAssocs (const True) lidV+  let ordPos (_, b) = (chessDist lpos $ bpos b, bpos b)+      dbs = sortBy (comparing ordPos) bsAll+      pickUnderXhair =  -- switch to the actor under xhair, if any+        let i = fromMaybe (-1)+                $ findIndex ((== xhairPos) . Just . bpos . snd) dbs+        in splitAt i dbs+      (permitAnyActor, (lt, gt)) = case sxhair of+        TEnemy a permit | isJust saimMode ->  -- pick next enemy+          let i = fromMaybe (-1) $ findIndex ((== a) . fst) dbs+          in (permit, splitAt (i + 1) dbs)+        TEnemy a permit ->  -- first key press, retarget old enemy+          let i = fromMaybe (-1) $ findIndex ((== a) . fst) dbs+          in (permit, splitAt i dbs)+        TPoint (TEnemyPos _ permit) _ _ -> (permit, pickUnderXhair)+        _ -> (False, pickUnderXhair)  -- the sensible default is only-foes+      gtlt = gt ++ lt+      isEnemy b = isAtWar fact (bfid b)+                  && not (bproj b)+                  && bhp b > 0+      lf = filter (isEnemy . snd) gtlt+      tgt | permitAnyActor = case gtlt of+        (a, _) : _ -> TEnemy a True+        [] -> sxhair  -- no actors in sight, stick to last target+          | otherwise = case lf of+        (a, _) : _ -> TEnemy a False+        [] -> sxhair  -- no seen foes in sight, stick to last target+  -- Register the chosen enemy, to pick another on next invocation.+  modifySession $ \sess -> sess {saimMode = Just $ AimMode lidV}+  modifySession $ \sess -> sess {sxhair = tgt}+  doLook++-- * AimItem++aimItemHuman :: MonadClientUI m => m ()+aimItemHuman = do+  lidV <- viewedLevelUI+  leader <- getLeaderUI+  lpos <- getsState $ bpos . getActorBody leader+  xhairPos <- xhairToPos+  sxhair <- getsSession sxhair+  saimMode <- getsSession saimMode+  bsAll <- getsState $ EM.keys . lfloor . (EM.! lidV) . sdungeon+  let ordPos p = (chessDist lpos p, p)+      dbs = sortBy (comparing ordPos) bsAll+      pickUnderXhair =  -- switch to the item under xhair, if any+        let i = fromMaybe (-1)+                $ findIndex ((== xhairPos) . Just) dbs+        in splitAt i dbs+      (lt, gt) = case sxhair of+        TPoint _ lid pos | isJust saimMode && lid == lidV ->  -- pick next item+          let i = fromMaybe (-1) $ findIndex (== pos) dbs+          in splitAt (i + 1) dbs+        TPoint _ lid pos | lid == lidV ->  -- first key press, retarget old item+          let i = fromMaybe (-1) $ findIndex (== pos) dbs+          in splitAt i dbs+        _ -> pickUnderXhair+      gtlt = gt ++ lt+      tgt = case gtlt of+        p : _ -> TPoint TAny lidV p+        [] -> sxhair  -- no items remembered, stick to last target+  -- Register the chosen enemy, to pick another on next invocation.+  modifySession $ \sess -> sess {saimMode = Just $ AimMode lidV}+  modifySession $ \sess -> sess {sxhair = tgt}+  doLook++-- * AimAscend++-- | Change the displayed level in aiming mode to (at most)+-- k levels shallower. Enters aiming mode, if not already in one.+aimAscendHuman :: MonadClientUI m => Int -> m MError+aimAscendHuman k = do+  dungeon <- getsState sdungeon+  lidV <- viewedLevelUI+  let up = k > 0+  case ascendInBranch dungeon up lidV of+    [] -> failMsg "no more levels in this direction"+    _ : _ -> do+      let ascendOne lid = case ascendInBranch dungeon up lid of+            [] -> lid+            nlid : _ -> nlid+          lidK = iterate ascendOne lidV !! abs k+      leader <- getLeaderUI+      lpos <- getsState $ bpos . getActorBody leader+      xhairPos <- xhairToPos+      let cpos = fromMaybe lpos xhairPos+          tgt = TPoint TAny lidK cpos+      modifySession $ \sess -> sess { saimMode = Just (AimMode lidK)+                                    , sxhair = tgt }+      doLook+      return Nothing++-- * EpsIncr++-- | Tweak the @eps@ parameter of the aiming digital line.+epsIncrHuman :: MonadClientUI m => Bool -> m ()+epsIncrHuman b = do+  saimMode <- getsSession saimMode+  lidV <- viewedLevelUI+  modifySession $ \sess -> sess {saimMode = Just $ AimMode lidV}+  modifyClient $ \cli -> cli {seps = seps cli + if b then 1 else -1}+  invalidateBfsAll -- actually only paths, but that's cheap enough+  flashAiming+  modifySession $ \sess -> sess {saimMode}++--- Flash the aiming line and path.+flashAiming :: MonadClientUI m => m ()+flashAiming = do+  lidV <- viewedLevelUI+  animate lidV pushAndDelay++-- * XhairUnknown++xhairUnknownHuman :: MonadClientUI m => m MError+xhairUnknownHuman = do+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  mpos <- closestUnknown leader+  case mpos of+    Nothing -> failMsg "no more unknown spots left"+    Just p -> do+      let sxhair = TPoint TUnknown (blid b) p+      modifySession $ \sess -> sess {sxhair}+      doLook+      return Nothing++-- * XhairItem++xhairItemHuman :: MonadClientUI m => m MError+xhairItemHuman = do+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  items <- closestItems leader+  case items of+    [] -> failMsg "no more items remembered or visible"+    _ -> do+      let (_, (p, bag)) = maximumBy (comparing fst) items+          sxhair = TPoint (TItem bag) (blid b) p+      modifySession $ \sess -> sess {sxhair}+      doLook+      return Nothing++-- * XhairStair++xhairStairHuman :: MonadClientUI m => Bool -> m MError+xhairStairHuman up = do+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  stairs <- closestTriggers (if up then ViaStairsUp else ViaStairsDown) leader+  case stairs of+    [] -> failMsg $ "no stairs" <+> if up then "up" else "down"+    _ -> do+      let (_, (p, (p0, bag))) = maximumBy (comparing fst) stairs+          sxhair = TPoint (TEmbed bag p0) (blid b) p+      modifySession $ \sess -> sess {sxhair}+      doLook+      return Nothing++-- * XhairPointerFloor++xhairPointerFloorHuman :: MonadClientUI m => m ()+xhairPointerFloorHuman = do+  saimMode <- getsSession saimMode+  xhairPointerFloor False+  modifySession $ \sess -> sess {saimMode}++xhairPointerFloor :: MonadClientUI m => Bool -> m ()+xhairPointerFloor verbose = do+  lidV <- viewedLevelUI+  Level{lxsize, lysize} <- getLevel lidV+  Point{..} <- getsSession spointer+  if px >= 0 && py - mapStartY >= 0+     && px < lxsize && py - mapStartY < lysize+  then do+    oldXhair <- getsSession sxhair+    let sxhair = TPoint TAny lidV $ Point px (py - mapStartY)+        sxhairMoused = sxhair /= oldXhair+    modifySession $ \sess ->+      sess { saimMode = Just $ AimMode lidV+           , sxhair+           , sxhairMoused }+    if verbose then doLook else flashAiming+  else stopPlayBack++-- * XhairPointerEnemy++xhairPointerEnemyHuman :: MonadClientUI m => m ()+xhairPointerEnemyHuman = do+  saimMode <- getsSession saimMode+  xhairPointerEnemy False+  modifySession $ \sess -> sess {saimMode}++xhairPointerEnemy :: MonadClientUI m => Bool -> m ()+xhairPointerEnemy verbose = do+  lidV <- viewedLevelUI+  Level{lxsize, lysize} <- getLevel lidV+  Point{..} <- getsSession spointer+  if px >= 0 && py - mapStartY >= 0+     && px < lxsize && py - mapStartY < lysize+  then do+    bsAll <- getsState $ actorAssocs (const True) lidV+    oldXhair <- getsSession sxhair+    let newPos = Point px (py - mapStartY)+        sxhair =+          case find (\(_, m) -> bpos m == newPos) bsAll of+            Just (im, _) -> TEnemy im True+            Nothing -> TPoint TAny lidV newPos+        sxhairMoused = sxhair /= oldXhair+    modifySession $ \sess ->+      sess { saimMode = Just $ AimMode lidV+           , sxhairMoused }+    modifySession $ \sess -> sess {sxhair}+    if verbose then doLook else flashAiming+  else stopPlayBack++-- * AimPointerFloor++aimPointerFloorHuman :: MonadClientUI m => m ()+aimPointerFloorHuman = xhairPointerFloor True++-- * AimPointerEnemy++aimPointerEnemyHuman :: MonadClientUI m => m ()+aimPointerEnemyHuman = xhairPointerEnemy True

+ Game/LambdaHack/Client/UI/HandleHumanM.hs view

@@ -0,0 +1,124 @@+-- | Semantics of human player commands.+module Game.LambdaHack.Client.UI.HandleHumanM+  ( cmdHumanSem+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Game.LambdaHack.Client.UI.HandleHelperM+import Game.LambdaHack.Client.UI.HandleHumanGlobalM+import Game.LambdaHack.Client.UI.HandleHumanLocalM+import Game.LambdaHack.Client.UI.HumanCmd+import Game.LambdaHack.Client.UI.MonadClientUI+import Game.LambdaHack.Common.Request++-- | The semantics of human player commands in terms of the @Action@ monad.+-- Decides if the action takes time and what action to perform.+-- Some time cosuming commands are enabled in aiming mode, but cannot be+-- invoked in aiming mode on a remote level (level different than+-- the level of the leader).+cmdHumanSem :: MonadClientUI m => HumanCmd -> m (Either MError ReqUI)+cmdHumanSem cmd =+  if noRemoteHumanCmd cmd then do+    -- If in aiming mode, check if the current level is the same+    -- as player level and refuse performing the action otherwise.+    arena <- getArenaUI+    lidV <- viewedLevelUI+    if arena /= lidV then+      weaveJust <$> failWith+        "command disabled on a remote level, press ESC to switch back"+    else cmdAction cmd+  else cmdAction cmd++-- | Compute the basic action for a command and mark whether it takes time.+cmdAction :: MonadClientUI m => HumanCmd -> m (Either MError ReqUI)+cmdAction cmd = case cmd of+  Macro kms -> addNoError $ macroHuman kms+  ByArea l -> byAreaHuman cmdAction l+  ByAimMode{..} ->+    byAimModeHuman (cmdAction exploration) (cmdAction aiming)+  ByItemMode{..} ->+    byItemModeHuman ts (cmdAction notChosen) (cmdAction chosen)+  ComposeIfLocal cmd1 cmd2 ->+    composeIfLocalHuman (cmdAction cmd1) (cmdAction cmd2)+  ComposeUnlessError cmd1 cmd2 ->+    composeUnlessErrorHuman (cmdAction cmd1) (cmdAction cmd2)+  Compose2ndLocal cmd1 cmd2 ->+    compose2ndLocalHuman (cmdAction cmd1) (cmdAction cmd2)+  LoopOnNothing cmd1 ->+    loopOnNothingHuman (cmdAction cmd1)++  Wait -> weaveJust <$> Right <$> fmap timedToUI waitHuman+  Wait10 -> weaveJust <$> Right <$> fmap timedToUI waitHuman10+  MoveDir v ->+    weaveJust <$> (ReqUITimed <$$> moveRunHuman True True False False v)+  RunDir v -> weaveJust <$> (ReqUITimed <$$> moveRunHuman True True True True v)+  RunOnceAhead -> runOnceAheadHuman+  MoveOnceToXhair -> weaveJust <$> (ReqUITimed <$$> moveOnceToXhairHuman)+  RunOnceToXhair  -> weaveJust <$> (ReqUITimed <$$> runOnceToXhairHuman)+  ContinueToXhair -> weaveJust <$> (ReqUITimed <$$> continueToXhairHuman)+  MoveItem cLegalRaw toCStore mverb auto ->+    weaveJust <$> (timedToUI <$$> moveItemHuman cLegalRaw toCStore mverb auto)+  Project ts -> weaveJust <$> (timedToUI <$$> projectHuman ts)+  Apply ts -> weaveJust <$> (timedToUI <$$> applyHuman ts)+  AlterDir ts -> weaveJust <$> (timedToUI <$$> alterDirHuman ts)+  AlterWithPointer ts -> weaveJust <$> (timedToUI <$$> alterWithPointerHuman ts)+  Help -> helpHuman cmdAction+  ItemMenu -> itemMenuHuman cmdAction+  ChooseItemMenu dialogMode -> chooseItemMenuHuman cmdAction dialogMode+  MainMenu -> mainMenuHuman cmdAction+  GameDifficultyIncr -> gameDifficultyIncr >> challengesMenuHuman cmdAction+  GameWolfToggle -> gameWolfToggle >> challengesMenuHuman cmdAction+  GameFishToggle -> gameFishToggle >> challengesMenuHuman cmdAction+  GameScenarioIncr -> gameScenarioIncr >> mainMenuHuman cmdAction++  GameRestart -> weaveJust <$> gameRestartHuman+  GameExit -> weaveJust <$> fmap Right gameExitHuman+  GameSave -> weaveJust <$> fmap Right gameSaveHuman+  Tactic -> weaveJust <$> tacticHuman+  Automate -> weaveJust <$> automateHuman++  Clear -> addNoError clearHuman+  SortSlots -> addNoError sortSlotsHuman+  ChooseItem dialogMode -> Left <$> chooseItemHuman dialogMode+  ChooseItemProject ts -> Left <$> chooseItemProjectHuman ts+  ChooseItemApply ts -> Left <$> chooseItemApplyHuman ts+  PickLeader k -> Left <$> pickLeaderHuman k+  PickLeaderWithPointer -> Left <$> pickLeaderWithPointerHuman+  MemberCycle -> Left <$> memberCycleHuman+  MemberBack -> Left <$> memberBackHuman+  SelectActor -> addNoError selectActorHuman+  SelectNone -> addNoError selectNoneHuman+  SelectWithPointer -> Left <$> selectWithPointerHuman+  Repeat n -> addNoError $ repeatHuman n+  Record -> addNoError recordHuman+  History -> addNoError historyHuman+  MarkVision -> markVisionHuman >> settingsMenuHuman cmdAction+  MarkSmell -> markSmellHuman >> settingsMenuHuman cmdAction+  MarkSuspect -> markSuspectHuman >> settingsMenuHuman cmdAction+  SettingsMenu -> settingsMenuHuman cmdAction+  ChallengesMenu -> challengesMenuHuman cmdAction++  Cancel -> addNoError cancelHuman+  Accept -> addNoError acceptHuman+  TgtClear -> addNoError tgtClearHuman+  ItemClear -> addNoError itemClearHuman+  MoveXhair v k -> Left <$> moveXhairHuman v k+  AimTgt -> Left <$> aimTgtHuman+  AimFloor -> addNoError aimFloorHuman+  AimEnemy -> addNoError aimEnemyHuman+  AimItem -> addNoError aimItemHuman+  AimAscend k -> Left <$> aimAscendHuman k+  EpsIncr b -> addNoError $ epsIncrHuman b+  XhairUnknown -> Left <$> xhairUnknownHuman+  XhairItem -> Left <$> xhairItemHuman+  XhairStair up -> Left <$> xhairStairHuman up+  XhairPointerFloor -> addNoError xhairPointerFloorHuman+  XhairPointerEnemy -> addNoError xhairPointerEnemyHuman+  AimPointerFloor -> addNoError aimPointerFloorHuman+  AimPointerEnemy -> addNoError aimPointerEnemyHuman++addNoError :: Monad m => m () -> m (Either MError ReqUI)+addNoError cmdCli = cmdCli >> return (Left Nothing)

Game/LambdaHack/Client/UI/HumanCmd.hs view

@@ -1,76 +1,139 @@ {-# LANGUAGE DeriveGeneric #-} -- | Abstract syntax human player commands. module Game.LambdaHack.Client.UI.HumanCmd-  ( CmdCategory(..), HumanCmd(..), Trigger(..)-  , noRemoteHumanCmd, categoryDescription, cmdDescription+  ( CmdCategory(..), categoryDescription+  , CmdArea(..), areaDescription+  , CmdTriple, HumanCmd(..), noRemoteHumanCmd+  , Trigger(..)   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Control.DeepSeq-import Control.Exception.Assert.Sugar-import Data.Maybe-import Data.Text (Text)+import Data.Binary import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU -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 | CmdMouse-  | CmdInternal | CmdDebug | CmdMinimal+    CmdMainMenu | CmdItemMenu+  | CmdMove | CmdItem | CmdAim | CmdMeta | CmdMouse+  | CmdInternal | CmdNoHelp | CmdDebug | CmdMinimal   deriving (Show, Read, Eq, Generic)  instance NFData CmdCategory +instance Binary CmdCategory+ categoryDescription :: CmdCategory -> Text-categoryDescription CmdMenu = "Main Menu"+categoryDescription CmdMainMenu = "Main Menu"+categoryDescription CmdItemMenu = "Item Menu commands" categoryDescription CmdMove = "Terrain exploration and alteration"-categoryDescription CmdItem = "Item use"-categoryDescription CmdTgt = "Aiming and targeting"-categoryDescription CmdAuto = "Automation"+categoryDescription CmdItem = "Remaining item-related commands"+categoryDescription CmdAim = "Aiming" categoryDescription CmdMeta = "Assorted" categoryDescription CmdMouse = "Mouse" categoryDescription CmdInternal = "Internal"+categoryDescription CmdNoHelp = "Ignored in Help" categoryDescription CmdDebug = "Debug" categoryDescription CmdMinimal = "The minimal command set" +-- The constructors are sorted, roughly, wrt inclusion, then top to bottom,+-- the left to right.+data CmdArea =+    CaMessage+  | CaMapLeader+  | CaMapParty+  | CaMap+  | CaLevelNumber+  | CaArenaName+  | CaPercentSeen+  | CaXhairDesc+  | CaSelected+  | CaCalmGauge+  | CaHPGauge+  | CaTargetDesc+  deriving (Show, Read, Eq, Ord, Generic)++instance NFData CmdArea++instance Binary CmdArea++areaDescription :: CmdArea -> Text+areaDescription ca = case ca of+  CaMessage ->      "message line"+  CaMapLeader ->    "leader on map"+  CaMapParty ->     "party on map"+  CaMap ->          "the map area"+  CaLevelNumber ->  "level number"+  CaArenaName ->    "level caption"+  CaPercentSeen ->  "percent seen"+  CaXhairDesc ->    "x-hair info"+  CaSelected ->     "party roster"+  CaCalmGauge ->    "Calm gauge"+  CaHPGauge ->      "HP gauge"+  CaTargetDesc ->   "target info"+  --                 1234567890123++type CmdTriple = ([CmdCategory], Text, HumanCmd)+ -- | Abstract syntax of player commands. data HumanCmd =+    -- Meta.+    Macro ![String]+  | ByArea ![(CmdArea, HumanCmd)]  -- if outside the areas, do nothing+  | ByAimMode {exploration :: !HumanCmd, aiming :: !HumanCmd}+  | ByItemMode {ts :: ![Trigger], notChosen :: !HumanCmd, chosen :: !HumanCmd}+  | ComposeIfLocal !HumanCmd !HumanCmd+  | ComposeUnlessError !HumanCmd !HumanCmd+  | Compose2ndLocal !HumanCmd !HumanCmd+  | LoopOnNothing !HumanCmd     -- Global.     -- These usually take time.-    Move !Vector-  | Run !Vector   | Wait-  | MoveItem ![CStore] !CStore !(Maybe MU.Part) !MU.Part !Bool-  | DescribeItem !ItemDialogMode-  | Project     ![Trigger]-  | Apply       ![Trigger]-  | AlterDir    ![Trigger]-  | TriggerTile ![Trigger]+  | Wait10+  | MoveDir !Vector+  | RunDir !Vector   | RunOnceAhead-  | MoveOnceToCursor-  | RunOnceToCursor-  | ContinueToCursor+  | MoveOnceToXhair+  | RunOnceToXhair+  | ContinueToXhair+  | MoveItem ![CStore] !CStore !(Maybe MU.Part) !Bool+  | Project ![Trigger]+  | Apply ![Trigger]+  | AlterDir ![Trigger]+  | AlterWithPointer ![Trigger]+  | Help+  | ItemMenu+  | MainMenu     -- Below this line, commands do not take time.-  | GameRestart !(GroupName ModeKind)+  | GameDifficultyIncr+  | GameWolfToggle+  | GameFishToggle+  | GameScenarioIncr+  | GameRestart   | GameExit   | GameSave   | Tactic   | Automate-    -- Local.-    -- Below this line, commands do not notify the server.-  | GameDifficultyCycle+    -- Local. Below this line, commands do not notify the server.+  | Clear+  | SortSlots+  | ChooseItem !ItemDialogMode+  | ChooseItemMenu !ItemDialogMode+  | ChooseItemProject ![Trigger]+  | ChooseItemApply ![Trigger]   | PickLeader !Int+  | PickLeaderWithPointer   | MemberCycle   | MemberBack   | SelectActor   | SelectNone-  | Clear-  | StopIfTgtMode   | SelectWithPointer   | Repeat !Int   | Record@@ -78,131 +141,59 @@   | MarkVision   | MarkSmell   | MarkSuspect-  | Help-  | MainMenu-  | Macro !Text ![String]-    -- These are mostly related to targeting.-  | MoveCursor !Vector !Int-  | TgtFloor-  | TgtEnemy-  | TgtAscend !Int-  | EpsIncr !Bool-  | TgtClear-  | CursorUnknown-  | CursorItem-  | CursorStair !Bool+  | SettingsMenu+  | ChallengesMenu+    -- These are mostly related to aiming.   | Cancel   | Accept-  | CursorPointerFloor-  | CursorPointerEnemy-  | TgtPointerFloor-  | TgtPointerEnemy+  | TgtClear+  | ItemClear+  | MoveXhair !Vector !Int+  | AimTgt+  | AimFloor+  | AimEnemy+  | AimItem+  | AimAscend !Int+  | EpsIncr !Bool+  | XhairUnknown+  | XhairItem+  | XhairStair !Bool+  | XhairPointerFloor+  | XhairPointerEnemy+  | AimPointerFloor+  | AimPointerEnemy   deriving (Show, Read, Eq, Ord, Generic)  instance NFData HumanCmd -data Trigger =-    ApplyItem {verb :: !MU.Part, object :: !MU.Part, symbol :: !Char}-  | AlterFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !TK.Feature}-  | TriggerFeature-      {verb :: !MU.Part, object :: !MU.Part, feature :: !TK.Feature}-  deriving (Show, Read, Eq, Ord, Generic)--instance NFData Trigger+instance Binary HumanCmd  -- | Commands that are forbidden on a remote level, because they--- would usually take time when invoked on one.--- Note that some commands that take time are not included,--- because they don't take time in targeting mode.+-- would usually take time when invoked on one, but not necessarily do+-- what the player expects. Note that some commands that normally take time+-- are not included, because they don't take time in aiming mode+-- or their individual sanity conditions include a remote level check. noRemoteHumanCmd :: HumanCmd -> Bool noRemoteHumanCmd cmd = case cmd of   Wait          -> True+  Wait10        -> True   MoveItem{}    -> True   Apply{}       -> True   AlterDir{}    -> True-  MoveOnceToCursor -> True-  RunOnceToCursor  -> True-  ContinueToCursor -> True-  _             -> False---- | Description of player commands.-cmdDescription :: HumanCmd -> Text-cmdDescription cmd = case cmd of-  Move v      -> "move" <+> compassText v-  Run v       -> "run" <+> compassText v-  Wait        -> "wait"-  MoveItem _ store2 mverb object _ ->-    let verb = fromMaybe (MU.Text $ verbCStore store2) mverb-    in makePhrase [verb, object]-  DescribeItem (MStore CGround) -> "manage items on the ground"-  DescribeItem (MStore COrgan) -> "describe organs of the leader"-  DescribeItem (MStore CEqp) -> "manage equipment of the leader"-  DescribeItem (MStore CInv) -> "manage inventory pack of the leader"-  DescribeItem (MStore CSha) -> "manage the shared party stash"-  DescribeItem MOwned -> "describe all owned items"-  DescribeItem MStats -> "show the stats summary of the leader"-  Project ts  -> triggerDescription ts-  Apply ts    -> triggerDescription ts-  AlterDir ts -> triggerDescription ts-  TriggerTile ts -> triggerDescription ts-  RunOnceAhead -> "run once ahead"-  MoveOnceToCursor -> "move one step towards the crosshair"-  RunOnceToCursor -> "run selected one step towards the crosshair"-  ContinueToCursor -> "continue towards the crosshair"+  AlterWithPointer{} -> True+  MoveOnceToXhair -> True+  RunOnceToXhair -> True+  ContinueToXhair -> True+  _ -> False -  GameRestart t ->-    -- TODO: use mname for the game mode instead of t-    makePhrase ["new", MU.Capitalize $ MU.Text $ tshow t, "game"]-  GameExit    -> "save and exit"-  GameSave    -> "save game"-  Tactic      -> "cycle tactic of non-leader team members (WIP)"-  Automate    -> "automate faction (ESC to retake control)"+data Trigger =+    ApplyItem {verb :: !MU.Part, object :: !MU.Part, symbol :: !Char}+  | AlterFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !TK.Feature}+  deriving (Show, Eq, Ord, Generic) -  GameDifficultyCycle -> "cycle difficulty of the next game"-  PickLeader{} -> "pick leader"-  MemberCycle -> "cycle among party members on the level"-  MemberBack  -> "cycle among all party members"-  SelectActor -> "select (or deselect) a party member"-  SelectNone  -> "deselect (or select) all on the level"-  Clear       -> "clear messages"-  StopIfTgtMode -> "stop playback if in aiming mode"-  SelectWithPointer -> "select actors if pointer over actor list"-  Repeat 1    -> "voice again the recorded commands"-  Repeat n    -> "voice the recorded commands" <+> tshow n <+> "times"-  Record      -> "start recording commands"-  History     -> "display player diary"-  MarkVision  -> "toggle visible zone display"-  MarkSmell   -> "toggle smell clues display"-  MarkSuspect -> "toggle suspect terrain display"-  Help        -> "display help"-  MainMenu    -> "display the Main Menu"-  Macro t _   -> t+instance Read Trigger where+  readsPrec = assert `failure` "parsing of Trigger not implemented" `twith` () -  MoveCursor v 1 -> "move crosshair" <+> compassText v-  MoveCursor v k ->-    "move crosshair up to" <+> tshow k <+> "steps" <+> compassText v-  TgtFloor -> "cycle aiming styles"-  TgtEnemy -> "aim at an enemy"-  TgtAscend k | k == 1  -> "aim at next shallower level"-  TgtAscend k | k >= 2  -> "aim at" <+> tshow k    <+> "levels shallower"-  TgtAscend k | k == -1 -> "aim at next deeper level"-  TgtAscend k | k <= -2 -> "aim at" <+> tshow (-k) <+> "levels deeper"-  TgtAscend _ -> assert `failure` "void level change when aiming"-                        `twith` cmd-  EpsIncr True   -> "swerve the aiming line"-  EpsIncr False  -> "unswerve the aiming line"-  TgtClear       -> "reset target/crosshair"-  CursorUnknown  -> "set crosshair to the closest unknown spot"-  CursorItem     -> "set crosshair to the closest item"-  CursorStair up -> "set crosshair to the closest stairs"-                    <+> if up then "up" else "down"-  Cancel -> "cancel action, open Main Menu"-  Accept -> "accept target/choice"-  CursorPointerFloor -> "set crosshair to floor under pointer"-  CursorPointerEnemy -> "set crosshair to enemy under pointer"-  TgtPointerFloor -> "enter aiming mode and describe a tile"-  TgtPointerEnemy -> "enter aiming mode and describe an enemy"+instance NFData Trigger -triggerDescription :: [Trigger] -> Text-triggerDescription [] = "trigger a thing"-triggerDescription (t : _) = makePhrase [verb t, object t]+instance Binary Trigger

− Game/LambdaHack/Client/UI/InventoryClient.hs

@@ -1,1031 +0,0 @@-{-# LANGUAGE DataKinds #-}--- | Inventory management and party cycling.--- TODO: document-module Game.LambdaHack.Client.UI.InventoryClient-  ( Suitability(..)-  , getGroupItem, getAnyItems, getStoreItem-  , memberCycle, memberBack, pickLeader-  , cursorPointerFloor, cursorPointerEnemy-  , moveCursorHuman, tgtFloorHuman, tgtEnemyHuman, epsIncrHuman, tgtClearHuman-  , doLook, describeItemC-  ) where--import Control.Applicative-import Control.Exception.Assert.Sugar-import Control.Monad-import Data.Char (intToDigit)-import qualified Data.Char as Char-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.List-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Monoid-import Data.Ord-import Data.Text (Text)-import qualified Data.Text as T-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.ItemSlot-import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.HumanCmd-import Game.LambdaHack.Client.UI.KeyBindings-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Client.UI.MsgClient-import Game.LambdaHack.Client.UI.WidgetClient-import qualified Game.LambdaHack.Common.Ability as Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemDescription-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import Game.LambdaHack.Common.Vector-import qualified Game.LambdaHack.Content.ItemKind as IK--data ItemDialogState = ISuitable | IAll | INoSuitable | INoAll-  deriving (Show, Eq)--ppItemDialogMode :: ItemDialogMode -> (Text, Text)-ppItemDialogMode (MStore cstore) = ppCStore cstore-ppItemDialogMode MOwned = ("in", "our possession")-ppItemDialogMode MStats = ("among", "strenghts")--ppItemDialogModeIn :: ItemDialogMode -> Text-ppItemDialogModeIn c = let (tIn, t) = ppItemDialogMode c in tIn <+> t--ppItemDialogModeFrom :: ItemDialogMode -> Text-ppItemDialogModeFrom c = let (_tIn, t) = ppItemDialogMode c in "from" <+> t--storeFromMode :: ItemDialogMode -> CStore-storeFromMode c = case c of-  MStore cstore -> cstore-  MOwned -> CGround  -- needed to decide display mode in textAllAE-  MStats -> CGround  -- needed to decide display mode in textAllAE--accessModeBag :: ActorId -> State -> ItemDialogMode -> ItemBag-accessModeBag leader s (MStore cstore) = getActorBag leader cstore s-accessModeBag leader s MOwned = let fid = bfid $ getActorBody leader s-                                in sharedAllOwnedFid False fid s-accessModeBag _ _ MStats = EM.empty---- | Let a human player choose any item from a given group.--- Note that this does not guarantee the chosen item belongs to the group,--- as the player can override the choice.--- Used e.g., for applying and projecting.-getGroupItem :: MonadClientUI m-             => m Suitability-                          -- ^ which items to consider suitable-             -> Text      -- ^ specific prompt for only suitable items-             -> Text      -- ^ generic prompt-             -> Bool      -- ^ whether to enable setting cursor with mouse-             -> [CStore]  -- ^ initial legal modes-             -> [CStore]  -- ^ legal modes after Calm taken into account-             -> m (SlideOrCmd ((ItemId, ItemFull), ItemDialogMode))-getGroupItem psuit prompt promptGeneric cursor cLegalRaw cLegalAfterCalm = do-  let dialogState = if cursor then INoSuitable else ISuitable-  soc <- getFull psuit-                 (\_ _ cCur -> prompt <+> ppItemDialogModeFrom cCur)-                 (\_ _ cCur -> promptGeneric <+> ppItemDialogModeFrom cCur)-                 cursor cLegalRaw cLegalAfterCalm True False dialogState-  case soc of-    Left sli -> return $ Left sli-    Right ([(iid, itemFull)], c) -> return $ Right ((iid, itemFull), c)-    Right _ -> assert `failure` soc---- | Let the human player choose any item from a list of items--- and let him specify the number of items.--- Used, e.g., for picking up and inventory manipulation.-getAnyItems :: MonadClientUI m-            => m Suitability-                         -- ^ which items to consider suitable-            -> Text      -- ^ specific prompt for only suitable items-            -> Text      -- ^ generic prompt-            -> [CStore]  -- ^ initial legal modes-            -> [CStore]  -- ^ legal modes after Calm taken into account-            -> Bool      -- ^ whether to ask, when the only item-                         --   in the starting mode is suitable-            -> Bool      -- ^ whether to ask for the number of items-            -> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode))-getAnyItems psuit prompt promptGeneric cLegalRaw cLegalAfterCalm askWhenLone askNumber = do-  soc <- getFull psuit-                 (\_ _ cCur -> prompt <+> ppItemDialogModeFrom cCur)-                 (\_ _ cCur -> promptGeneric <+> ppItemDialogModeFrom cCur)-                 False cLegalRaw cLegalAfterCalm-                 askWhenLone True ISuitable-  case soc of-    Left _ -> return soc-    Right ([(iid, itemFull)], c) -> do-      socK <- pickNumber askNumber $ itemK itemFull-      case socK of-        Left slides -> return $ Left slides-        Right k ->-          return $ Right ([(iid, itemFull{itemK=k})], c)-    Right _ -> return soc---- | Display all items from a store and let the human player choose any--- or switch to any other store.--- Used, e.g., for viewing inventory and item descriptions.-getStoreItem :: MonadClientUI m-             => (Actor -> [ItemFull] -> ItemDialogMode -> Text)-                                 -- ^ how to describe suitable items-             -> ItemDialogMode   -- ^ initial mode-             -> m (SlideOrCmd ((ItemId, ItemFull), ItemDialogMode))-getStoreItem prompt cInitial = do-  let allCs = map MStore [CEqp, CInv, CSha]-              ++ [MOwned]-              ++ map MStore [CGround, COrgan]-              ++ [MStats]-      (pre, rest) = break (== cInitial) allCs-      post = dropWhile (== cInitial) rest-      remCs = post ++ pre-  soc <- getItem (return SuitsEverything)-                 prompt prompt False cInitial remCs-                 True False (cInitial:remCs) ISuitable-  case soc of-    Left sli -> return $ Left sli-    Right ([(iid, itemFull)], c) -> return $ Right ((iid, itemFull), c)-    Right _ -> assert `failure` soc---- | Let the human player choose a single, preferably suitable,--- item from a list of items. Don't display stores empty for all actors.--- Start with a non-empty store.-getFull :: MonadClientUI m-        => m Suitability-                            -- ^ which items to consider suitable-        -> (Actor -> [ItemFull] -> ItemDialogMode -> Text)-                            -- ^ specific prompt for only suitable items-        -> (Actor -> [ItemFull] -> ItemDialogMode -> Text)-                            -- ^ generic prompt-        -> Bool             -- ^ whether to enable setting cursor with mouse-        -> [CStore]         -- ^ initial legal modes-        -> [CStore]         -- ^ legal modes with Calm taken into account-        -> Bool             -- ^ whether to ask, when the only item-                            --   in the starting mode is suitable-        -> Bool             -- ^ whether to permit multiple items as a result-        -> ItemDialogState  -- ^ the dialog state to start in-        -> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode))-getFull psuit prompt promptGeneric cursor cLegalRaw cLegalAfterCalm-        askWhenLone permitMulitple initalState = do-  side <- getsClient sside-  leader <- getLeaderUI-  let aidNotEmpty store aid = do-        bag <- getsState $ getCBag (CActor aid store)-        return $! not $ EM.null bag-      partyNotEmpty store = do-        as <- getsState $ fidActorNotProjAssocs side-        bs <- mapM (aidNotEmpty store . fst) as-        return $! or bs-  mpsuit <- psuit-  let psuitFun = case mpsuit of-        SuitsEverything -> const True-        SuitsNothing _ -> const False-        SuitsSomething f -> f-  -- Move the first store that is non-empty for suitable items for this actor-  -- to the front, if any.-  getCStoreBag <- getsState $ \s cstore -> getCBag (CActor leader cstore) s-  let hasThisActor = not . EM.null . getCStoreBag-  case filter hasThisActor cLegalAfterCalm of-    [] ->-      if isNothing (find hasThisActor cLegalRaw) then do-        let contLegalRaw = map MStore cLegalRaw-            tLegal = map (MU.Text . ppItemDialogModeIn) contLegalRaw-            ppLegal = makePhrase [MU.WWxW "nor" tLegal]-        failWith $ "no items" <+> ppLegal-      else failSer ItemNotCalm-    haveThis@(headThisActor : _) -> do-      itemToF <- itemToFullClient-      let suitsThisActor store =-            let bag = getCStoreBag store-            in any (\(iid, kit) -> psuitFun $ itemToF iid kit) $ EM.assocs bag-          cThisActor cDef = fromMaybe cDef $ find suitsThisActor haveThis-      -- Don't display stores totally empty for all actors.-      cLegal <- filterM partyNotEmpty cLegalRaw-      let breakStores cInit =-            let (pre, rest) = break (== cInit) cLegal-                post = dropWhile (== cInit) rest-            in (MStore cInit, map MStore $ post ++ pre)-      -- The last used store may go before even the first nonempty store.-      lastStore <- getsClient slastStore-      firstStore <--        if lastStore `notElem` cLegalAfterCalm-        then return $! cThisActor headThisActor-        else do-          (itemSlots, organSlots) <- getsClient sslots-          let lSlots = if lastStore == COrgan then organSlots else itemSlots-          lastSlot <- getsClient slastSlot-          case EM.lookup lastSlot lSlots of-            Nothing -> return $! cThisActor headThisActor-            Just lastIid -> case EM.lookup lastIid $ getCStoreBag lastStore of-              Nothing -> return $! cThisActor headThisActor-              Just kit -> do-                let lastItemFull = itemToF lastIid kit-                    lastSuits = psuitFun lastItemFull-                    cLast = cThisActor lastStore-                return $! if lastSuits && cLast /= CGround-                          then lastStore-                          else cLast-      let (modeFirst, modeRest) = breakStores firstStore-      getItem psuit prompt promptGeneric cursor modeFirst modeRest-              askWhenLone permitMulitple (map MStore cLegal) initalState---- | Let the human player choose a single, preferably suitable,--- item from a list of items.-getItem :: MonadClientUI m-        => m Suitability-                            -- ^ which items to consider suitable-        -> (Actor -> [ItemFull] -> ItemDialogMode -> Text)-                            -- ^ specific prompt for only suitable items-        -> (Actor -> [ItemFull] -> ItemDialogMode -> Text)-                            -- ^ generic prompt-        -> Bool             -- ^ whether to enable setting cursor with mouse-        -> ItemDialogMode   -- ^ first mode, legal or not-        -> [ItemDialogMode] -- ^ the (rest of) legal modes-        -> Bool             -- ^ whether to ask, when the only item-                            --   in the starting mode is suitable-        -> Bool             -- ^ whether to permit multiple items as a result-        -> [ItemDialogMode] -- ^ all legal modes-        -> ItemDialogState  -- ^ the dialog state to start in-        -> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode))-getItem psuit prompt promptGeneric cursor cCur cRest askWhenLone permitMulitple-        cLegal initalState = do-  leader <- getLeaderUI-  accessCBag <- getsState $ accessModeBag leader-  let storeAssocs = EM.assocs . accessCBag-      allAssocs = concatMap storeAssocs (cCur : cRest)-  case (cRest, allAssocs) of-    ([], [(iid, k)]) | not askWhenLone -> do-      itemToF <- itemToFullClient-      return $ Right ([(iid, itemToF iid k)], cCur)-    _ ->-      transition psuit prompt promptGeneric cursor permitMulitple cLegal-                 0 cCur cRest initalState--data DefItemKey m = DefItemKey-  { defLabel  :: Text  -- ^ can be undefined if not @defCond@-  , defCond   :: !Bool-  , defAction :: K.KM -> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode))-  }--data Suitability =-    SuitsEverything-  | SuitsNothing Msg-  | SuitsSomething (ItemFull -> Bool)--transition :: forall m. MonadClientUI m-           => m Suitability-           -> (Actor -> [ItemFull] -> ItemDialogMode -> Text)-           -> (Actor -> [ItemFull] -> ItemDialogMode -> Text)-           -> Bool-           -> Bool-           -> [ItemDialogMode]-           -> Int-           -> ItemDialogMode-           -> [ItemDialogMode]-           -> ItemDialogState-           -> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode))-transition psuit prompt promptGeneric cursor permitMulitple cLegal-           numPrefix cCur cRest itemDialogState = do-  let recCall =-        transition psuit prompt promptGeneric cursor permitMulitple cLegal-  (itemSlots, organSlots) <- getsClient sslots-  leader <- getLeaderUI-  body <- getsState $ getActorBody leader-  activeItems <- activeItemsClient leader-  fact <- getsState $ (EM.! bfid body) . sfactionD-  hs <- partyAfterLeader leader-  bagAll <- getsState $ \s -> accessModeBag leader s cCur-  lastSlot <- getsClient slastSlot-  itemToF <- itemToFullClient-  Binding{brevMap} <- askBinding-  mpsuit <- psuit  -- when throwing, this sets eps and checks cursor validity-  (suitsEverything, psuitFun) <- case mpsuit of-    SuitsEverything -> return (True, const True)-    SuitsNothing err -> do-      slides <- promptToSlideshow $ err <+> moreMsg-      void $ getInitConfirms ColorFull [] $ slides <> toSlideshow Nothing [[]]-      return (False, const False)-    -- When throwing, this function takes missile range into accout.-    SuitsSomething f -> return (False, f)-  let getSingleResult :: ItemId -> (ItemId, ItemFull)-      getSingleResult iid = (iid, itemToF iid (bagAll EM.! iid))-      getResult :: ItemId -> ([(ItemId, ItemFull)], ItemDialogMode)-      getResult iid = ([getSingleResult iid], cCur)-      getMultResult :: [ItemId] -> ([(ItemId, ItemFull)], ItemDialogMode)-      getMultResult iids = (map getSingleResult iids, cCur)-      filterP iid kit = psuitFun $ itemToF iid kit-      bagAllSuit = EM.filterWithKey filterP bagAll-      isOrgan = cCur == MStore COrgan-      lSlots = if isOrgan then organSlots else itemSlots-      bagItemSlotsAll = EM.filter (`EM.member` bagAll) lSlots-      -- Predicate for slot matching the current prefix, unless the prefix-      -- is 0, in which case we display all slots, even if they require-      -- the user to start with number keys to get to them.-      -- Could be generalized to 1 if prefix 1x exists, etc., but too rare.-      hasPrefixOpen x _ = slotPrefix x == numPrefix || numPrefix == 0-      bagItemSlotsOpen = EM.filterWithKey hasPrefixOpen bagItemSlotsAll-      hasPrefix x _ = slotPrefix x == numPrefix-      bagItemSlots = EM.filterWithKey hasPrefix bagItemSlotsOpen-      bag = EM.fromList $ map (\iid -> (iid, bagAll EM.! iid))-                              (EM.elems bagItemSlotsOpen)-      suitableItemSlotsAll = EM.filter (`EM.member` bagAllSuit) lSlots-      suitableItemSlotsOpen =-        EM.filterWithKey hasPrefixOpen suitableItemSlotsAll-      suitableItemSlots = EM.filterWithKey hasPrefix suitableItemSlotsOpen-      bagSuit = EM.fromList $ map (\iid -> (iid, bagAllSuit EM.! iid))-                                  (EM.elems suitableItemSlotsOpen)-      (autoDun, autoLvl) = autoDungeonLevel fact-      multipleSlots = if itemDialogState `elem` [IAll, INoAll]-                      then bagItemSlotsAll-                      else suitableItemSlotsAll-      keyDefs :: [(K.KM, DefItemKey m)]-      keyDefs = filter (defCond . snd) $-        [ (K.toKM K.NoModifier $ K.Char '?', DefItemKey-           { defLabel = "?"-           , defCond = not (EM.null bag)-           , defAction = \_ -> recCall numPrefix cCur cRest-                               $ case itemDialogState of-               INoSuitable -> if EM.null bagSuit then IAll else ISuitable-               ISuitable -> if suitsEverything then INoAll else IAll-               IAll -> if EM.null bag then INoSuitable else INoAll-               INoAll -> if suitsEverything then ISuitable else INoSuitable-           })-        , (K.toKM K.NoModifier $ K.Char '/', DefItemKey-           { defLabel = "/"-           , defCond = not $ null cRest-           , defAction = \_ -> do-               let calmE = calmEnough body activeItems-                   mcCur = filter (`elem` cLegal) [cCur]-                   (cCurAfterCalm, cRestAfterCalm) = case cRest ++ mcCur of-                     c1@(MStore CSha) : c2 : rest | not calmE ->-                       (c2, c1 : rest)-                     [MStore CSha] | not calmE -> assert `failure` cRest-                     c1 : rest -> (c1, rest)-                     [] -> assert `failure` cRest-               recCall numPrefix cCurAfterCalm cRestAfterCalm itemDialogState-           })-        , (K.toKM K.NoModifier $ K.Char '*', DefItemKey-           { defLabel = "*"-           , defCond = permitMulitple && not (EM.null multipleSlots)-           , defAction = \_ ->-               let eslots = EM.elems multipleSlots-               in return $ Right $ getMultResult eslots-           })-        , (K.toKM K.NoModifier K.Return, DefItemKey-           { defLabel = if lastSlot `EM.member` labelItemSlotsOpen-                        then let l = makePhrase [slotLabel lastSlot]-                             in "RET(" <> l <> ")"  -- l is on the screen list-                        else "RET"-           , defCond = not (EM.null labelItemSlotsOpen)-           , defAction = \_ -> case EM.lookup lastSlot labelItemSlotsOpen of-               Just iid -> return $ Right $ getResult iid-               Nothing -> case EM.minViewWithKey labelItemSlotsOpen of-                 Nothing -> assert `failure` "labelItemSlotsOpen empty"-                                   `twith` labelItemSlotsOpen-                 Just ((l, _), _) -> do-                   modifyClient $ \cli ->-                     cli { slastSlot = l-                         , slastStore = storeFromMode cCur }-                   recCall numPrefix cCur cRest itemDialogState-           })-        , let km = M.findWithDefault (K.toKM K.NoModifier K.Tab)-                                     MemberCycle brevMap-          in (km, DefItemKey-           { defLabel = K.showKM km-           , defCond = not (cCur == MOwned-                            || autoLvl-                            || not (any (\(_, b) -> blid b == blid body) hs))-           , defAction = \_ -> do-               err <- memberCycle False-               let !_A = assert (err == mempty `blame` err) ()-               (cCurUpd, cRestUpd) <- legalWithUpdatedLeader cCur cRest-               recCall numPrefix cCurUpd cRestUpd itemDialogState-           })-        , let km = M.findWithDefault (K.toKM K.NoModifier K.BackTab)-                                     MemberBack brevMap-          in (km, DefItemKey-           { defLabel = K.showKM km-           , defCond = not (cCur == MOwned || autoDun || null hs)-           , defAction = \_ -> do-               err <- memberBack False-               let !_A = assert (err == mempty `blame` err) ()-               (cCurUpd, cRestUpd) <- legalWithUpdatedLeader cCur cRest-               recCall numPrefix cCurUpd cRestUpd itemDialogState-           })-        , let km = M.findWithDefault (K.toKM K.NoModifier (K.KP '/'))-                                     TgtFloor brevMap-          in cursorCmdDef False km tgtFloorHuman-        , let hackyCmd = Macro "" ["KP_Divide"]  -- no keypad, but arrows enough-              km = M.findWithDefault (K.toKM K.NoModifier K.RightButtonPress)-                                     hackyCmd brevMap-          in cursorCmdDef False km tgtEnemyHuman-        , let km = M.findWithDefault (K.toKM K.NoModifier (K.KP '*'))-                                     TgtEnemy brevMap-          in cursorCmdDef False km tgtEnemyHuman-        , let hackyCmd = Macro "" ["KP_Multiply"]  -- no keypad, but arrows OK-              km = M.findWithDefault (K.toKM K.NoModifier K.RightButtonPress)-                                     hackyCmd brevMap-          in cursorCmdDef False km tgtEnemyHuman-        , let km = M.findWithDefault (K.toKM K.NoModifier K.BackSpace)-                                     TgtClear brevMap-          in cursorCmdDef False km tgtClearHuman-        ]-        ++ numberPrefixes-        ++ [ let plusMinus = K.Char $ if b then '+' else '-'-                 km = M.findWithDefault (K.toKM K.NoModifier plusMinus)-                                        (EpsIncr b) brevMap-             in cursorCmdDef False km (epsIncrHuman b)-           | b <- [True, False]-           ]-        ++ arrows-        ++ [-          let km = M.findWithDefault (K.toKM K.NoModifier K.MiddleButtonPress)-                                     CursorPointerEnemy brevMap-          in cursorCmdDef False km (cursorPointerEnemy False False)-        , let km = M.findWithDefault (K.toKM K.Shift K.MiddleButtonPress)-                                     CursorPointerFloor brevMap-          in cursorCmdDef False km (cursorPointerFloor False False)-        , let km = M.findWithDefault (K.toKM K.NoModifier K.RightButtonPress)-                                     TgtPointerEnemy brevMap-          in cursorCmdDef True km (cursorPointerEnemy True True)-        ]-      prefixCmdDef d =-        (K.toKM K.NoModifier $ K.Char (intToDigit d), DefItemKey-           { defLabel = ""-           , defCond = True-           , defAction = \_ ->-               recCall (10 * numPrefix + d) cCur cRest itemDialogState-           })-      numberPrefixes = map prefixCmdDef [0..9]-      cursorCmdDef verbose km cmd =-        (km, DefItemKey-           { defLabel = "keypad, mouse"-           , defCond = cursor && EM.null bagFiltered-           , defAction = \_ -> do-               look <- cmd-               when verbose $-                 void $ getInitConfirms ColorFull []-                      $ look <> toSlideshow Nothing [[]]-               recCall numPrefix cCur cRest itemDialogState-           })-      arrows =-        let kCmds = K.moveBinding False False-                                  (`moveCursorHuman` 1) (`moveCursorHuman` 10)-        in map (uncurry $ cursorCmdDef False) kCmds-      lettersDef :: DefItemKey m-      lettersDef = DefItemKey-        { defLabel = slotRange $ EM.keys labelItemSlots-        , defCond = True-        , defAction = \K.KM{key} -> case key of-            K.Char l -> case EM.lookup (SlotChar numPrefix l) bagItemSlots of-              Nothing -> assert `failure` "unexpected slot"-                                `twith` (l, bagItemSlots)-              Just iid -> return $ Right $ getResult iid-            _ -> assert `failure` "unexpected key:" `twith` K.showKey key-        }-      (labelItemSlotsOpen, labelItemSlots, bagFiltered, promptChosen) =-        case itemDialogState of-          ISuitable   -> (suitableItemSlotsOpen,-                          suitableItemSlots,-                          bagSuit,-                          prompt body activeItems cCur <> ":")-          IAll        -> (bagItemSlotsOpen,-                          bagItemSlots,-                          bag,-                          promptGeneric body activeItems cCur <> ":")-          INoSuitable -> (suitableItemSlotsOpen,-                          suitableItemSlots,-                          EM.empty,-                          prompt body activeItems cCur <> ":")-          INoAll      -> (bagItemSlotsOpen,-                          bagItemSlots,-                          EM.empty,-                          promptGeneric body activeItems cCur <> ":")-  io <- case cCur of-    MStats -> statsOverlay leader -- TODO: describe each stat when selected-    _ -> itemOverlay (storeFromMode cCur) (blid body) bagFiltered-  runDefItemKey keyDefs lettersDef io bagItemSlots promptChosen--statsOverlay :: MonadClient m => ActorId -> m Overlay-statsOverlay aid = do-  b <- getsState $ getActorBody aid-  activeItems <- activeItemsClient aid-  let block n = n + if braced b then 50 else 0-      prSlot :: (IK.EqpSlot, Int -> Text) -> Text-      prSlot (eqpSlot, f) =-        let fullText t =-              "    "-              <> makePhrase [ MU.Text $ T.justifyLeft 22 ' '-                                      $ IK.slotName eqpSlot-                            , MU.Text t ]-              <> "  "-            valueText = f $ sumSlotNoFilter eqpSlot activeItems-        in fullText valueText-      -- Some values can be negative, for others 0 is equivalent but shorter.-      slotList =  -- TODO:  [IK.EqpSlotAddHurtMelee..IK.EqpSlotAddLight]-        [ (IK.EqpSlotAddHurtMelee, \t -> tshow t <> "%")-        -- TODO: not applicable right now, IK.EqpSlotAddHurtRanged-        , (IK.EqpSlotAddArmorMelee, \t -> "[" <> tshow (block t) <> "%]")-        , (IK.EqpSlotAddArmorRanged, \t -> "{" <> tshow (block t) <> "%}")-        , (IK.EqpSlotAddMaxHP, \t -> tshow $ max 0 t)-        , (IK.EqpSlotAddMaxCalm, \t -> tshow $ max 0 t)-        , (IK.EqpSlotAddSpeed, \t -> tshow (max 0 t) <> "m/10s")-        , (IK.EqpSlotAddSight, \t ->-            tshow (max 0 $ min (fromIntegral $ bcalm b `div` (5 * oneM)) t)-            <> "m")-        , (IK.EqpSlotAddSmell, \t -> tshow (max 0 t) <> "m")-        , (IK.EqpSlotAddLight, \t -> tshow (max 0 t) <> "m")-        ]-      skills = sumSkills activeItems-      -- TODO: are negative total skills meaningful?-      prAbility :: Ability.Ability -> Text-      prAbility ability =-        let fullText t =-              "    "-              <> makePhrase [ MU.Text $ T.justifyLeft 22 ' '-                              $ "ability" <+> tshow ability-                            , MU.Text t ]-              <> "  "-            valueText = tshow $ EM.findWithDefault 0 ability skills-        in fullText valueText-      abilityList = [minBound..maxBound]-  return $! toOverlay $ map prSlot slotList ++ map prAbility abilityList--legalWithUpdatedLeader :: MonadClientUI m-                       => ItemDialogMode-                       -> [ItemDialogMode]-                       -> m (ItemDialogMode, [ItemDialogMode])-legalWithUpdatedLeader cCur cRest = do-  leader <- getLeaderUI-  let newLegal = cCur : cRest  -- not updated in any way yet-  b <- getsState $ getActorBody leader-  activeItems <- activeItemsClient leader-  let calmE = calmEnough b activeItems-      legalAfterCalm = case newLegal of-        c1@(MStore CSha) : c2 : rest | not calmE -> (c2, c1 : rest)-        [MStore CSha] | not calmE -> (MStore CGround, newLegal)-        c1 : rest -> (c1, rest)-        [] -> assert `failure` (cCur, cRest)-  return legalAfterCalm--runDefItemKey :: MonadClientUI m-              => [(K.KM, DefItemKey m)]-              -> DefItemKey m-              -> Overlay-              -> EM.EnumMap SlotChar ItemId-              -> Text-              -> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode))-runDefItemKey keyDefs lettersDef io labelItemSlots prompt = do-  let itemKeys =-        let slotKeys = map (K.Char . slotChar) (EM.keys labelItemSlots)-            defKeys = map fst keyDefs-        in map (K.toKM K.NoModifier) slotKeys ++ defKeys-      choice = let letterRange = defLabel lettersDef-                   keyLabelsRaw = letterRange : map (defLabel . snd) keyDefs-                   keyLabels = filter (not . T.null) keyLabelsRaw-               in "[" <> T.intercalate ", " (nub keyLabels)-  akm <- displayChoiceUI (prompt <+> choice) io itemKeys-  case akm of-    Left slides -> failSlides slides-    Right km ->-      case lookup km{K.pointer=Nothing} keyDefs of-        Just keyDef -> defAction keyDef km-        Nothing -> defAction lettersDef km--pickNumber :: MonadClientUI m => Bool -> Int -> m (SlideOrCmd Int)-pickNumber askNumber kAll = do-  let kDefault = kAll-  if askNumber && kAll > 1 then do-    let tDefault = tshow kDefault-        kbound = min 9 kAll-        kprompt = "Choose number [1-" <> tshow kbound-                  <> ", RET(" <> tDefault <> ")"-        kkeys = map (K.toKM K.NoModifier)-                $ map (K.Char . Char.intToDigit) [1..kbound]-                  ++ [K.Return]-    kkm <- displayChoiceUI kprompt emptyOverlay kkeys-    case kkm of-      Left slides -> failSlides slides-      Right K.KM{key} ->-        case key of-          K.Char l -> return $ Right $ Char.digitToInt l-          K.Return -> return $ Right kDefault-          _ -> assert `failure` "unexpected key:" `twith` kkm-  else return $ Right kAll---- | Switches current member to the next on the level, if any, wrapping.-memberCycle :: MonadClientUI m => Bool -> m Slideshow-memberCycle verbose = do-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  leader <- getLeaderUI-  body <- getsState $ getActorBody leader-  hs <- partyAfterLeader leader-  let autoLvl = snd $ autoDungeonLevel fact-  case filter (\(_, b) -> blid b == blid body) hs of-    _ | autoLvl -> failMsg $ showReqFailure NoChangeLvlLeader-    [] -> failMsg "cannot pick any other member on this level"-    (np, b) : _ -> do-      success <- pickLeader verbose np-      let !_A = assert (success `blame` "same leader" `twith` (leader, np, b)) ()-      return mempty---- | Switches current member to the previous in the whole dungeon, wrapping.-memberBack :: MonadClientUI m => Bool -> m Slideshow-memberBack verbose = do-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  leader <- getLeaderUI-  hs <- partyAfterLeader leader-  let (autoDun, autoLvl) = autoDungeonLevel fact-  case reverse hs of-    _ | autoDun -> failMsg $ showReqFailure NoChangeDunLeader-    _ | autoLvl -> failMsg $ showReqFailure NoChangeLvlLeader-    [] -> failMsg "no other member in the party"-    (np, b) : _ -> do-      success <- pickLeader verbose np-      let !_A = assert (success `blame` "same leader"-                                `twith` (leader, np, b)) ()-      return mempty--partyAfterLeader :: MonadStateRead m => ActorId -> m [(ActorId, Actor)]-partyAfterLeader leader = do-  faction <- getsState $ bfid . getActorBody leader-  allA <- getsState $ EM.assocs . sactorD-  let factionA = filter (\(_, body) ->-        not (bproj body) && bfid body == faction) allA-      hs = sortBy (comparing keySelected) factionA-      i = fromMaybe (-1) $ findIndex ((== leader) . fst) hs-      (lt, gt) = (take i hs, drop (i + 1) hs)-  return $! gt ++ lt---- | Select a faction leader. False, if nothing to do.-pickLeader :: MonadClientUI m => Bool -> ActorId -> m Bool-pickLeader verbose aid = do-  leader <- getLeaderUI-  stgtMode <- getsClient stgtMode-  if leader == aid-    then return False -- already picked-    else do-      pbody <- getsState $ getActorBody aid-      let !_A = assert (not (bproj pbody)-                        `blame` "projectile chosen as the leader"-                        `twith` (aid, pbody)) ()-      -- Even if it's already the leader, give his proper name, not 'you'.-      let subject = partActor pbody-      when verbose $ msgAdd $ makeSentence [subject, "picked as a leader"]-      -- Update client state.-      s <- getState-      modifyClient $ updateLeader aid s-      -- Move the cursor, if active, to the new level.-      case stgtMode of-        Nothing -> return ()-        Just _ ->-          modifyClient $ \cli -> cli {stgtMode = Just $ TgtMode $ blid pbody}-      -- Inform about items, etc.-      lookMsg <- lookAt False "" True (bpos pbody) aid ""-      when verbose $ msgAdd lookMsg-      return True--cursorPointerFloor :: MonadClientUI m => Bool -> Bool -> m Slideshow-cursorPointerFloor verbose addMoreMsg = do-  km <- getsClient slastKM-  lidV <- viewedLevel-  Level{lxsize, lysize} <- getLevel lidV-  case K.pointer km of-    Just(newPos@Point{..}) | px >= 0 && py >= 0-                             && px < lxsize && py < lysize -> do-      let scursor = TPoint lidV newPos-      modifyClient $ \cli -> cli {scursor, stgtMode = Just $ TgtMode lidV}-      if verbose then-        doLook addMoreMsg-      else do-        displayPush ""  -- flash the targeting line and path-        displayDelay  -- for a bit longer-        return mempty-    _ -> do-      stopPlayBack-      return mempty--cursorPointerEnemy :: MonadClientUI m => Bool -> Bool -> m Slideshow-cursorPointerEnemy verbose addMoreMsg = do-  km <- getsClient slastKM-  lidV <- viewedLevel-  Level{lxsize, lysize} <- getLevel lidV-  case K.pointer km of-    Just(newPos@Point{..}) | px >= 0 && py >= 0-                             && px < lxsize && py < lysize -> do-      bsAll <- getsState $ actorAssocs (const True) lidV-      let scursor =-            case find (\(_, m) -> bpos m == newPos) bsAll of-              Just (im, _) -> TEnemy im True-              Nothing -> TPoint lidV newPos-      modifyClient $ \cli -> cli {scursor, stgtMode = Just $ TgtMode lidV}-      if verbose then-        doLook addMoreMsg-      else do-        displayPush ""  -- flash the targeting line and path-        displayDelay  -- for a bit longer-        return mempty-    _ -> do-      stopPlayBack-      return mempty---- | Move the cursor. Assumes targeting mode.-moveCursorHuman :: MonadClientUI m => Vector -> Int -> m Slideshow-moveCursorHuman dir n = do-  leader <- getLeaderUI-  stgtMode <- getsClient stgtMode-  let lidV = maybe (assert `failure` leader) tgtLevelId stgtMode-  Level{lxsize, lysize} <- getLevel lidV-  lpos <- getsState $ bpos . getActorBody leader-  scursor <- getsClient scursor-  cursorPos <- cursorToPos-  let cpos = fromMaybe lpos cursorPos-      shiftB pos = shiftBounded lxsize lysize pos dir-      newPos = iterate shiftB cpos !! n-  if newPos == cpos then failMsg "never mind"-  else do-    let tgt = case scursor of-          TVector{} -> TVector $ newPos `vectorToFrom` lpos-          _ -> TPoint lidV newPos-    modifyClient $ \cli -> cli {scursor = tgt}-    doLook False---- | Cycle targeting mode. Do not change position of the cursor,--- switch among things at that position.-tgtFloorHuman :: MonadClientUI m => m Slideshow-tgtFloorHuman = do-  lidV <- viewedLevel-  leader <- getLeaderUI-  lpos <- getsState $ bpos . getActorBody leader-  cursorPos <- cursorToPos-  scursor <- getsClient scursor-  stgtMode <- getsClient stgtMode-  bsAll <- getsState $ actorAssocs (const True) lidV-  let cursor = fromMaybe lpos cursorPos-      tgt = case scursor of-        _ | isNothing stgtMode ->  -- first key press: keep target-          scursor-        TEnemy a True -> TEnemy a False-        TEnemy{} -> TPoint lidV cursor-        TEnemyPos{} -> TPoint lidV cursor-        TPoint{} -> TVector $ cursor `vectorToFrom` lpos-        TVector{} ->-          -- For projectiles, we pick here the first that would be picked-          -- by '*', so that all other projectiles on the tile come next,-          -- without any intervening actors from other tiles.-          case find (\(_, m) -> Just (bpos m) == cursorPos) bsAll of-            Just (im, _) -> TEnemy im True-            Nothing -> TPoint lidV cursor-  modifyClient $ \cli -> cli {scursor = tgt, stgtMode = Just $ TgtMode lidV}-  doLook False--tgtEnemyHuman :: MonadClientUI m => m Slideshow-tgtEnemyHuman = do-  lidV <- viewedLevel-  leader <- getLeaderUI-  lpos <- getsState $ bpos . getActorBody leader-  cursorPos <- cursorToPos-  scursor <- getsClient scursor-  stgtMode <- getsClient stgtMode-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  bsAll <- getsState $ actorAssocs (const True) lidV-  let ordPos (_, b) = (chessDist lpos $ bpos b, bpos b)-      dbs = sortBy (comparing ordPos) bsAll-      pickUnderCursor =  -- switch to the actor under cursor, if any-        let i = fromMaybe (-1)-                $ findIndex ((== cursorPos) . Just . bpos . snd) dbs-        in splitAt i dbs-      (permitAnyActor, (lt, gt)) = case scursor of-        TEnemy a permit | isJust stgtMode ->  -- pick next enemy-          let i = fromMaybe (-1) $ findIndex ((== a) . fst) dbs-          in (permit, splitAt (i + 1) dbs)-        TEnemy a permit ->  -- first key press, retarget old enemy-          let i = fromMaybe (-1) $ findIndex ((== a) . fst) dbs-          in (permit, splitAt i dbs)-        TEnemyPos _ _ _ permit -> (permit, pickUnderCursor)-        _ -> (False, pickUnderCursor)  -- the sensible default is only-foes-      gtlt = gt ++ lt-      isEnemy b = isAtWar fact (bfid b)-                  && not (bproj b)-                  && bhp b > 0-      lf = filter (isEnemy . snd) gtlt-      tgt | permitAnyActor = case gtlt of-        (a, _) : _ -> TEnemy a True-        [] -> scursor  -- no actors in sight, stick to last target-          | otherwise = case lf of-        (a, _) : _ -> TEnemy a False-        [] -> scursor  -- no seen foes in sight, stick to last target-  -- Register the chosen enemy, to pick another on next invocation.-  modifyClient $ \cli -> cli {scursor = tgt, stgtMode = Just $ TgtMode lidV}-  doLook False---- | Tweak the @eps@ parameter of the targeting digital line.-epsIncrHuman :: MonadClientUI m => Bool -> m Slideshow-epsIncrHuman b = do-  stgtMode <- getsClient stgtMode-  if isJust stgtMode-    then do-      modifyClient $ \cli -> cli {seps = seps cli + if b then 1 else -1}-      return mempty-    else failMsg "never mind"  -- no visual feedback, so no sense--tgtClearHuman :: MonadClientUI m => m Slideshow-tgtClearHuman = do-  leader <- getLeaderUI-  tgt <- getsClient $ getTarget leader-  case tgt of-    Just _ -> do-      modifyClient $ updateTarget leader (const Nothing)-      return mempty-    Nothing -> do-      scursorOld <- getsClient scursor-      b <- getsState $ getActorBody leader-      let scursor = case scursorOld of-            TEnemy _ permit -> TEnemy leader permit-            TEnemyPos _ _ _ permit -> TEnemy leader permit-            TPoint{} -> TPoint (blid b) (bpos b)-            TVector{} -> TVector (Vector 0 0)-      modifyClient $ \cli -> cli {scursor}-      doLook False---- | Perform look around in the current position of the cursor.--- Normally expects targeting mode and so that a leader is picked.-doLook :: MonadClientUI m => Bool -> m Slideshow-doLook addMoreMsg = do-  Kind.COps{cotile=Kind.Ops{ouniqGroup}} <- getsState scops-  let unknownId = ouniqGroup "unknown space"-  stgtMode <- getsClient stgtMode-  case stgtMode of-    Nothing -> return mempty-    Just tgtMode -> do-      leader <- getLeaderUI-      let lidV = tgtLevelId tgtMode-      lvl <- getLevel lidV-      cursorPos <- cursorToPos-      per <- getPerFid lidV-      b <- getsState $ getActorBody leader-      let p = fromMaybe (bpos b) cursorPos-          canSee = ES.member p (totalVisible per)-      inhabitants <- if canSee-                     then getsState $ posToActors p lidV-                     else return []-      seps <- getsClient seps-      mnewEps <- makeLine False b p seps-      itemToF <- itemToFullClient-      let aims = isJust mnewEps-          enemyMsg = case inhabitants of-            [] -> ""-            (_, body) : rest ->-                 -- Even if it's the leader, give his proper name, not 'you'.-                 let subjects = map (partActor . snd) inhabitants-                     subject = MU.WWandW subjects-                     verb = "be here"-                     desc =-                       if not (null rest)  -- many actors, only list names-                       then ""-                       else case itemDisco $ itemToF (btrunk body) (1, []) of-                         Nothing -> ""  -- no details, only show the name-                         Just ItemDisco{itemKind} -> IK.idesc itemKind-                     pdesc = if desc == "" then "" else "(" <> desc <> ")"-                 in makeSentence [MU.SubjectVerbSg subject verb] <+> pdesc-          vis | lvl `at` p == unknownId = "that is"-              | not canSee = "you remember"-              | not aims = "you are aware of"-              | otherwise = "you see"-      -- Show general info about current position.-      lookMsg <- lookAt True vis canSee p leader enemyMsg-{- targeting is kind of a menu (or at least mode), so this is menu inside-   a menu, which is messy, hence disabled until UI overhauled:-      -- Check if there's something lying around at current position.-      is <- getsState $ getCBag $ CFloor lidV p-      if EM.size is <= 2 then-        promptToSlideshow lookMsg-      else do-        msgAdd lookMsg  -- TODO: do not add to history-        floorItemOverlay lidV p--}-      promptToSlideshow $ lookMsg <+> if addMoreMsg then moreMsg else ""----- | Create a list of item names.-_floorItemOverlay :: MonadClientUI m-                  => LevelId -> Point-                  -> m (SlideOrCmd (RequestTimed 'Ability.AbMoveItem))-_floorItemOverlay _lid _p = describeItemC MOwned {-CFloor lid p-}--describeItemC :: MonadClientUI m-              => ItemDialogMode-              -> m (SlideOrCmd (RequestTimed 'Ability.AbMoveItem))-describeItemC c = do-  let subject = partActor-      verbSha body activeItems = if calmEnough body activeItems-                                 then "notice"-                                 else "paw distractedly"-      prompt body activeItems c2 =-        let (tIn, t) = ppItemDialogMode c2-        in case c2 of-        MStore CGround ->  -- TODO: variant for actors without (unwounded) feet-          makePhrase-            [ MU.Capitalize $ MU.SubjectVerbSg (subject body) "notice"-            , MU.Text "at"-            , MU.WownW (MU.Text $ bpronoun body) $ MU.Text "feet" ]-        MStore CSha ->-          makePhrase-            [ MU.Capitalize-              $ MU.SubjectVerbSg (subject body) (verbSha body activeItems)-            , MU.Text tIn-            , MU.Text t ]-        MStore COrgan ->-          makePhrase-            [ MU.Capitalize $ MU.SubjectVerbSg (subject body) "feel"-            , MU.Text tIn-            , MU.WownW (MU.Text $ bpronoun body) $ MU.Text t ]-        MOwned ->-          makePhrase-            [ MU.Capitalize $ MU.SubjectVerbSg (subject body) "recall"-            , MU.Text tIn-            , MU.Text t ]-        MStats ->-          makePhrase-            [ MU.Capitalize $ MU.SubjectVerbSg (subject body) "estimate"-            , MU.WownW (MU.Text $ bpronoun body) $ MU.Text t ]-        _ ->-          makePhrase-            [ MU.Capitalize $ MU.SubjectVerbSg (subject body) "see"-            , MU.Text tIn-            , MU.WownW (MU.Text $ bpronoun body) $ MU.Text t ]-  ggi <- getStoreItem prompt c-  case ggi of-    Right ((iid, itemFull), c2) -> do-      leader <- getLeaderUI-      b <- getsState $ getActorBody leader-      activeItems <- activeItemsClient leader-      let calmE = calmEnough b activeItems-      localTime <- getsState $ getLocalTime (blid b)-      let io = itemDesc (storeFromMode c2) localTime itemFull-      case c2 of-        MStore COrgan -> do-          let symbol = jsymbol (itemBase itemFull)-              blurb | symbol == '+' = "drop temporary conditions"-                    | otherwise = "amputate organs"-          -- TODO: also forbid on the server, except in special cases.-          Left <$> overlayToSlideshow ("Can't"-                                       <+> blurb-                                       <> ", but here's the description.") io-        MStore CSha | not calmE ->-          Left <$> overlayToSlideshow "Not enough calm to take items from the shared stash, but here's the description." io-        MStore fromCStore -> do-          let prompt2 = "Where to move the item?"-              eqpFree = eqpFreeN b-              fstores :: [(K.Key, (CStore, Text))]-              fstores =-                filter ((/= fromCStore) . fst . snd) $-                  [ (K.Char 'p', (CInv, "inventory 'p'ack")) ]-                  ++ [ (K.Char 'e', (CEqp, "'e'quipment")) | eqpFree > 0 ]-                  ++ [ (K.Char 's', (CSha, "shared 's'tash")) | calmE ]-                  ++ [ (K.Char 'g', (CGround, "'g'round")) ]-              choice = "[" <> T.intercalate ", " (map (snd . snd) fstores)-              keys = map (K.toKM K.NoModifier . K.Char) "epsg"-          akm <- displayChoiceUI (prompt2 <+> choice) io keys-          case akm of-            Left slides -> failSlides slides-            Right km -> do-              case lookup (K.key km) fstores of-                Nothing -> return $ Left mempty  -- canceled-                Just (toCStore, _) -> do-                  let k = itemK itemFull-                      kToPick | toCStore == CEqp = min eqpFree k-                              | otherwise = k-                  socK <- pickNumber True kToPick-                  case socK of-                    Left slides -> return $ Left slides-                    Right kChosen -> return $ Right $ ReqMoveItems-                                       [(iid, kChosen, fromCStore, toCStore)]-        MOwned -> do-          -- We can't move items from MOwned, because different copies may come-          -- from different stores and we can't guess player's intentions.-          found <- getsState $ findIid leader (bfid b) iid-          let !_A = assert (not (null found) `blame` ggi) ()-          let ppLoc (_, CSha) = MU.Text $ ppCStoreIn CSha <+> "of the party"-              ppLoc (b2, store) = MU.Text $ ppCStoreIn store <+> "of"-                                                             <+> bname b2-              foundTexts = map ppLoc found-              prompt2 = makeSentence ["The item is", MU.WWandW foundTexts]-          Left <$> overlayToSlideshow prompt2 io-        MStats -> assert `failure` ggi-    Left slides -> return $ Left slides

+ Game/LambdaHack/Client/UI/InventoryM.hs view

@@ -0,0 +1,513 @@+{-# LANGUAGE DataKinds #-}+-- | Inventory management and party cycling.+module Game.LambdaHack.Client.UI.InventoryM+  ( Suitability(..)+  , getFull, getGroupItem, getStoreItem+  , ppItemDialogMode, ppItemDialogModeFrom+#ifdef EXPOSE_INTERNAL+  , storeFromMode+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.Char as Char+import Data.Either+import qualified Data.EnumMap.Strict as EM+import qualified Data.Map.Strict as M+import qualified Data.Text as T+import Data.Tuple (swap)+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Client.CommonM+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Client.UI.ActorUI+import Game.LambdaHack.Client.UI.HandleHelperM+import Game.LambdaHack.Client.UI.HumanCmd+import Game.LambdaHack.Client.UI.ItemSlot+import qualified Game.LambdaHack.Client.UI.Key as K+import Game.LambdaHack.Client.UI.KeyBindings+import Game.LambdaHack.Client.UI.MonadClientUI+import Game.LambdaHack.Client.UI.MsgM+import Game.LambdaHack.Client.UI.Overlay+import Game.LambdaHack.Client.UI.SessionUI+import Game.LambdaHack.Client.UI.Slideshow+import Game.LambdaHack.Client.UI.SlideshowM+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.State++data ItemDialogState = ISuitable | IAll+  deriving (Show, Eq)++ppItemDialogMode :: ItemDialogMode -> (Text, Text)+ppItemDialogMode (MStore cstore) = ppCStore cstore+ppItemDialogMode MOwned = ("in", "our possession")+ppItemDialogMode MStats = ("among", "strenghts")+ppItemDialogMode MLoreItem = ("among", "item lore")+ppItemDialogMode MLoreOrgan = ("among", "organ lore")++ppItemDialogModeIn :: ItemDialogMode -> Text+ppItemDialogModeIn c = let (tIn, t) = ppItemDialogMode c in tIn <+> t++ppItemDialogModeFrom :: ItemDialogMode -> Text+ppItemDialogModeFrom c = let (_tIn, t) = ppItemDialogMode c in "from" <+> t++storeFromMode :: ItemDialogMode -> CStore+storeFromMode c = case c of+  MStore cstore -> cstore+  MOwned -> CGround  -- needed to decide display mode in textAllAE+  MStats -> CGround+  MLoreItem -> CGround+  MLoreOrgan -> COrgan++accessModeBag :: ActorId -> State -> ItemDialogMode -> ItemBag+accessModeBag leader s (MStore cstore) = let b = getActorBody leader s+                                         in getBodyStoreBag b cstore s+accessModeBag leader s MOwned = let fid = bfid $ getActorBody leader s+                                in sharedAllOwnedFid False fid s+accessModeBag _ _ MStats = EM.empty+accessModeBag _ s MLoreItem = EM.map (const (1, [])) $ sitemD s+accessModeBag _ s MLoreOrgan = EM.map (const (1, [])) $ sitemD s++-- | Let a human player choose any item from a given group.+-- Note that this does not guarantee the chosen item belongs to the group,+-- as the player can override the choice.+-- Used e.g., for applying and projecting.+getGroupItem :: MonadClientUI m+             => m Suitability+                          -- ^ which items to consider suitable+             -> Text      -- ^ specific prompt for only suitable items+             -> Text      -- ^ generic prompt+             -> [CStore]  -- ^ initial legal modes+             -> [CStore]  -- ^ legal modes after Calm taken into account+             -> m (Either Text ( (ItemId, ItemFull)+                               , (ItemDialogMode, Either K.KM SlotChar) ))+getGroupItem psuit prompt promptGeneric+             cLegalRaw cLegalAfterCalm = do+  soc <- getFull psuit+                 (\_ _ _ cCur -> prompt <+> ppItemDialogModeFrom cCur)+                 (\_ _ _ cCur -> promptGeneric <+> ppItemDialogModeFrom cCur)+                 cLegalRaw cLegalAfterCalm True False+  case soc of+    Left err -> return $ Left err+    Right ([(iid, itemFull)], cekm) -> return $ Right ((iid, itemFull), cekm)+    Right _ -> assert `failure` soc++-- | Display all items from a store and let the human player choose any+-- or switch to any other store.+-- Used, e.g., for viewing inventory and item descriptions.+getStoreItem :: MonadClientUI m+             => (Actor -> ActorUI -> AspectRecord -> ItemDialogMode -> Text)+                                 -- ^ how to describe suitable items+             -> ItemDialogMode   -- ^ initial mode+             -> m ( Either Text (ItemId, ItemFull)+                  , (ItemDialogMode, Either K.KM SlotChar) )+getStoreItem prompt cInitial = do+  let itemCs = map MStore [CInv, CGround, CEqp, CSha]+      allCs | cInitial `elem` [MLoreItem, MLoreOrgan] = [MLoreItem, MLoreOrgan]+            | otherwise = itemCs ++ [MOwned, MStore COrgan, MStats]+      (pre, rest) = break (== cInitial) allCs+      post = dropWhile (== cInitial) rest+      remCs = post ++ pre+  soc <- getItem (return SuitsEverything)+                 prompt prompt cInitial remCs+                 True False (cInitial : remCs)+  case soc of+    (Left err, cekm) -> return (Left err, cekm)+    (Right [(iid, itemFull)], cekm) -> return (Right (iid, itemFull), cekm)+    (Right{}, _) -> assert `failure` soc++-- | Let the human player choose a single, preferably suitable,+-- item from a list of items. Don't display stores empty for all actors.+-- Start with a non-empty store.+getFull :: MonadClientUI m+        => m Suitability    -- ^ which items to consider suitable+        -> (Actor -> ActorUI -> AspectRecord -> ItemDialogMode -> Text)+                            -- ^ specific prompt for only suitable items+        -> (Actor -> ActorUI -> AspectRecord -> ItemDialogMode -> Text)+                            -- ^ generic prompt+        -> [CStore]         -- ^ initial legal modes+        -> [CStore]         -- ^ legal modes with Calm taken into account+        -> Bool             -- ^ whether to ask, when the only item+                            --   in the starting mode is suitable+        -> Bool             -- ^ whether to permit multiple items as a result+        -> m (Either Text ( [(ItemId, ItemFull)]+                          , (ItemDialogMode, Either K.KM SlotChar) ))+getFull psuit prompt promptGeneric cLegalRaw cLegalAfterCalm+        askWhenLone permitMulitple = do+  side <- getsClient sside+  leader <- getLeaderUI+  let aidNotEmpty store aid = do+        body <- getsState $ getActorBody aid+        bag <- getsState $ getBodyStoreBag body store+        return $! not $ EM.null bag+      partyNotEmpty store = do+        as <- getsState $ fidActorNotProjAssocs side+        bs <- mapM (aidNotEmpty store . fst) as+        return $! or bs+  mpsuit <- psuit+  let psuitFun = case mpsuit of+        SuitsEverything -> const True+        SuitsSomething f -> f+  -- Move the first store that is non-empty for suitable items for this actor+  -- to the front, if any.+  b <- getsState $ getActorBody leader+  getCStoreBag <- getsState $ \s cstore -> getBodyStoreBag b cstore s+  let hasThisActor = not . EM.null . getCStoreBag+  case filter hasThisActor cLegalAfterCalm of+    [] ->+      if isNothing (find hasThisActor cLegalRaw) then do+        let contLegalRaw = map MStore cLegalRaw+            tLegal = map (MU.Text . ppItemDialogModeIn) contLegalRaw+            ppLegal = makePhrase [MU.WWxW "nor" tLegal]+        return $ Left $ "no items" <+> ppLegal+      else return $ Left $ showReqFailure ItemNotCalm+    haveThis@(headThisActor : _) -> do+      itemToF <- itemToFullClient+      let suitsThisActor store =+            let bag = getCStoreBag store+            in any (\(iid, kit) -> psuitFun $ itemToF iid kit) $ EM.assocs bag+          firstStore = fromMaybe headThisActor $ find suitsThisActor haveThis+      -- Don't display stores totally empty for all actors.+      cLegal <- filterM partyNotEmpty cLegalRaw+      let breakStores cInit =+            let (pre, rest) = break (== cInit) cLegal+                post = dropWhile (== cInit) rest+            in (MStore cInit, map MStore $ post ++ pre)+      let (modeFirst, modeRest) = breakStores firstStore+      res <- getItem psuit prompt promptGeneric modeFirst modeRest+                     askWhenLone permitMulitple (map MStore cLegal)+      case res of+        (Left x, _) -> return $ Left x+        (Right x, cekm) -> return $ Right (x, cekm)++-- | Let the human player choose a single, preferably suitable,+-- item from a list of items.+getItem :: MonadClientUI m+        => m Suitability+                            -- ^ which items to consider suitable+        -> (Actor -> ActorUI -> AspectRecord -> ItemDialogMode -> Text)+                            -- ^ specific prompt for only suitable items+        -> (Actor -> ActorUI -> AspectRecord -> ItemDialogMode -> Text)+                            -- ^ generic prompt+        -> ItemDialogMode   -- ^ first mode, legal or not+        -> [ItemDialogMode] -- ^ the (rest of) legal modes+        -> Bool             -- ^ whether to ask, when the only item+                            --   in the starting mode is suitable+        -> Bool             -- ^ whether to permit multiple items as a result+        -> [ItemDialogMode] -- ^ all legal modes+        -> m ( Either Text [(ItemId, ItemFull)]+             , (ItemDialogMode, Either K.KM SlotChar) )+getItem psuit prompt promptGeneric cCur cRest askWhenLone permitMulitple+        cLegal = do+  leader <- getLeaderUI+  accessCBag <- getsState $ accessModeBag leader+  let storeAssocs = EM.assocs . accessCBag+      allAssocs = concatMap storeAssocs (cCur : cRest)+  case (cRest, allAssocs) of+    ([], [(iid, k)]) | not askWhenLone -> do+      itemToF <- itemToFullClient+      ItemSlots itemSlots organSlots <- getsSession sslots+      let isOrgan = cCur `elem` [MStore COrgan, MLoreOrgan]+          lSlots = if isOrgan then organSlots else itemSlots+          slotChar = fromMaybe (assert `failure` (iid, lSlots))+                     $ lookup iid $ map swap $ EM.assocs lSlots+      return (Right [(iid, itemToF iid k)], (cCur, Right slotChar))+    _ ->+      transition psuit prompt promptGeneric permitMulitple cLegal+                 0 cCur cRest ISuitable++data DefItemKey m = DefItemKey+  { defLabel  :: Either Text K.KM  -- ^ can be undefined if not @defCond@+  , defCond   :: !Bool+  , defAction :: Either K.KM SlotChar+              -> m ( Either Text [(ItemId, ItemFull)]+                   , (ItemDialogMode, Either K.KM SlotChar) )+  }++data Suitability =+    SuitsEverything+  | SuitsSomething (ItemFull -> Bool)++transition :: forall m. MonadClientUI m+           => m Suitability+           -> (Actor -> ActorUI -> AspectRecord -> ItemDialogMode -> Text)+           -> (Actor -> ActorUI -> AspectRecord -> ItemDialogMode -> Text)+           -> Bool+           -> [ItemDialogMode]+           -> Int+           -> ItemDialogMode+           -> [ItemDialogMode]+           -> ItemDialogState+           -> m ( Either Text [(ItemId, ItemFull)]+                , (ItemDialogMode, Either K.KM SlotChar) )+transition psuit prompt promptGeneric permitMulitple cLegal+           numPrefix cCur cRest itemDialogState = do+  let recCall = transition psuit prompt promptGeneric permitMulitple cLegal+  ItemSlots itemSlots organSlots <- getsSession sslots+  leader <- getLeaderUI+  body <- getsState $ getActorBody leader+  bodyUI <- getsSession $ getActorUI leader+  actorAspect <- getsClient sactorAspect+  let ar = fromMaybe (assert `failure` leader) (EM.lookup leader actorAspect)+  fact <- getsState $ (EM.! bfid body) . sfactionD+  hs <- partyAfterLeader leader+  bagAll <- getsState $ \s -> accessModeBag leader s cCur+  itemToF <- itemToFullClient+  Binding{brevMap} <- getsSession sbinding+  mpsuit <- psuit  -- when throwing, this sets eps and checks xhair validity+  psuitFun <- case mpsuit of+    SuitsEverything -> return $ const True+    SuitsSomething f -> return f+      -- When throwing, this function takes missile range into accout.+  let getSingleResult :: ItemId -> (ItemId, ItemFull)+      getSingleResult iid = (iid, itemToF iid (bagAll EM.! iid))+      getResult :: Either K.KM SlotChar -> ItemId+                -> ( Either Text [(ItemId, ItemFull)]+                   , (ItemDialogMode, Either K.KM SlotChar) )+      getResult ekm iid = (Right [getSingleResult iid], (cCur, ekm))+      getMultResult :: Either K.KM SlotChar -> [ItemId]+                    -> ( Either Text [(ItemId, ItemFull)]+                       , (ItemDialogMode, Either K.KM SlotChar) )+      getMultResult ekm iids = (Right $ map getSingleResult iids, (cCur, ekm))+      filterP iid kit = psuitFun $ itemToF iid kit+      bagAllSuit = EM.filterWithKey filterP bagAll+      isOrgan = cCur `elem` [MStore COrgan, MLoreOrgan]+      lSlots = if isOrgan then organSlots else itemSlots+      bagItemSlotsAll = EM.filter (`EM.member` bagAll) lSlots+      -- Predicate for slot matching the current prefix, unless the prefix+      -- is 0, in which case we display all slots, even if they require+      -- the user to start with number keys to get to them.+      -- Could be generalized to 1 if prefix 1x exists, etc., but too rare.+      hasPrefixOpen x _ = slotPrefix x == numPrefix || numPrefix == 0+      bagItemSlotsOpen = EM.filterWithKey hasPrefixOpen bagItemSlotsAll+      hasPrefix x _ = slotPrefix x == numPrefix+      bagItemSlots = EM.filterWithKey hasPrefix bagItemSlotsOpen+      bag = EM.fromList $ map (\iid -> (iid, bagAll EM.! iid))+                              (EM.elems bagItemSlotsOpen)+      suitableItemSlotsAll = EM.filter (`EM.member` bagAllSuit) lSlots+      suitableItemSlotsOpen =+        EM.filterWithKey hasPrefixOpen suitableItemSlotsAll+      bagSuit = EM.fromList $ map (\iid -> (iid, bagAllSuit EM.! iid))+                                  (EM.elems suitableItemSlotsOpen)+      (autoDun, _) = autoDungeonLevel fact+      multipleSlots = if itemDialogState == IAll+                      then bagItemSlotsAll+                      else suitableItemSlotsAll+      revCmd dflt cmd = case M.lookup cmd brevMap of+        Nothing -> dflt+        Just (k : _) -> k+        Just [] -> assert `failure` brevMap+      keyDefs :: [(K.KM, DefItemKey m)]+      keyDefs = filter (defCond . snd) $+        [ let km = K.mkChar '?'+          in (km, DefItemKey+           { defLabel = Right km+           , defCond = bag /= bagSuit+           , defAction = \_ -> recCall numPrefix cCur cRest+                               $ case itemDialogState of+                                   ISuitable -> IAll+                                   IAll -> ISuitable+           })+        , let km = K.mkChar '/'+          in (km, changeContainerDef $ Right km)+        , (K.mkKP '/', changeContainerDef $ Left "")+        , let km = K.mkChar '!'+          in (km, useMultipleDef $ Right km)+        , (K.mkKP '*', useMultipleDef $ Left "")+        , let km = revCmd (K.KM K.NoModifier K.Tab) MemberCycle+          in (km, DefItemKey+           { defLabel = Right km+           , defCond = not (cCur == MOwned+                            || not (any (\(_, b, _) -> blid b == blid body) hs))+           , defAction = \_ -> do+               err <- memberCycle False+               let !_A = assert (isNothing err `blame` err) ()+               (cCurUpd, cRestUpd) <- legalWithUpdatedLeader cCur cRest+               recCall numPrefix cCurUpd cRestUpd itemDialogState+           })+        , let km = revCmd (K.KM K.NoModifier K.BackTab) MemberBack+          in (km, DefItemKey+           { defLabel = Right km+           , defCond = not (cCur == MOwned || autoDun || null hs)+           , defAction = \_ -> do+               err <- memberBack False+               let !_A = assert (isNothing err `blame` err) ()+               (cCurUpd, cRestUpd) <- legalWithUpdatedLeader cCur cRest+               recCall numPrefix cCurUpd cRestUpd itemDialogState+           })+        , (K.KM K.NoModifier K.LeftButtonRelease, DefItemKey+           { defLabel = Left ""+           , defCond = not (cCur == MOwned || null hs)+           , defAction = \_ -> do+               void pickLeaderWithPointer  -- error ignored; update anyway+               (cCurUpd, cRestUpd) <- legalWithUpdatedLeader cCur cRest+               recCall numPrefix cCurUpd cRestUpd itemDialogState+           })+        , let km = revCmd (K.KM K.NoModifier $ K.Char '^') SortSlots+          in (km, DefItemKey+           { defLabel = if cCur == MOwned then Right km else Left ""+           , defCond = True+           , defAction = \_ -> do+               sortSlots (bfid body) (Just body)+               recCall numPrefix cCur cRest itemDialogState+           })+        , (K.escKM, DefItemKey+           { defLabel = Right K.escKM+           , defCond = True+           , defAction = \ekm -> return (Left "never mind", (cCur, ekm))+           })+        ]+        ++ numberPrefixes+      changeContainerDef defLabel = DefItemKey+        { defLabel+        , defCond = not $ null cRest+        , defAction = \_ -> do+            let calmE = calmEnough body ar+                mcCur = filter (`elem` cLegal) [cCur]+                (cCurAfterCalm, cRestAfterCalm) = case cRest ++ mcCur of+                  c1@(MStore CSha) : c2 : rest | not calmE ->+                    (c2, c1 : rest)+                  [MStore CSha] | not calmE -> assert `failure` cRest+                  c1 : rest -> (c1, rest)+                  [] -> assert `failure` cRest+            recCall numPrefix cCurAfterCalm cRestAfterCalm itemDialogState+        }+      useMultipleDef defLabel = DefItemKey+        { defLabel+        , defCond = permitMulitple && not (EM.null multipleSlots)+        , defAction = \ekm ->+            let eslots = EM.elems multipleSlots+            in return $ getMultResult ekm eslots+        }+      prefixCmdDef d =+        (K.mkChar $ Char.intToDigit d, DefItemKey+           { defLabel = Left ""+           , defCond = True+           , defAction = \_ ->+               recCall (10 * numPrefix + d) cCur cRest itemDialogState+           })+      numberPrefixes = map prefixCmdDef [0..9]+      lettersDef :: DefItemKey m+      lettersDef = DefItemKey+        { defLabel = Left ""+        , defCond = True+        , defAction = \ekm ->+            let slot = case ekm of+                  Left K.KM{key} -> case key of+                    K.Char l -> SlotChar numPrefix l+                    _ -> assert `failure` "unexpected key:"+                                `twith` K.showKey key+                  Right sl -> sl+            in case EM.lookup slot bagItemSlotsAll of+              Nothing -> assert `failure` "unexpected slot"+                                `twith` (slot, bagItemSlots)+              Just iid -> return $! getResult (Right slot) iid+        }+      (bagFiltered, promptChosen) =+        case itemDialogState of+          ISuitable -> (bagSuit, prompt body bodyUI ar cCur <> ":")+          IAll      -> (bag, promptGeneric body bodyUI ar cCur <> ":")+  case cCur of+    MStats -> do+      io <- statsOverlay leader+      let slotLabels = map fst $ snd io+          slotKeys = mapMaybe (keyOfEKM numPrefix) slotLabels+          statsDef :: DefItemKey m+          statsDef = DefItemKey+            { defLabel = Left ""+            , defCond = True+            , defAction = \ekm ->+                let slot = case ekm of+                      Left K.KM{key} -> case key of+                        K.Char l -> SlotChar numPrefix l+                        _ -> assert `failure` "unexpected key:"+                                    `twith` K.showKey key+                      Right sl -> sl+                in return (Left "", (MStats, Right slot))+            }+      runDefItemKey keyDefs statsDef io slotKeys promptChosen MStats+    _ -> do+      io <- itemOverlay (storeFromMode cCur) (blid body) bagFiltered+      let slotKeys = mapMaybe (keyOfEKM numPrefix . Right)+                     $ EM.keys bagItemSlots+      runDefItemKey keyDefs lettersDef io slotKeys promptChosen cCur++keyOfEKM :: Int -> Either [K.KM] SlotChar -> Maybe K.KM+keyOfEKM _ (Left kms) = assert `failure` kms+keyOfEKM numPrefix (Right SlotChar{..}) | slotPrefix == numPrefix =+  Just $ K.mkChar slotChar+keyOfEKM _ _ = Nothing++legalWithUpdatedLeader :: MonadClientUI m+                       => ItemDialogMode+                       -> [ItemDialogMode]+                       -> m (ItemDialogMode, [ItemDialogMode])+legalWithUpdatedLeader cCur cRest = do+  leader <- getLeaderUI+  let newLegal = cCur : cRest  -- not updated in any way yet+  b <- getsState $ getActorBody leader+  actorAspect <- getsClient sactorAspect+  let ar = fromMaybe (assert `failure` leader) (EM.lookup leader actorAspect)+      calmE = calmEnough b ar+      legalAfterCalm = case newLegal of+        c1@(MStore CSha) : c2 : rest | not calmE -> (c2, c1 : rest)+        [MStore CSha] | not calmE -> (MStore CGround, newLegal)+        c1 : rest -> (c1, rest)+        [] -> assert `failure` (cCur, cRest)+  return legalAfterCalm++-- We don't create keys from slots in @okx@, so they have to be+-- exolicitly given in @slotKeys@.+runDefItemKey :: MonadClientUI m+              => [(K.KM, DefItemKey m)]+              -> DefItemKey m+              -> OKX+              -> [K.KM]+              -> Text+              -> ItemDialogMode+              -> m ( Either Text [(ItemId, ItemFull)]+                   , (ItemDialogMode, Either K.KM SlotChar) )+runDefItemKey keyDefs lettersDef okx slotKeys prompt cCur = do+  let itemKeys = slotKeys ++ map fst keyDefs+      wrapB s = "[" <> s <> "]"+      (keyLabelsRaw, keys) = partitionEithers $ map (defLabel . snd) keyDefs+      keyLabels = filter (not . T.null) keyLabelsRaw+      choice = T.intercalate " " $ map wrapB $ nub keyLabels+  promptAdd $ prompt <+> choice+  lidV <- viewedLevelUI+  Level{lysize} <- getLevel lidV+  ekm <- do+    okxs <- overlayToSlideshow (lysize + 1) keys okx+    !lastSlot <- getsSession slastSlot+    let allOKX = concatMap snd $ slideshow okxs+        pointer =+          case findIndex ((== Right lastSlot) . fst) allOKX of+            Just p | cCur `notElem` [MStats, MLoreItem, MLoreOrgan] -> p+            _ -> case findIndex (isRight . fst) allOKX of+              Just p -> p+              _ -> 0+    (okm, pointer2) <- displayChoiceScreen ColorFull False pointer okxs itemKeys+    -- Remember item pointer, unless not a proper item container. Remember+    -- even if not moved, in case the initial position was a default.+    case drop pointer2 allOKX of+      (Right slastSlot, _) : _+        | cCur `notElem` [MStats, MLoreItem, MLoreOrgan] ->+        modifySession $ \sess -> sess {slastSlot}+      _ -> return ()+    return okm+  case ekm of+    Left km -> case km `lookup` keyDefs of+      Just keyDef -> defAction keyDef ekm+      Nothing -> defAction lettersDef ekm  -- pressed; with current prefix+    Right _slot -> defAction lettersDef ekm  -- selected; with the given prefix

+ Game/LambdaHack/Client/UI/ItemDescription.hs view

@@ -0,0 +1,243 @@+-- | Descripitons of items.+module Game.LambdaHack.Client.UI.ItemDescription+  ( partItem, partItemHigh, partItemWs, partItemWsRanged+  , partItemShortAW, partItemMediumAW, partItemShortWownW+  , viewItem, show64With2+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.EnumMap.Strict as EM+import Data.Int (Int64)+import qualified Data.Text as T+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Client.UI.EffectDescription+import qualified Game.LambdaHack.Common.Color as Color+import qualified Game.LambdaHack.Common.Dice as Dice+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Flavour+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.ItemStrongest+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Time+import qualified Game.LambdaHack.Content.ItemKind as IK++show64With2 :: Int64 -> Text+show64With2 n =+  let k = 100 * n `div` oneM+      l = k `div` 100+      x = k - l * 100+  in tshow l+     <> if | x == 0 -> ""+           | x < 10 -> ".0" <> tshow x+           | otherwise -> "." <> tshow x++-- | The part of speech describing the item parameterized by the number+-- of effects/aspects to show..+partItemN :: FactionId -> FactionDict+          -> Bool -> Int -> Int -> CStore -> Time -> ItemFull+          -> (Bool, Bool, MU.Part, MU.Part)+partItemN side factionD ranged fullInfo n cstore localTime itemFull =+  let genericName = jname $ itemBase itemFull+  in case itemDisco itemFull of+    Nothing ->+      let flav = flavourToName $ jflavour $ itemBase itemFull+      in (False, False, MU.Text $ flav <+> genericName, "")+    Just iDisco ->+      let timeout = aTimeout $ aspectRecordFull itemFull+          timeoutTurns = timeDeltaScale (Delta timeTurn) timeout+          temporary = not (null $ itemTimer itemFull) && timeout == 0+          charging startT = timeShift startT timeoutTurns > localTime+          it1 = filter charging (itemTimer itemFull)+          lenCh = length it1+          timer | lenCh == 0 || temporary = ""+                | itemK itemFull == 1 && lenCh == 1 = "(charging)"+                | itemK itemFull == lenCh = "(all charging)"+                | otherwise = "(" <> tshow lenCh <+> "charging)"+          skipRecharging = fullInfo <= 4 && lenCh >= itemK itemFull+          (effTsRaw, rangedDamage) =+            textAllAE fullInfo skipRecharging cstore itemFull+          effTs = filter (not . T.null) effTsRaw+                  ++ if ranged then rangedDamage else []+          lsource = case jfid $ itemBase itemFull of+            Nothing -> []+            Just fid -> ["by" <+> if fid == side+                                  then "us"+                                  else gname (factionD EM.! fid)]+          ts = lsource+               ++ take n effTs+               ++ ["(...)" | length effTs > n]+               ++ [timer]+          unique = IK.Unique `elem` IK.ieffects (itemKind iDisco)+          name | temporary = "temporarily" <+> genericName+               | otherwise = genericName+          capName = if unique+                    then MU.Capitalize $ MU.Text name+                    else MU.Text name+      in ( not (null lsource) || temporary+         , unique, capName, MU.Phrase $ map MU.Text ts )++textAllAE :: Int -> Bool -> CStore -> ItemFull -> ([Text], [Text])+textAllAE fullInfo skipRecharging cstore ItemFull{itemBase, itemDisco} =+  let features | fullInfo >= 9 = map featureToSuff $ sort $ jfeature itemBase+               | otherwise = []+  in case itemDisco of+    Nothing -> (features, [])+    Just ItemDisco{itemKind, itemAspect} ->+      let timeoutAspect :: IK.Aspect -> Bool+          timeoutAspect IK.Timeout{} = True+          timeoutAspect _ = False+          hurtMeleeAspect :: IK.Aspect -> Bool+          hurtMeleeAspect IK.AddHurtMelee{} = True+          hurtMeleeAspect _ = False+          elabel :: IK.Effect -> Bool+          elabel IK.ELabel{} = True+          elabel _ = False+          notDetail :: IK.Effect -> Bool+          notDetail IK.Explode{} = fullInfo >= 6+          notDetail _ = True+          active = cstore `elem` [CEqp, COrgan]+                   || cstore == CGround && goesIntoEqp itemBase+          splitAE :: [IK.Aspect] -> [IK.Effect] -> [Text]+          splitAE aspects effects =+            let ppA = kindAspectToSuffix+                ppE = effectToSuffix+                reduce_a = maybe "?" tshow . Dice.reduceDice+                periodic = IK.Periodic `elem` IK.ieffects itemKind+                mtimeout = find timeoutAspect aspects+                restAs = sort aspects+                -- Effects are not sorted, because they fire in the order+                -- specified.+                restEs = filter notDetail effects+                aes = if active+                      then map ppA restAs ++ map ppE restEs+                      else map ppE restEs ++ map ppA restAs+                rechargingTs = T.intercalate (T.singleton ' ')+                               $ filter (not . T.null)+                               $ map ppE $ stripRecharging restEs+                onSmashTs = T.intercalate (T.singleton ' ')+                            $ filter (not . T.null)+                            $ map ppE $ stripOnSmash restEs+                durable = IK.Durable `elem` jfeature itemBase+                fragile = IK.Fragile `elem` jfeature itemBase+                periodicOrTimeout =+                  if | skipRecharging || T.null rechargingTs -> ""+                     | periodic -> case mtimeout of+                         Nothing | durable && not fragile ->+                           "(each turn:" <+> rechargingTs <> ")"+                         Nothing ->+                           "(each turn until gone:" <+> rechargingTs <> ")"+                         Just (IK.Timeout t) ->+                           "(every" <+> reduce_a t <> ":"+                           <+> rechargingTs <> ")"+                         _ -> assert `failure` mtimeout+                     | otherwise -> case mtimeout of+                         Nothing -> ""+                         Just (IK.Timeout t) ->+                           "(timeout" <+> reduce_a t <> ":"+                           <+> rechargingTs <> ")"+                         _ -> assert `failure` mtimeout+                onSmash = if T.null onSmashTs then ""+                          else "(on smash:" <+> onSmashTs <> ")"+                elab = case find elabel effects of+                  Just (IK.ELabel t) -> [t]+                  _ -> []+                damage = case find hurtMeleeAspect aspects of+                  Just (IK.AddHurtMelee hurtMelee) ->+                    (if jdamage itemBase <= 0+                     then "0d0"+                     else tshow (jdamage itemBase))+                    <> affixDice hurtMelee <> "%"+                  _ -> if jdamage itemBase <= 0+                       then ""+                       else tshow (jdamage itemBase)+            in elab ++ if fullInfo >= 6 || fullInfo >= 2 && null elab+                       then [periodicOrTimeout] ++ [damage] ++ aes+                            ++ [onSmash | fullInfo >= 7]+                       else [damage]+          aets = case itemAspect of+            Just aspectRecord ->+              splitAE (aspectRecordToList aspectRecord) (IK.ieffects itemKind)+            Nothing ->+              splitAE (IK.iaspects itemKind) (IK.ieffects itemKind)+          IK.ThrowMod{IK.throwVelocity} = strengthToThrow itemBase+          speed = speedFromWeight (jweight itemBase) throwVelocity+          meanDmg = Dice.meanDice (jdamage itemBase)+          minDeltaHP = xM meanDmg `divUp` 100+          aHurtMeleeOfItem = case itemAspect of+            Just aspectRecord -> aHurtMelee aspectRecord+            Nothing -> case find hurtMeleeAspect (IK.iaspects itemKind) of+              Just (IK.AddHurtMelee d) -> Dice.meanDice d+              _ -> 0+          pmult = 100 + min 99 (max (-99) aHurtMeleeOfItem)+          prawDeltaHP = fromIntegral pmult * minDeltaHP+          pdeltaHP = modifyDamageBySpeed prawDeltaHP speed+          rangedDamage = if pdeltaHP == 0+                         then []+                         else ["{avg" <+> show64With2 pdeltaHP <+> "ranged}"]+          -- Note that avg melee damage would be too complex to display here,+          -- because in case of @MOwned@ the owner is different than leader,+          -- so the value would be different than when viewing the item.+      in (aets ++ features, rangedDamage)++-- | The part of speech describing the item.+partItem :: FactionId -> FactionDict+         -> CStore -> Time -> ItemFull -> (Bool, Bool, MU.Part, MU.Part)+partItem side factionD = partItemN side factionD False 5 4++partItemHigh :: FactionId -> FactionDict+             -> CStore -> Time -> ItemFull -> (Bool, Bool, MU.Part, MU.Part)+partItemHigh side factionD = partItemN side factionD False 10 100++-- The @count@ can be different than @itemK@ in @ItemFull@, e.g., when picking+-- a subset of items to drop.+partItemWsR :: FactionId -> FactionDict+            -> Bool -> Int -> CStore -> Time -> ItemFull -> MU.Part+partItemWsR side factionD ranged count cstore localTime itemFull =+  let (temporary, unique, name, stats) =+        partItemN side factionD ranged 5 4 cstore localTime itemFull+  in if | temporary && count == 1 -> MU.Phrase [name, stats]+        | temporary -> MU.Phrase [MU.Text $ tshow count <> "-fold", name, stats]+        | unique && count == 1 -> MU.Phrase ["the", name, stats]+        | otherwise -> MU.Phrase [MU.CarWs count name, stats]++partItemWs :: FactionId -> FactionDict+           -> Int -> CStore -> Time -> ItemFull -> MU.Part+partItemWs side factionD = partItemWsR side factionD False++partItemWsRanged :: FactionId -> FactionDict+                 -> Int -> CStore -> Time -> ItemFull -> MU.Part+partItemWsRanged side factionD = partItemWsR side factionD True++partItemShortAW :: FactionId -> FactionDict+                -> CStore -> Time -> ItemFull -> MU.Part+partItemShortAW side factionD c localTime itemFull =+  let (_, unique, name, _) =+        partItemN side factionD False 4 4 c localTime itemFull+  in if unique+     then MU.Phrase ["the", name]+     else MU.AW name++partItemMediumAW :: FactionId -> FactionDict+                 -> CStore -> Time -> ItemFull -> MU.Part+partItemMediumAW side factionD c localTime itemFull =+  let (_, unique, name, stats) =+        partItemN side factionD False 5 100 c localTime itemFull+  in if unique+     then MU.Phrase ["the", name, stats]+     else MU.AW $ MU.Phrase [name, stats]++partItemShortWownW :: FactionId -> FactionDict+              -> MU.Part -> CStore -> Time -> ItemFull -> MU.Part+partItemShortWownW side factionD partA c localTime itemFull =+  let (_, _, name, _) =+        partItemN side factionD False 4 4 c localTime itemFull+  in MU.WownW partA name++viewItem :: Item -> Color.AttrCharW32+{-# INLINE viewItem #-}+viewItem item =+  Color.attrChar2ToW32 (flavourToColor $ jflavour item) (jsymbol item)

+ Game/LambdaHack/Client/UI/ItemSlot.hs view

@@ -0,0 +1,93 @@+-- | Item slots for UI and AI item collections.+module Game.LambdaHack.Client.UI.ItemSlot+  ( ItemSlots(..), SlotChar(..)+  , allSlots, allZeroSlots, intSlots, slotLabel, assignSlot+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Data.Binary+import Data.Bits (unsafeShiftL, unsafeShiftR)+import Data.Char+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import Data.Ord (comparing)+import qualified Data.Text as T++import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.State++data SlotChar = SlotChar {slotPrefix :: !Int, slotChar :: !Char}+  deriving (Show, Eq)++instance Ord SlotChar where+  compare = comparing fromEnum++instance Binary SlotChar where+  put = put . fromEnum+  get = fmap toEnum get++instance Enum SlotChar where+  fromEnum (SlotChar n c) =+    unsafeShiftL n 8 + ord c + (if isUpper c then 100 else 0)+  toEnum e =+    let n = unsafeShiftR e 8+        c0 = e - unsafeShiftL n 8+        c100 = c0 - if c0 > 150 then 100 else 0+    in SlotChar n (chr c100)++data ItemSlots = ItemSlots !(EM.EnumMap SlotChar ItemId)+                           !(EM.EnumMap SlotChar ItemId)+  deriving Show++instance Binary ItemSlots where+  put (ItemSlots is os) = put is >> put os+  get = ItemSlots <$> get <*> get++allSlots :: Int -> [SlotChar]+allSlots n = map (SlotChar n) $ ['a'..'z'] ++ ['A'..'Z']++allZeroSlots :: [SlotChar]+allZeroSlots = allSlots 0++intSlots :: [SlotChar]+intSlots = map (flip SlotChar 'a') [0..]++-- | Assigns a slot to an item, for inclusion in the inventory+-- of a hero. Tries to to use the requested slot, if any.+assignSlot :: CStore -> Item -> FactionId -> Maybe Actor -> ItemSlots+           -> SlotChar -> State+           -> SlotChar+assignSlot store item fid mbody (ItemSlots itemSlots organSlots) lastSlot s =+  assert (maybe True (\b -> bfid b == fid) mbody)+  $ if jsymbol item == '$'+    then SlotChar 0 '$'+    else head $ fresh ++ free+ where+  offset = maybe 0 (+1) (elemIndex lastSlot allZeroSlots)+  onlyOrgans = store == COrgan+  len0 = length allZeroSlots+  candidatesZero = take len0 $ drop offset $ cycle allZeroSlots+  candidates = candidatesZero ++ concat [allSlots n | n <- [1..]]+  onPerson = sharedAllOwnedFid onlyOrgans fid s+  onGround = maybe EM.empty  -- consider floor only under the acting actor+                   (\b -> getFloorBag (blid b) (bpos b) s)+                   mbody+  inBags = ES.unions $ map EM.keysSet $ onPerson : [ onGround | not onlyOrgans]+  lSlots = if onlyOrgans  then organSlots else itemSlots+  f l = maybe True (`ES.notMember` inBags) $ EM.lookup l lSlots+  free = filter f candidates+  g l = l `EM.notMember` lSlots+  fresh = filter g $ take ((slotPrefix lastSlot + 1) * len0) candidates++slotLabel :: SlotChar -> Text+slotLabel x =+  T.snoc (if slotPrefix x == 0 then T.empty else tshow $ slotPrefix x)+         (slotChar x)+  <> ")"

+ Game/LambdaHack/Client/UI/Key.hs view

@@ -0,0 +1,507 @@+{-# LANGUAGE DeriveGeneric #-}+-- | Frontend-independent keyboard input operations.+module Game.LambdaHack.Client.UI.Key+  ( Key(..), showKey, handleDir, dirAllKey+  , moveBinding, mkKM, mkChar, mkKP, keyTranslate, keyTranslateWeb+  , Modifier(..), KM(..), showKM+  , escKM, spaceKM, safeSpaceKM, returnKM+  , pgupKM, pgdnKM, wheelNorthKM, wheelSouthKM+  , upKM, downKM, leftKM, rightKM+  , homeKM, endKM, backspaceKM+  , leftButtonReleaseKM, rightButtonReleaseKM+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude hiding (Alt, Left, Right)++import Control.DeepSeq+import Data.Binary+import qualified Data.Char as Char+import GHC.Generics (Generic)++import Game.LambdaHack.Common.Vector++-- | Frontend-independent datatype to represent keys.+data Key =+    Esc+  | Return+  | Space+  | Tab+  | BackTab+  | BackSpace+  | PgUp+  | PgDn+  | Left+  | Right+  | Up+  | Down+  | End+  | Begin+  | Insert+  | Delete+  | Home+  | KP !Char      -- ^ a keypad key for a character (digits and operators)+  | Char !Char    -- ^ a single printable character+  | Fun !Int      -- ^ function key+  | LeftButtonPress    -- ^ left mouse button pressed+  | MiddleButtonPress  -- ^ middle mouse button pressed+  | RightButtonPress   -- ^ right mouse button pressed+  | LeftButtonRelease    -- ^ left mouse button released+  | MiddleButtonRelease  -- ^ middle mouse button released+  | RightButtonRelease   -- ^ right mouse button released+  | WheelNorth  -- ^ mouse wheel rotated north+  | WheelSouth  -- ^ mouse wheel rotated south+  | Unknown !String -- ^ an unknown key, registered to warn the user+  | DeadKey+  deriving (Ord, Eq, Generic)++instance Binary Key++instance NFData Key++-- | Our own encoding of modifiers.+data Modifier =+    NoModifier+  | Shift+  | Control+  | Alt+  deriving (Show, Ord, Eq, Generic)++instance Binary Modifier++instance NFData Modifier++data KM = KM { modifier :: !Modifier+             , key      :: !Key }+  deriving (Ord, Eq, Generic)++instance Binary KM++instance NFData KM++instance Show KM where+  show = showKM++-- Common and terse names for keys.+showKey :: Key -> String+showKey Esc      = "ESC"+showKey Return   = "RET"+showKey Space    = "SPACE"+showKey Tab      = "TAB"+showKey BackTab  = "S-TAB"+showKey BackSpace = "BACKSPACE"+showKey Up       = "UP"+showKey Down     = "DOWN"+showKey Left     = "LEFT"+showKey Right    = "RIGHT"+showKey Home     = "HOME"+showKey End      = "END"+showKey PgUp     = "PGUP"+showKey PgDn     = "PGDN"+showKey Begin    = "BEGIN"+showKey Insert   = "INS"+showKey Delete   = "DEL"+showKey (KP c)   = "KP_" ++ [c]+showKey (Char c) = [c]+showKey (Fun n) = "F" ++ show n+showKey LeftButtonPress = "LMB-PRESS"+showKey MiddleButtonPress = "MMB-PRESS"+showKey RightButtonPress = "RMB-PRESS"+showKey LeftButtonRelease = "LMB"+showKey MiddleButtonRelease = "MMB"+showKey RightButtonRelease = "RMB"+showKey WheelNorth = "WHEEL-UP"+showKey WheelSouth = "WHEEL-DN"+showKey (Unknown s) = "'" ++ s ++ "'"+showKey DeadKey      = "DEADKEY"++-- | Show a key with a modifier, if any.+showKM :: KM -> String+showKM KM{modifier=Shift, key} = "S-" ++ showKey key+showKM KM{modifier=Control, key} = "C-" ++ showKey key+showKM KM{modifier=Alt, key} = "A-" ++ showKey key+showKM KM{modifier=NoModifier, key} = showKey key++escKM :: KM+escKM = KM NoModifier Esc++spaceKM :: KM+spaceKM = KM NoModifier Space++safeSpaceKM :: KM+safeSpaceKM = KM NoModifier $ Unknown "SAFE_SPACE"++returnKM :: KM+returnKM = KM NoModifier Return++pgupKM :: KM+pgupKM = KM NoModifier PgUp++pgdnKM :: KM+pgdnKM = KM NoModifier PgDn++wheelNorthKM :: KM+wheelNorthKM = KM NoModifier WheelNorth++wheelSouthKM :: KM+wheelSouthKM = KM NoModifier WheelSouth++upKM :: KM+upKM = KM NoModifier Up++downKM :: KM+downKM = KM NoModifier Down++leftKM :: KM+leftKM = KM NoModifier Left++rightKM :: KM+rightKM = KM NoModifier Right++homeKM :: KM+homeKM = KM NoModifier Home++endKM :: KM+endKM = KM NoModifier End++backspaceKM :: KM+backspaceKM = KM NoModifier BackSpace++leftButtonReleaseKM :: KM+leftButtonReleaseKM = KM NoModifier LeftButtonRelease++rightButtonReleaseKM :: KM+rightButtonReleaseKM = KM NoModifier RightButtonRelease++dirKeypadKey :: [Key]+dirKeypadKey = [Home, Up, PgUp, Right, PgDn, Down, End, Left]++dirKeypadShiftChar :: [Char]+dirKeypadShiftChar = ['7', '8', '9', '6', '3', '2', '1', '4']++dirKeypadShiftKey :: [Key]+dirKeypadShiftKey = map KP dirKeypadShiftChar++dirLaptopKey :: [Key]+dirLaptopKey = map Char ['7', '8', '9', 'o', 'l', 'k', 'j', 'u']++dirLaptopShiftKey :: [Key]+dirLaptopShiftKey = map Char ['&', '*', '(', 'O', 'L', 'K', 'J', 'U']++dirViChar :: [Char]+dirViChar = ['y', 'k', 'u', 'l', 'n', 'j', 'b', 'h']++dirViKey :: [Key]+dirViKey = map Char dirViChar++dirViShiftKey :: [Key]+dirViShiftKey = map (Char . Char.toUpper) dirViChar++dirMoveNoModifier :: Bool -> Bool -> [Key]+dirMoveNoModifier configVi configLaptop =+  dirKeypadKey ++ if | configVi -> dirViKey+                     | configLaptop -> dirLaptopKey+                     | otherwise -> []++dirRunNoModifier :: Bool -> Bool -> [Key]+dirRunNoModifier configVi configLaptop =+  dirKeypadShiftKey ++ if | configVi -> dirViShiftKey+                          | configLaptop -> dirLaptopShiftKey+                          | otherwise -> []++dirRunControl :: [Key]+dirRunControl = dirKeypadKey+                ++ dirKeypadShiftKey+                ++ map Char dirKeypadShiftChar++dirRunShift :: [Key]+dirRunShift = dirRunControl++dirAllKey :: Bool -> Bool -> [Key]+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 -> Maybe Vector+handleDir configVi configLaptop KM{modifier=NoModifier, key} =+  let assocs = zip (dirAllKey configVi configLaptop) $ cycle moves+  in lookup key assocs+handleDir _ _ _ = Nothing++-- | Binding of both sets of movement keys.+moveBinding :: Bool -> Bool -> (Vector -> a) -> (Vector -> a)+            -> [(KM, a)]+moveBinding configVi configLaptop move run =+  let assign f (km, dir) = (km, f dir)+      mapMove modifier keys =+        map (assign move) (zip (map (KM modifier) keys) $ cycle moves)+      mapRun modifier keys =+        map (assign run) (zip (map (KM modifier) keys) $ cycle moves)+  in mapMove NoModifier (dirMoveNoModifier configVi configLaptop)+     ++ mapRun NoModifier (dirRunNoModifier configVi configLaptop)+     ++ mapRun Control dirRunControl+     ++ mapRun Shift dirRunShift++mkKM :: String -> KM+mkKM s = let mkKey sk =+               case keyTranslate sk of+                 Unknown _ -> assert `failure` "unknown key" `twith` s+                 key -> key+         in case s of+           'S':'-':rest -> KM Shift (mkKey rest)+           'C':'-':rest -> KM Control (mkKey rest)+           'A':'-':rest -> KM Alt (mkKey rest)+           _ -> KM NoModifier (mkKey s)++mkChar :: Char -> KM+mkChar c = KM NoModifier $ Char c++mkKP :: Char -> KM+mkKP c = KM NoModifier $ KP c++-- | Translate key from a GTK string description to our internal key type.+-- To be used, in particular, for the command bindings and macros+-- in the config file.+--+-- See https://github.com/twobob/gtk-/blob/master/gdk/keyname-table.h+keyTranslate :: String -> Key+keyTranslate "less"          = Char '<'+keyTranslate "greater"       = Char '>'+keyTranslate "period"        = Char '.'+keyTranslate "colon"         = Char ':'+keyTranslate "semicolon"     = Char ';'+keyTranslate "comma"         = Char ','+keyTranslate "question"      = Char '?'+keyTranslate "numbersign"    = Char '#'+keyTranslate "dollar"        = Char '$'+keyTranslate "parenleft"     = Char '('+keyTranslate "parenright"    = Char ')'+keyTranslate "asterisk"      = Char '*'  -- for latop movement keys+keyTranslate "KP_Multiply"   = KP '*'    -- for keypad aiming+keyTranslate "slash"         = Char '/'+keyTranslate "KP_Divide"     = KP '/'+keyTranslate "bar"           = Char '|'+keyTranslate "backslash"     = Char '\\'+keyTranslate "asciicircum"   = Char '^'+keyTranslate "underscore"    = Char '_'+keyTranslate "minus"         = Char '-'+keyTranslate "KP_Subtract"   = Char '-'  -- KP and normal are merged here+keyTranslate "plus"          = Char '+'+keyTranslate "KP_Add"        = Char '+'  -- KP and normal are merged here+keyTranslate "equal"         = Char '='+keyTranslate "bracketleft"   = Char '['+keyTranslate "bracketright"  = Char ']'+keyTranslate "braceleft"     = Char '{'+keyTranslate "braceright"    = Char '}'+keyTranslate "caret"         = Char '^'+keyTranslate "ampersand"     = Char '&'+keyTranslate "at"            = Char '@'+keyTranslate "asciitilde"    = Char '~'+keyTranslate "grave"         = Char '`'+keyTranslate "exclam"        = Char '!'+keyTranslate "apostrophe"    = Char '\''+keyTranslate "Escape"        = Esc+keyTranslate "ESC"           = Esc+keyTranslate "Return"        = Return+keyTranslate "RET"           = Return+keyTranslate "space"         = Space+keyTranslate "SPACE"         = Space+keyTranslate "Tab"           = Tab+keyTranslate "TAB"           = Tab+keyTranslate "BackTab"       = BackTab+keyTranslate "ISO_Left_Tab"  = BackTab+keyTranslate "BackSpace"     = BackSpace+keyTranslate "BACKSPACE"     = BackSpace+keyTranslate "Up"            = Up+keyTranslate "UP"            = Up+keyTranslate "KP_Up"         = Up+keyTranslate "Down"          = Down+keyTranslate "DOWN"          = Down+keyTranslate "KP_Down"       = Down+keyTranslate "Left"          = Left+keyTranslate "LEFT"          = Left+keyTranslate "KP_Left"       = Left+keyTranslate "Right"         = Right+keyTranslate "RIGHT"         = Right+keyTranslate "KP_Right"      = Right+keyTranslate "Home"          = Home+keyTranslate "HOME"          = Home+keyTranslate "KP_Home"       = Home+keyTranslate "End"           = End+keyTranslate "END"           = End+keyTranslate "KP_End"        = End+keyTranslate "Page_Up"       = PgUp+keyTranslate "PGUP"          = PgUp+keyTranslate "KP_Page_Up"    = PgUp+keyTranslate "Prior"         = PgUp+keyTranslate "KP_Prior"      = PgUp+keyTranslate "Page_Down"     = PgDn+keyTranslate "PGDN"          = PgDn+keyTranslate "KP_Page_Down"  = PgDn+keyTranslate "Next"          = PgDn+keyTranslate "KP_Next"       = PgDn+keyTranslate "Begin"         = Begin+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 "INS"           = Insert+keyTranslate "KP_Insert"     = Insert+keyTranslate "Delete"        = Delete+keyTranslate "DEL"           = Delete+keyTranslate "KP_Delete"     = Delete+keyTranslate "KP_Enter"      = Return+keyTranslate "F1"            = Fun 1+keyTranslate "F2"            = Fun 2+keyTranslate "F3"            = Fun 3+keyTranslate "F4"            = Fun 4+keyTranslate "F5"            = Fun 5+keyTranslate "F6"            = Fun 6+keyTranslate "F7"            = Fun 7+keyTranslate "F8"            = Fun 8+keyTranslate "F9"            = Fun 9+keyTranslate "F10"           = Fun 10+keyTranslate "F11"           = Fun 11+keyTranslate "F12"           = Fun 12+keyTranslate "LeftButtonPress" = LeftButtonPress+keyTranslate "LMB-PRESS" = LeftButtonPress+keyTranslate "MiddleButtonPress" = MiddleButtonPress+keyTranslate "MMB-PRESS" = MiddleButtonPress+keyTranslate "RightButtonPress" = RightButtonPress+keyTranslate "RMB-PRESS" = RightButtonPress+keyTranslate "LeftButtonRelease" = LeftButtonRelease+keyTranslate "LMB" = LeftButtonRelease+keyTranslate "MiddleButtonRelease" = MiddleButtonRelease+keyTranslate "MMB" = MiddleButtonRelease+keyTranslate "RightButtonRelease" = RightButtonRelease+keyTranslate "RMB" = RightButtonRelease+keyTranslate "WheelNorth"    = WheelNorth+keyTranslate "WHEEL-UP"      = WheelNorth+keyTranslate "WheelSouth"    = WheelSouth+keyTranslate "WHEEL-DN"      = WheelSouth+-- dead keys+keyTranslate "Shift_L"          = DeadKey+keyTranslate "Shift_R"          = DeadKey+keyTranslate "Control_L"        = DeadKey+keyTranslate "Control_R"        = DeadKey+keyTranslate "Super_L"          = DeadKey+keyTranslate "Super_R"          = DeadKey+keyTranslate "Menu"             = DeadKey+keyTranslate "Alt_L"            = DeadKey+keyTranslate "Alt_R"            = DeadKey+keyTranslate "Meta_L"           = DeadKey+keyTranslate "Meta_R"           = DeadKey+keyTranslate "ISO_Level2_Shift" = DeadKey+keyTranslate "ISO_Level3_Shift" = DeadKey+keyTranslate "ISO_Level2_Latch" = DeadKey+keyTranslate "ISO_Level3_Latch" = DeadKey+keyTranslate "Num_Lock"         = DeadKey+keyTranslate "Caps_Lock"        = DeadKey+keyTranslate "VoidSymbol"       = DeadKey+-- numeric keypad+keyTranslate ['K','P','_',c] = KP c+-- standard characters+keyTranslate [c]             = Char c+keyTranslate s               = Unknown s++-- | Translate key from a Web API string description+-- (https://developer.mozilla.org/en-US/docs/Web/API/KeyboardEvent/key#Key_values)+-- to our internal key type. To be used in web frontends.+-- The argument says whether Shift is pressed.+keyTranslateWeb :: String -> Bool -> Key+keyTranslateWeb "1"          True = KP '1'+keyTranslateWeb "2"          True = KP '2'+keyTranslateWeb "3"          True = KP '3'+keyTranslateWeb "4"          True = KP '4'+keyTranslateWeb "5"          True = KP '5'+keyTranslateWeb "6"          True = KP '6'+keyTranslateWeb "7"          True = KP '7'+keyTranslateWeb "8"          True = KP '8'+keyTranslateWeb "9"          True = KP '9'+keyTranslateWeb "End"        True = KP '1'+keyTranslateWeb "ArrowDown"  True = KP '2'+keyTranslateWeb "PageDown"   True = KP '3'+keyTranslateWeb "ArrowLeft"  True = KP '4'+keyTranslateWeb "Begin"      True = KP '5'+keyTranslateWeb "Clear"      True = KP '5'+keyTranslateWeb "ArrowRight" True = KP '6'+keyTranslateWeb "Home"       True = KP '7'+keyTranslateWeb "ArrowUp"    True = KP '8'+keyTranslateWeb "PageUp"     True = KP '9'+keyTranslateWeb "Backspace"  _ = BackSpace+keyTranslateWeb "Tab"        True = BackTab+keyTranslateWeb "Tab"        False = Tab+keyTranslateWeb "BackTab"    _ = BackTab+keyTranslateWeb "Begin"      _ = Begin+keyTranslateWeb "Clear"      _ = Begin+keyTranslateWeb "Enter"      _ = Return+keyTranslateWeb "Esc"        _ = Esc+keyTranslateWeb "Escape"     _ = Esc+keyTranslateWeb "Del"        _ = Delete+keyTranslateWeb "Delete"     _ = Delete+keyTranslateWeb "Home"       _ = Home+keyTranslateWeb "Up"         _ = Up+keyTranslateWeb "ArrowUp"    _ = Up+keyTranslateWeb "Down"       _ = Down+keyTranslateWeb "ArrowDown"  _ = Down+keyTranslateWeb "Left"       _ = Left+keyTranslateWeb "ArrowLeft"  _ = Left+keyTranslateWeb "Right"      _ = Right+keyTranslateWeb "ArrowRight" _ = Right+keyTranslateWeb "PageUp"     _ = PgUp+keyTranslateWeb "PageDown"   _ = PgDn+keyTranslateWeb "End"        _ = End+keyTranslateWeb "Insert"     _ = Insert+keyTranslateWeb "space"      _ = Space+keyTranslateWeb "Equals"     _ = Char '='+keyTranslateWeb "Multiply"   True = Char '*'  -- for latop movement keys+keyTranslateWeb "Multiply"   False = KP '*'     -- for keypad aiming+keyTranslateWeb "*"          False = KP '*'     -- for keypad aiming+keyTranslateWeb "Add"        _ = Char '+'  -- KP and normal are merged here+keyTranslateWeb "Subtract"   _ = Char '-'  -- KP and normal are merged here+keyTranslateWeb "Divide"     True = Char '/'+keyTranslateWeb "Divide"     False = KP '/'+keyTranslateWeb "/"          False = KP '/'+keyTranslateWeb "Decimal"    _ = Char '.'  -- dot and comma are merged here+keyTranslateWeb "Separator"  _ = Char '.'  -- to sidestep national standards+keyTranslateWeb "F1"         _ = Fun 1+keyTranslateWeb "F2"         _ = Fun 2+keyTranslateWeb "F3"         _ = Fun 3+keyTranslateWeb "F4"         _ = Fun 4+keyTranslateWeb "F5"         _ = Fun 5+keyTranslateWeb "F6"         _ = Fun 6+keyTranslateWeb "F7"         _ = Fun 7+keyTranslateWeb "F8"         _ = Fun 8+keyTranslateWeb "F9"         _ = Fun 9+keyTranslateWeb "F10"        _ = Fun 10+keyTranslateWeb "F11"        _ = Fun 11+keyTranslateWeb "F12"        _ = Fun 12+-- dead keys+keyTranslateWeb "Dead"        _ = DeadKey+keyTranslateWeb "Shift"       _ = DeadKey+keyTranslateWeb "Control"     _ = DeadKey+keyTranslateWeb "Meta"        _ = DeadKey+keyTranslateWeb "Menu"        _ = DeadKey+keyTranslateWeb "ContextMenu" _ = DeadKey+keyTranslateWeb "Alt"         _ = DeadKey+keyTranslateWeb "AltGraph"    _ = DeadKey+keyTranslateWeb "Num_Lock"    _ = DeadKey+keyTranslateWeb "CapsLock"    _ = DeadKey+keyTranslateWeb "Win"         _ = DeadKey+-- browser quirks+keyTranslateWeb "Unidentified" _ = Begin  -- hack for Firefox+keyTranslateWeb ['\ESC']     _ = Esc+keyTranslateWeb [' ']        _ = Space+keyTranslateWeb ['\n']       _ = Return+keyTranslateWeb ['\r']       _ = DeadKey+keyTranslateWeb ['\t']       _ = Tab+-- standard characters+keyTranslateWeb [c]          _ = Char c+keyTranslateWeb s            _ = Unknown s

Game/LambdaHack/Client/UI/KeyBindings.hs view

@@ -1,31 +1,32 @@+{-# LANGUAGE TupleSections #-} -- | Binding of keys to commands. -- No operation in this module involves the 'State' or 'Action' type. module Game.LambdaHack.Client.UI.KeyBindings-  ( Binding(..), stdBinding, keyHelp+  ( Binding(..), stdBinding, keyHelp, okxsN   ) where -import Control.Arrow (second)-import qualified Data.Char as Char-import Data.List+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import qualified Data.Map.Strict as M-import Data.Text (Text) import qualified Data.Text as T-import Data.Tuple (swap) -import qualified Game.LambdaHack.Client.Key as K import Game.LambdaHack.Client.UI.Config import Game.LambdaHack.Client.UI.Content.KeyKind import Game.LambdaHack.Client.UI.HumanCmd-import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Client.UI.ItemSlot+import qualified Game.LambdaHack.Client.UI.Key as K+import Game.LambdaHack.Client.UI.Overlay+import Game.LambdaHack.Client.UI.Slideshow+import qualified Game.LambdaHack.Common.Color as Color  -- | Bindings and other information about human player commands. data Binding = Binding-  { bcmdMap  :: !(M.Map K.KM (Text, [CmdCategory], HumanCmd))-                                        -- ^ binding of keys to commands-  , bcmdList :: ![(K.KM, (Text, [CmdCategory], HumanCmd))]-                                        -- ^ the properly ordered list-                                        --   of commands for the help menu-  , brevMap  :: !(M.Map HumanCmd K.KM)  -- ^ and from commands to their keys+  { bcmdMap  :: !(M.Map K.KM CmdTriple)   -- ^ binding of keys to commands+  , bcmdList :: ![(K.KM, CmdTriple)]      -- ^ the properly ordered list+                                          --   of commands for the help menu+  , brevMap  :: !(M.Map HumanCmd [K.KM])  -- ^ and from commands to their keys   }  -- | Binding of keys to movement and other standard commands,@@ -33,41 +34,59 @@ stdBinding :: KeyKind  -- ^ default key bindings from the content            -> Config   -- ^ game config            -> Binding  -- ^ concrete binding-stdBinding copsClient !Config{configCommands, configVi, configLaptop} =-  let heroSelect k = ( K.toKM K.NoModifier (K.Char (Char.intToDigit k))-                     , ([CmdMeta], PickLeader k) )-      cmdWithHelp = rhumanCommands copsClient ++ configCommands-      cmdAll =-        cmdWithHelp-        ++ [ (K.mkKM "KP_Begin", ([CmdMove], Wait))-           , (K.mkKM "CTRL-KP_Begin", ([CmdMove], Macro "" ["KP_Begin"]))-           , (K.mkKM "KP_5", ([CmdMove], Macro "" ["KP_Begin"]))-           , (K.mkKM "CTRL-KP_5", ([CmdMove], Macro "" ["KP_Begin"])) ]-        ++ (if configVi-            then [ (K.mkKM "period", ([CmdMove], Macro "" ["KP_Begin"])) ]-            else if configLaptop-            then [ (K.mkKM "i", ([CmdMove], Macro "" ["KP_Begin"]))-                 , (K.mkKM "I", ([CmdMove], Macro "" ["KP_Begin"])) ]-            else [])-        ++ K.moveBinding configVi configLaptop (\v -> ([CmdMove], Move v))-                                               (\v -> ([CmdMove], Run v))-        ++ fmap heroSelect [0..6]-      mkDescribed (cats, cmd) = (cmdDescription cmd, cats, cmd)+stdBinding copsClient Config{configCommands, configVi, configLaptop} =+  let waitTriple = ([CmdMove], "", Wait)+      wait10Triple = ([CmdMove], "", Wait10)+      moveXhairOr n cmd v = ByAimMode { exploration = cmd v+                                      , aiming = MoveXhair v n }+      bcmdList =+        (if configVi+         then filter (\(k, _) ->+           k `notElem` [K.mkKM "period", K.mkKM "C-period"])+         else id) (rhumanCommands copsClient)+        ++ configCommands+        ++ [ (K.mkKM "KP_Begin", waitTriple)+           , (K.mkKM "C-KP_Begin", wait10Triple)+           , (K.mkKM "KP_5", waitTriple)+           , (K.mkKM "C-KP_5", wait10Triple) ]+        ++ (if | configVi ->+                 [ (K.mkKM "period", waitTriple)+                 , (K.mkKM "C-period", wait10Triple) ]+               | configLaptop ->+                 [ (K.mkKM "i", waitTriple)+                 , (K.mkKM "C-i", wait10Triple)+                 , (K.mkKM "I", waitTriple) ]+               | otherwise ->+                 [])+        ++ K.moveBinding configVi configLaptop+             (\v -> ([CmdMove], "", moveXhairOr 1 MoveDir v))+             (\v -> ([CmdMove], "", moveXhairOr 10 RunDir v))+      rejectRepetitions t1 t2 = assert `failure` "duplicate key"+                                       `twith` (t1, t2)   in Binding-  { bcmdMap = M.fromList $ map (second mkDescribed) cmdAll-  , bcmdList = map (second mkDescribed) cmdWithHelp-  , brevMap = M.fromList $ map (swap . second snd) cmdAll+  { bcmdMap = M.fromListWith rejectRepetitions+      [ (k, triple)+      | (k, triple@(cats, _, _)) <- bcmdList+      , all (`notElem` [CmdMainMenu]) cats+      ]+  , bcmdList+  , brevMap = M.fromListWith (flip (++)) $ concat+      [ [(cmd, [k])]+      | (k, (cats, _desc, cmd)) <- bcmdList+      , all (`notElem` [CmdMainMenu, CmdDebug, CmdNoHelp]) cats+      ]   }  -- | Produce a set of help screens from the key bindings.-keyHelp :: Binding -> Slideshow-keyHelp Binding{bcmdList} =+keyHelp :: Binding -> Int -> [(Text, OKX)]+keyHelp keyb@Binding{..} offset = assert (offset > 0) $   let     movBlurb =-      [ "Walk throughout a level with mouse or numeric keypad (left diagram)"-      , "or its compact laptop replacement (middle) or the Vi text editor keys"-      , "(right, also known as \"Rogue-like keys\"; can be enabled in config.ui.ini)."-      , "Run, until disturbed, with left mouse button or SHIFT (or CTRL) and a key."+      [ ""+      , "Walk throughout a level with mouse or numeric keypad (left diagram below)"+      , "or its compact laptop replacement (middle) or the Vi text editor keys (right,"+      , "enabled in config.ui.ini). Run, until disturbed, by adding Shift or Control."+      , "Go-to with LMB (left mouse button). Run collectively with RMB."       , ""       , "               7 8 9          7 8 9          y k u"       , "                \\|/            \\|/            \\|/"@@ -75,82 +94,169 @@       , "                /|\\            /|\\            /|\\"       , "               1 2 3          j k l          b j n"       , ""-      , "In aiming mode (KEYPAD_* or \\) the same keys (or mouse) move the crosshair."-      , "Press 'KEYPAD_5' (or 'i' or '.') to wait, bracing for blows, which reduces"-      , "any damage taken and makes it impossible for foes to displace you."-      , "You displace enemies or friends by bumping into them with SHIFT (or CTRL)."-      , ""-      , "Search, loot, open and attack by bumping into walls, doors and enemies."+      , "In aiming mode, the same keys (and mouse) move the x-hair (aiming crosshair)."+      , "Press 'KP_5' ('5' on keypad, if present) to wait, bracing for impact,"+      , "which reduces any damage taken and prevents displacement by foes. Press"+      , "'C-KP_5' (the same key with Control) to wait 0.1 of a turn, without bracing."+      , "You displace enemies by running into them with Shift/Control or RMB. Search,"+      , "open, descend and attack by bumping into walls, doors, stairs and enemies."       , "The best item to attack with is automatically chosen from among"       , "weapons in your personal equipment and your unwounded organs."       , ""-      , "Press SPACE to see the minimal command set."+      , "Press SPACE or scroll the mouse wheel to see the minimal command set."       ]     minimalBlurb =-      [ "The following minimal command set lets you accomplish anything in the game,"-      , "though not necessarily with the fewest number of keystrokes."-      , "Most of the other commands are shorthands, defined as macros"-      , "(with the exception of the advanced commands for assigning non-default"-      , "tactics and targets to your autonomous henchmen, if you have any)."+      [ "The following commands, joined with the basic set above, let you accomplish"+      , "anything in the game, though not necessarily with the fewest keystrokes."+      , "You can also play the game exclusively with a mouse, or both mouse and"+      , "keyboard. See the ending help screens for mouse commands."+      , "Lastly, you can select a command with arrows or mouse directly from the help"+      , "screen and execute it on the spot."       , ""       ]-    casualEndBlurb =+    casualEnding =       [ ""       , "Press SPACE to see the detailed descriptions of all commands."       ]-    categoryBlurb =+    categoryEnding =       [ ""       , "Press SPACE to see the next page of command descriptions."       ]-    lastBlurb =+    lastCategoryEnding =       [ ""+      , "Press SPACE to see mouse command descriptions."+      ]+    mouseBasicsBlurb =+      [ "Screen area and UI mode (aiming/exploration) determine mouse click effects."+      , "Here is an overview of effects of each button over most of the game map area."+      , "The list includes not only left and right buttons, but also the optional"+      , "middle mouse button (MMB) and even the mouse wheel, which is normally used"+      , "over menus, to page-scroll them, rather than over game map."+      , "For mice without RMB, one can use C-LMB (Control key and left mouse button)."+      , ""+      ]+    mouseBasicsEnding =+      [ ""+      , "Press SPACE to see mouse commands in aiming mode."+      ]+    mouseAimingModeEnding =+      [ ""+      , "Press SPACE to see mouse commands in explorations mode."+      ]+    lastHelpEnding =+      [ ""       , "For more playing instructions see file PLAYING.md."-      , "Press PGUP to return to previous pages or ESC to see the map again."+      , "Press PGUP or scroll the mouse wheel to return to previous pages"+      , "and press SPACE or ESC to see the map again."       ]+    keyL = 12     pickLeaderDescription =-      [ fmt 16 "0, 1 ... 6" "pick a particular actor as the new leader"+      [ fmt keyL "0, 1 ... 6" "pick a particular actor as the new leader"       ]     casualDescription = "Minimal cheat sheet for casual play"-    fmt n k h = T.justifyRight 72 ' '-                $ T.justifyLeft n ' ' k-                  <> T.justifyLeft 48 ' ' h-    fmts s = " " <> T.justifyLeft 71 ' ' s+    fmt n k h = " " <> T.justifyLeft n ' ' k <+> h+    fmts s = " " <> s     movText = map fmts movBlurb     minimalText = map fmts minimalBlurb-    casualEndText = map fmts casualEndBlurb-    categoryText = map fmts categoryBlurb-    lastText = map fmts lastBlurb-    coImage :: K.KM -> [K.KM]-    coImage k = k : sort [ from-                         | (from, (_, cats, Macro _ [to])) <- bcmdList-                         , K.mkKM to == k-                         , any (`notElem` [CmdDebug, CmdInternal]) cats ]-    disp k = T.concat $ intersperse " or " $ map K.showKM $ coImage k-    keysN n cat = [ fmt n (disp k) h-                  | (k, (h, cats, _)) <- bcmdList, cat `elem` cats, h /= "" ]-    -- TODO: measure the longest key sequence and set the caption automatically+    casualEnd = map fmts casualEnding+    categoryEnd = map fmts categoryEnding+    lastCategoryEnd = map fmts lastCategoryEnding+    mouseBasicsText = map fmts mouseBasicsBlurb+    mouseBasicsEnd = map fmts mouseBasicsEnding+    mouseAimingModeEnd = map fmts mouseAimingModeEnding+    lastHelpEnd = map fmts lastHelpEnding     keyCaptionN n = fmt n "keys" "command"-    keys = keysN 16-    keyCaption = keyCaptionN 16-  in toSlideshow (Just True)-    [ [casualDescription <+> "(1/2). [press SPACE to see more]"] ++ [""]-      ++ movText ++ [moreMsg]-    , [casualDescription <+> "(2/2). [press SPACE to see all commands]"] ++ [""]-      ++ minimalText-      ++ [keyCaption] ++ keys CmdMinimal ++ casualEndText ++ [moreMsg]-    , ["All terrain exploration and alteration commands"-       <> ". [press SPACE to advance]"] ++ [""]-      ++ [keyCaptionN 10] ++ keysN 10 CmdMove ++ categoryText ++ [moreMsg]-    , [categoryDescription CmdItem <> ". [press SPACE to advance]"] ++ [""]-      ++ [keyCaptionN 10] ++ keysN 10 CmdItem ++ categoryText ++ [moreMsg]-    , [categoryDescription CmdTgt <> ". [press SPACE to advance]"] ++ [""]-      ++ [keyCaption] ++ keys CmdTgt ++ categoryText ++ [moreMsg]-    , [categoryDescription CmdAuto <> ". [press SPACE to advance]"] ++ [""]-      ++ [keyCaption] ++ keys CmdAuto ++ categoryText ++ [moreMsg]-    , [categoryDescription CmdMeta <> ". [press SPACE to advance]"] ++ [""]-      ++ [keyCaption] ++ keys CmdMeta ++ pickLeaderDescription-      ++ categoryText ++ [moreMsg]-    , [categoryDescription CmdMouse-       <> ". [press PGUP to see previous, ESC to cancel]"] ++ [""]-      ++ [keyCaptionN 21] ++ keysN 21 CmdMouse ++ lastText ++ [endMsg]+    keyCaption = keyCaptionN keyL+    okxs = okxsN keyb offset keyL (const False)+    keyM = 13+    keyB = 31+    truncatem b = if T.length b > keyB+                  then T.take (keyB - 1) b <> "$"+                  else b+    fmm a b c = fmt keyM a $ fmt keyB (truncatem b) (" " <> truncatem c)+    areaCaption = fmm "area" "LMB (left mouse button)"+                             "RMB (right mouse button)"+    keySel :: ((HumanCmd, HumanCmd) -> HumanCmd) -> K.KM+           -> [(CmdArea, Either K.KM SlotChar, Text)]+    keySel sel key =+      let cmd = case M.lookup key bcmdMap of+            Just (_, _, cmd2) -> cmd2+            Nothing -> assert `failure` key+          caCmds = case cmd of+            ByAimMode{..} -> case sel (exploration, aiming) of+              ByArea l -> sort l+              _ -> assert `failure` cmd+            _ -> assert `failure` cmd+          caMakeChoice (ca, cmd2) =+            let (km, desc) = case M.lookup cmd2 brevMap of+                  Just ks ->+                    let descOfKM km2 = case M.lookup km2 bcmdMap of+                          Just (_, "", _) -> Nothing+                          Just (_, desc2, _) -> Just (km2, desc2)+                          Nothing -> assert `failure` km2+                    in case mapMaybe descOfKM ks of+                      [] -> assert `failure` (ks, cmd2)+                      kmdesc3 : _ -> kmdesc3+                  Nothing -> (key, "(not described:" <+> tshow cmd2 <> ")")+            in (ca, Left km, desc)+      in map caMakeChoice caCmds+    okm :: ((HumanCmd, HumanCmd) -> HumanCmd)+        -> K.KM -> K.KM -> [Text] -> [Text]+        -> OKX+    okm sel key1 key2 header footer =+      let kst1 = keySel sel key1+          kst2 = keySel sel key2+          f (ca1, Left km1, _) (ca2, Left km2, _) y = assert (ca1 == ca2)+            [ (Left [km1], (y, keyM + 3, keyB + keyM + 3))+            , (Left [km2], (y, keyB + keyM + 5, 2 * keyB + keyM + 5)) ]+          f c d e = assert `failure` (c, d, e)+          kxs = concat $ zipWith3 f kst1 kst2 [offset + length header..]+          render (ca1, _, desc1) (_, _, desc2) =+            fmm (areaDescription ca1) desc1 desc2+          menu = zipWith render kst1 kst2+      in (map textToAL $ "" : header ++ menu ++ footer, kxs)+  in+    [ ( casualDescription <+> "(1/2)."+      , (map textToAL movText, []) )+    , ( casualDescription <+> "(2/2)."+      , okxs CmdMinimal (minimalText ++ [keyCaption]) casualEnd )+    , ( "All terrain exploration and alteration commands."+      , okxs CmdMove [keyCaption] categoryEnd )+    , ( categoryDescription CmdItemMenu <> "."+      , okxs CmdItemMenu [keyCaption] categoryEnd )+    , ( categoryDescription CmdItem <> "."+      , okxs CmdItem [keyCaption] categoryEnd )+    , ( categoryDescription CmdAim <> "."+      , okxs CmdAim [keyCaption] categoryEnd )+    , ( categoryDescription CmdMeta <> "."+      , okxs CmdMeta [keyCaption] (pickLeaderDescription ++ lastCategoryEnd) )+    , ( "Mouse overview."+      , let (ls, _) =+              okxs CmdMouse (mouseBasicsText ++ [keyCaption]) mouseBasicsEnd+        in (ls, []) )  -- don't capture mouse wheel, etc.+    , ( "Mouse in aiming mode."+      , okm snd K.leftButtonReleaseKM K.rightButtonReleaseKM+            [areaCaption] mouseAimingModeEnd )+    , ( "Mouse in exploration mode."+      , okm fst K.leftButtonReleaseKM K.rightButtonReleaseKM+            [areaCaption] lastHelpEnd )     ]++okxsN :: Binding -> Int -> Int -> (HumanCmd -> Bool) -> CmdCategory+      -> [Text] -> [Text] -> OKX+okxsN Binding{..} offset n greyedOut cat header footer =+  let fmt k h = " " <> T.justifyLeft n ' ' k <+> h+      coImage :: HumanCmd -> [K.KM]+      coImage cmd = M.findWithDefault (assert `failure` cmd) cmd brevMap+      disp = T.intercalate " or " . map (T.pack . K.showKM)+      keys :: [(Either [K.KM] SlotChar, (Bool, Text))]+      keys = [ (Left kms, (greyedOut cmd, fmt (disp kms) desc))+             | (_, (cats, desc, cmd)) <- bcmdList+             , let kms = coImage cmd+             , cat `elem` cats+             , desc /= "" ]+      f (ks, (_, tkey)) y = (ks, (y, 1, T.length tkey))+      kxs = zipWith f keys [offset + length header..]+      ts = map (False,) ("" : header) ++ map snd keys ++ map (False,) footer+      greyToAL (b, t) = if b then fgToAL Color.BrBlack t else textToAL t+  in (map greyToAL ts, kxs)

Game/LambdaHack/Client/UI/MonadClientUI.hs view

@@ -1,270 +1,252 @@-{-# LANGUAGE RankNTypes #-} -- | Client monad for interacting with a human through UI. module Game.LambdaHack.Client.UI.MonadClientUI   ( -- * Client UI monad-    MonadClientUI( getsSession  -- exposed only to be implemented, not used-                 , liftIO  -- exposed only to be implemented, not used+    MonadClientUI( getsSession, modifySession+                 , liftIO  -- exposed only to be implemented, not used,                  )-  , SessionUI(..)-    -- * Display and key input-  , ColorMode(..)-  , promptGetKey, getKeyOverlayCommand, getInitConfirms-  , displayFrame, displayDelay, displayActorStart, drawOverlay     -- * Assorted primitives-  , stopPlayBack, askConfig, askBinding-  , syncFrames, setFrontAutoYes, tryTakeMVarSescMVar, scoreToSlideshow-  , getLeaderUI, getArenaUI, viewedLevel-  , targetDescLeader, targetDescCursor-  , leaderTgtToPos, leaderTgtAims, cursorToPos+  , getSession, putSession, clientPrintUI, mapStartY, displayFrames+  , setFrontAutoYes, anyKeyPressed, discardPressedKey, addPressedEsc+  , connFrontendFrontKey, frontendShutdown, chanFrontend+  , getReportUI, getLeaderUI, getArenaUI, viewedLevelUI+  , leaderTgtToPos, xhairToPos, clearXhair, clearAimMode+  , scoreToSlideshow, defaultHistory+  , tellAllClipPS, tellGameClipPS, elapsedSessionTimeGT+  , resetSessionStart, resetGameStart+  , partAidLeader, partActorLeader, partActorLeaderFun, partPronounLeader+  , tryRestore, leaderSkillsClientUI   ) where -import Control.Applicative-import Control.Concurrent-import Control.Concurrent.STM-import Control.Exception.Assert.Sugar-import Control.Monad+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import qualified Data.EnumMap.Strict as EM-import Data.Maybe-import Data.Monoid-import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Time.Clock+import Data.Time.Clock.POSIX+import Data.Time.LocalTime import qualified NLP.Miniutter.English as MU-import System.Time+import System.FilePath+import System.IO (hFlush, stdout) -import Game.LambdaHack.Client.BfsClient-import Game.LambdaHack.Client.CommonClient-import qualified Game.LambdaHack.Client.Key as K+import Game.LambdaHack.Client.CommonM import Game.LambdaHack.Client.MonadClient hiding (liftIO) import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.Animation-import Game.LambdaHack.Client.UI.Config-import Game.LambdaHack.Client.UI.DrawClient-import Game.LambdaHack.Client.UI.Frontend as Frontend-import Game.LambdaHack.Client.UI.KeyBindings+import Game.LambdaHack.Client.UI.ActorUI+import Game.LambdaHack.Client.UI.Frame+import Game.LambdaHack.Client.UI.Frontend+import qualified Game.LambdaHack.Client.UI.Frontend as Frontend+import qualified Game.LambdaHack.Client.UI.Key as K+import Game.LambdaHack.Client.UI.Msg+import Game.LambdaHack.Client.UI.Overlay+import Game.LambdaHack.Client.UI.SessionUI+import Game.LambdaHack.Client.UI.Slideshow+import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.ClientOptions import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.File import qualified Game.LambdaHack.Common.HighScore as HighScore-import Game.LambdaHack.Common.ItemDescription+import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.Save as Save import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Time-import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Content.RuleKind --- | The information that is constant across a client playing session,--- including many consecutive games in a single session,--- but is completely disregarded and reset when a new playing session starts.--- This includes a frontend session and keybinding info.-data SessionUI = SessionUI-  { schanF   :: !ChanFrontend       -- ^ connection with the frontend-  , sbinding :: !Binding            -- ^ binding of keys to commands-  , sescMVar :: !(Maybe (MVar ()))-  , sconfig  :: !Config-  }+-- Assumes no interleaving with other clients, because each UI client+-- in a different terminal/window/machine.+clientPrintUI :: MonadClientUI m => Text -> m ()+clientPrintUI t = liftIO $ do+  T.hPutStrLn stdout t+  hFlush stdout +-- | The row where the dungeon map starts.+mapStartY :: Y+mapStartY = 1+ -- | The monad that gives the client access to UI operations. class MonadClient m => MonadClientUI m where-  getsSession  :: (SessionUI -> a) -> m a-  liftIO       :: IO a -> m a+  getsSession   :: (SessionUI -> a) -> m a+  modifySession :: (SessionUI -> SessionUI) -> m ()+  liftIO        :: IO a -> m a --- | Read a keystroke received from the frontend.-readConnFrontend :: MonadClientUI m => m K.KM-readConnFrontend = do-  ChanFrontend{responseF} <- getsSession schanF-  liftIO $ atomically $ readTQueue responseF+getSession :: MonadClientUI m => m SessionUI+getSession = getsSession id --- | Write a UI request to the frontend.-writeConnFrontend :: MonadClientUI m => FrontReq -> m ()-writeConnFrontend efr = do-  ChanFrontend{requestF} <- getsSession schanF-  liftIO $ atomically $ writeTQueue requestF efr+putSession :: MonadClientUI m => SessionUI -> m ()+putSession s = modifySession (const s) -promptGetKey :: MonadClientUI m => [K.KM] -> SingleFrame -> m K.KM-promptGetKey frontKM frontFr = do-  -- Assume we display the arena when we prompt for a key and possibly-  -- insert a delay and reset cutoff.-  arena <- getArenaUI-  localTime <- getsState $ getLocalTime arena-  -- No delay, because this is before the UI actor acts. Ideally the frame-  -- would not be changed either.-  -- However, set sdisplayed so that there's no extra delay after the actor-  -- acts either, because waiting for the key introduces enough delay.-  -- Or this is running, etc., which we want fast.-  let ageDisp = EM.insert arena localTime-  modifyClient $ \cli -> cli {sdisplayed = ageDisp $ sdisplayed cli}-  escPressed <- tryTakeMVarSescMVar  -- this also clears the ESC-pressed marker-  lastPlayOld <- getsClient slastPlay-  km <- case lastPlayOld of-    km : kms | not escPressed && (null frontKM || km `elem` frontKM) -> do-      displayFrame $ Just frontFr-      -- Sync frames so that ESC doesn't skip frames.-      syncFrames-      modifyClient $ \cli -> cli {slastPlay = kms}-      return km-    _ -> do-      stopPlayBack  -- we can't continue playback; wipe out old srunning-      writeConnFrontend FrontKey{..}-      km <- readConnFrontend-      modifyClient $ \cli -> cli {slastKM = km}-      return km-  (seqCurrent, seqPrevious, k) <- getsClient slastRecord-  let slastRecord = (km : seqCurrent, seqPrevious, k)-  modifyClient $ \cli -> cli {slastRecord}-  return km+-- | Write a UI request to the frontend and read a corresponding reply.+connFrontend :: MonadClientUI m => FrontReq a -> m a+connFrontend req = do+  ChanFrontend f <- getsSession schanF+  liftIO $ f req --- | Display an overlay and wait for a human player command.-getKeyOverlayCommand :: MonadClientUI m => Maybe Bool -> Overlay -> m K.KM-getKeyOverlayCommand onBlank overlay = do-  frame <- drawOverlay (isJust onBlank) ColorFull overlay-  promptGetKey [] frame+displayFrame :: MonadClientUI m => Maybe FrameForall -> m ()+displayFrame mf = do+  frame <- case mf of+    Nothing -> return $! FrontDelay 1+    Just fr -> do+      modifySession $ \cli -> cli {snframes = snframes cli + 1}+      return $! FrontFrame fr+  connFrontend frame --- | Display a slideshow, awaiting confirmation for each slide except the last.-getInitConfirms :: MonadClientUI m-                => ColorMode -> [K.KM] -> Slideshow -> m Bool-getInitConfirms dm frontClear slides = do-  let (onBlank, ovs) = slideshow slides-      frontFromTop = onBlank-  frontSlides <- drawOverlays (isJust onBlank) dm ovs-  case frontSlides of-    [] -> return True-    _ -> do-      writeConnFrontend FrontSlides{..}-      km <- readConnFrontend-      -- Don't clear ESC marker here, because the wait for confirms may-      -- block a ping and the ping would not see the ESC.-      return $! km /= K.escKM+-- | Push frames or delays to the frame queue. The frames depict+-- the @lid@ level.+displayFrames :: MonadClientUI m => LevelId -> Frames -> m ()+displayFrames lid frs = do+  mapM_ displayFrame frs+  -- Can be different than @blid b@, e.g., when our actor is attacked+  -- on a remote level.+  lidV <- viewedLevelUI+  when (lidV == lid) $+    modifySession $ \sess -> sess {sdisplayNeeded = False} -displayFrame :: MonadClientUI m => Maybe SingleFrame -> m ()-displayFrame mf = do-  let frame = case mf of-        Nothing -> FrontDelay-        Just fr -> FrontNormalFrame fr-  writeConnFrontend frame+-- | Write 'FrontKey' UI request to the frontend, read the reply,+-- set pointer, return key.+connFrontendFrontKey :: MonadClientUI m => [K.KM] -> FrameForall -> m K.KM+connFrontendFrontKey frontKeyKeys frontKeyFrame = do+  kmp <- connFrontend FrontKey{..}+  modifySession $ \sess -> sess {spointer = kmpPointer kmp}+  return $! kmpKeyMod kmp -displayDelay :: MonadClientUI m =>  m ()-displayDelay = replicateM_ 4 $ writeConnFrontend FrontDelay+setFrontAutoYes :: MonadClientUI m => Bool -> m ()+setFrontAutoYes b = connFrontend $ FrontAutoYes b --- | Push frames or delays to the frame queue. Additionally set @sdisplayed@.--- because animations not always happen after @SfxActorStart@ on the leader's--- level (e.g., death can lead to leader change to another level mid-turn,--- and there could be melee and animations on that level at the same moment).--- Insert delays, so that the animations don't look rushed.-displayActorStart :: MonadClientUI m => Actor -> Frames -> m ()-displayActorStart b frs = do-  timeCutOff <- getsClient $ EM.findWithDefault timeZero (blid b) . sdisplayed-  localTime <- getsState $ getLocalTime (blid b)-  let delta = localTime `timeDeltaToFrom` timeCutOff-  when (delta > Delta timeClip && not (bproj b))-    displayDelay-  let ageDisp = EM.insert (blid b) localTime-  modifyClient $ \cli -> cli {sdisplayed = ageDisp $ sdisplayed cli}-  mapM_ displayFrame frs+anyKeyPressed :: MonadClientUI m => m Bool+anyKeyPressed = connFrontend FrontPressed --- | Draw the current level with the overlay on top.-drawOverlay :: MonadClientUI m-            => Bool -> ColorMode -> Overlay -> m SingleFrame-drawOverlay sfBlank@True _ sfTop = do-  let sfLevel = []-      sfBottom = []-  return $! SingleFrame {..}-drawOverlay False dm sfTop = do-  lid <- viewedLevel-  mleader <- getsClient _sleader-  tgtPos <- leaderTgtToPos-  cursorPos <- cursorToPos-  let anyPos = fromMaybe (Point 0 0) cursorPos-        -- if cursor invalid, e.g., on a wrong level; @draw@ ignores it later on-      pathFromLeader leader = Just <$> getCacheBfsAndPath leader anyPos-  bfsmpath <- maybe (return Nothing) pathFromLeader mleader-  tgtDesc <- maybe (return ("------", Nothing)) targetDescLeader mleader-  cursorDesc <- targetDescCursor-  draw dm lid cursorPos tgtPos bfsmpath cursorDesc tgtDesc sfTop+discardPressedKey :: MonadClientUI m => m ()+discardPressedKey = connFrontend FrontDiscard -drawOverlays :: MonadClientUI m-             => Bool -> ColorMode -> [Overlay] -> m [SingleFrame]-drawOverlays _ _ [] = return []-drawOverlays sfBlank dm (topFirst : rest) = do-  fistFrame <- drawOverlay sfBlank dm topFirst-  let f topNext = fistFrame {sfTop = topNext}-  return $! fistFrame : map f rest  -- keep @rest@ lazy for responsiveness+addPressedKey :: MonadClientUI m => KMP -> m ()+addPressedKey = connFrontend . FrontAdd -stopPlayBack :: MonadClientUI m => m ()-stopPlayBack = do-  modifyClient $ \cli -> cli-    { slastPlay = []-    , slastRecord = ([], [], 0)-        -- TODO: not ideal, but needed to cancel macros that contain apostrophes-    , swaitTimes = - abs (swaitTimes cli)-    }-  srunning <- getsClient srunning-  case srunning of-    Nothing -> return ()-    Just RunParams{runLeader} -> do-      -- Switch to the original leader, from before the run start,-      -- unless dead or unless the faction never runs with multiple-      -- (but could have the leader changed automatically meanwhile).-      side <- getsClient sside-      fact <- getsState $ (EM.! side) . sfactionD-      arena <- getArenaUI-      s <- getState-      when (memActor runLeader arena s && not (noRunWithMulti fact)) $-        modifyClient $ updateLeader runLeader s-      modifyClient (\cli -> cli {srunning = Nothing})+addPressedEsc :: MonadClientUI m => m ()+addPressedEsc = addPressedKey KMP { kmpKeyMod = K.escKM+                                  , kmpPointer = originPoint } -askConfig :: MonadClientUI m => m Config-askConfig = getsSession sconfig+frontendShutdown :: MonadClientUI m => m ()+frontendShutdown = connFrontend FrontShutdown --- | Get the key binding.-askBinding :: MonadClientUI m => m Binding-askBinding = getsSession sbinding+chanFrontend :: MonadClientUI m => DebugModeCli -> m ChanFrontend+chanFrontend = liftIO . Frontend.chanFrontendIO --- | Sync frames display with the frontend.-syncFrames :: MonadClientUI m => m ()-syncFrames = do-  -- Hack.-  writeConnFrontend-    FrontSlides{frontClear=[], frontSlides=[], frontFromTop=Nothing}-  km <- readConnFrontend-  let !_A = assert (km == K.spaceKM) ()-  return ()+getReportUI :: MonadClientUI m => m Report+getReportUI = do+  report <- getsSession _sreport+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  let underAI = isAIFact fact+      promptAI = toPrompt $ stringToAL "[press ESC for Main Menu]"+  return $! if underAI then consReportNoScrub promptAI report else report -setFrontAutoYes :: MonadClientUI m => Bool -> m ()-setFrontAutoYes b = writeConnFrontend $ FrontAutoYes b+getLeaderUI :: MonadClientUI m => m ActorId+getLeaderUI = do+  cli <- getClient+  case _sleader cli of+    Nothing -> assert `failure` "leader expected but not found" `twith` cli+    Just leader -> return leader -tryTakeMVarSescMVar :: MonadClientUI m => m Bool-tryTakeMVarSescMVar = do-  mescMVar <- getsSession sescMVar-  case mescMVar of-    Nothing -> return False-    Just escMVar -> do-      mUnit <- liftIO $ tryTakeMVar escMVar-      return $! isJust mUnit+getArenaUI :: MonadClientUI m => m LevelId+getArenaUI = do+  let fallback = do+        side <- getsClient sside+        fact <- getsState $ (EM.! side) . sfactionD+        case gquit fact of+          Just Status{stDepth} -> return $! toEnum stDepth+          Nothing -> getEntryArena fact+  mleader <- getsClient _sleader+  case mleader of+    Just leader -> do+      -- The leader may just be teleporting (e.g., due to displace+      -- over terrain not in FOV) so not existent momentarily.+      mem <- getsState $ EM.member leader . sactorD+      if mem+      then getsState $ blid . getActorBody leader+      else fallback+    Nothing -> fallback +viewedLevelUI :: MonadClientUI m => m LevelId+viewedLevelUI = do+  arena <- getArenaUI+  saimMode <- getsSession saimMode+  return $! maybe arena aimLevelId saimMode++leaderTgtToPos :: MonadClientUI m => m (Maybe Point)+leaderTgtToPos = do+  lidV <- viewedLevelUI+  mleader <- getsClient _sleader+  case mleader of+    Nothing -> return Nothing+    Just aid -> do+      mtgt <- getsClient $ getTarget aid+      case mtgt of+        Nothing -> return Nothing+        Just tgt -> aidTgtToPos aid lidV tgt++xhairToPos :: MonadClientUI m => m (Maybe Point)+xhairToPos = do+  lidV <- viewedLevelUI+  mleader <- getsClient _sleader+  sxhair <- getsSession sxhair+  case mleader of+    Nothing -> return Nothing  -- e.g., when game start and no leader yet+    Just aid -> aidTgtToPos aid lidV sxhair  -- e.g., xhair on another level++-- Reset xhair and move it to actor's position.+clearXhair :: MonadClientUI m => m ()+clearXhair = do+  leader <- getLeaderUI+  lpos <- getsState $ bpos . getActorBody leader+  lidV <- viewedLevelUI  -- don't assume aiming mode is or will be off+  modifySession $ \sess -> sess {sxhair = TPoint TAny lidV lpos}++-- If aim mode is exited, usually the player had the opportunity to deal+-- with xhair on a foe spotted on another level, so now move xhair+-- back to the leader level.+clearAimMode :: MonadClientUI m => m ()+clearAimMode = do+  leader <- getLeaderUI+  lpos <- getsState $ bpos . getActorBody leader+  xhairPos <- xhairToPos  -- computed while still in aiming mode+  modifySession $ \sess -> sess {saimMode = Nothing}+  lidV <- viewedLevelUI  -- not in aiming mode at this point+  sxhairOld <- getsSession sxhair+  let cpos = fromMaybe lpos xhairPos+      sxhair = case sxhairOld of+        TEnemy{} -> sxhairOld+        TVector{} -> sxhairOld+        _ -> TPoint TAny lidV cpos+  modifySession $ \sess -> sess {sxhair}+ scoreToSlideshow :: MonadClientUI m => Int -> Status -> m Slideshow scoreToSlideshow total status = do+  lidV <- viewedLevelUI+  Level{lxsize, lysize} <- getLevel lidV   fid <- getsClient sside   fact <- getsState $ (EM.! fid) . sfactionD-  -- TODO: Re-read the table in case it's changed by a concurrent game.-  -- TODO: we should do this, and make sure we do that after server-  -- saved the updated score table, and not register, but read from it.-  -- Otherwise the score is not accurate, e.g., the number of victims.   scoreDict <- getsState shigh   gameModeId <- getsState sgameModeId   gameMode <- getGameMode   time <- getsState stime-  date <- liftIO getClockTime-  scurDiff <- getsClient scurDiff+  date <- liftIO getPOSIXTime+  tz <- liftIO $ getTimeZone $ posixSecondsToUTCTime date+  curChalSer <- getsClient scurChal   factionD <- getsState sfactionD   let table = HighScore.getTable gameModeId scoreDict       gameModeName = mname gameMode-      showScore (ntable, pos) =-        HighScore.highSlideshow ntable pos gameModeName-      diff | fhasUI $ gplayer fact = scurDiff-           | otherwise = difficultyInverse scurDiff+      chal | fhasUI $ gplayer fact = curChalSer+           | otherwise = curChalSer+                           {cdiff = difficultyInverse (cdiff curChalSer)}       theirVic (fi, fa) | isAtWar fact fi                           && not (isHorrorFact fa) = Just $ gvictims fa                         | otherwise = Nothing@@ -272,122 +254,145 @@       ourVic (fi, fa) | isAllied fact fi || fi == fid = Just $ gvictims fa                       | otherwise = Nothing       ourVictims = EM.unionsWith (+) $ mapMaybe ourVic $ EM.assocs factionD-      (worthMentioning, rScore) =-        HighScore.register table total time status date diff-                           (fname $ gplayer fact)+      (worthMentioning, (ntable, pos)) =+        HighScore.register table total time status date chal+                           (T.unwords $ tail $ T.words $ gname fact)                            ourVictims theirVictims                            (fhiCondPoly $ gplayer fact)-  return $! if worthMentioning then showScore rScore else mempty+      (msg, tts) = HighScore.highSlideshow ntable pos gameModeName tz+      al = textToAL msg+      splitScreen ts =+        splitOKX lxsize (lysize + 3) al [K.spaceKM, K.escKM] (ts, [])+      sli = toSlideshow $ concat $ map (splitScreen . map textToAL) tts+  return $! if worthMentioning+            then sli+            else emptySlideshow -getLeaderUI :: MonadClientUI m => m ActorId-getLeaderUI = do-  cli <- getClient-  case _sleader cli of-    Nothing -> assert `failure` "leader expected but not found" `twith` cli-    Just leader -> return leader+defaultHistory :: MonadClientUI m => Int -> m History+defaultHistory configHistoryMax = liftIO $ do+  utcTime <- getCurrentTime+  timezone <- getTimeZone utcTime+  let curDate = show $ utcToLocalTime timezone utcTime+      emptyHist = emptyHistory configHistoryMax+  return $! addReport emptyHist timeZero+         $ singletonReport $ toMsg $ stringToAL+         $ "Human history log started on " ++ curDate ++ "." -getArenaUI :: MonadClientUI m => m LevelId-getArenaUI = do-  mleader <- getsClient _sleader-  case mleader of-    Just leader -> getsState $ blid . getActorBody leader-    Nothing -> do-      side <- getsClient sside-      fact <- getsState $ (EM.! side) . sfactionD-      case gquit fact of-        Just Status{stDepth} -> return $! toEnum stDepth-        Nothing -> getEntryArena fact+tellAllClipPS :: MonadClientUI m => m ()+tellAllClipPS = do+  bench <- getsClient $ sbenchmark . sdebugCli+  when bench $ do+    sstartPOSIX <- getsSession sstart+    curPOSIX <- liftIO getPOSIXTime+    allTime <- getsSession sallTime+    gtime <- getsState stime+    allNframes <- getsSession sallNframes+    gnframes <- getsSession snframes+    let time = absoluteTimeAdd allTime gtime+        nframes = allNframes + gnframes+        diff = fromRational $ toRational $ curPOSIX - sstartPOSIX+        cps = fromIntegral (timeFit time timeClip) / diff :: Double+        fps = fromIntegral nframes / diff :: Double+    clientPrintUI $+      "Session time:" <+> tshow diff <> "s; frames:" <+> tshow nframes <> "."+      <+> "Average clips per second:" <+> tshow cps <> "."+      <+> "Average FPS:" <+> tshow fps <> "." -viewedLevel :: MonadClientUI m => m LevelId-viewedLevel = do-  arena <- getArenaUI-  stgtMode <- getsClient stgtMode-  return $! maybe arena tgtLevelId stgtMode+tellGameClipPS :: MonadClientUI m => m ()+tellGameClipPS = do+  bench <- getsClient $ sbenchmark . sdebugCli+  when bench $ do+    sgstartPOSIX <- getsSession sgstart+    curPOSIX <- liftIO getPOSIXTime+    -- If loaded game, don't report anything.+    unless (sgstartPOSIX == 0) $ do+      time <- getsState stime+      nframes <- getsSession snframes+      let diff = fromRational $ toRational $ curPOSIX - sgstartPOSIX+          cps = fromIntegral (timeFit time timeClip) / diff :: Double+          fps = fromIntegral nframes / diff :: Double+      -- This means: "Game portion after last reload time:...".+      clientPrintUI $+        "Game time:" <+> tshow diff <> "s; frames:" <+> tshow nframes <> "."+        <+> "Average clips per second:" <+> tshow cps <> "."+        <+> "Average FPS:" <+> tshow fps <> "." -targetDesc :: MonadClientUI m => Maybe Target -> m (Text, Maybe Text)-targetDesc target = do-  lidV <- viewedLevel-  mleader <- getsClient _sleader-  case target of-    Just (TEnemy aid _) -> do-      side <- getsClient sside-      b <- getsState $ getActorBody aid-      maxHP <- sumOrganEqpClient IK.EqpSlotAddMaxHP aid-      let percentage = 100 * bhp b `div` xM (max 5 maxHP)-          stars | percentage < 20  = "[____]"-                | percentage < 40  = "[*___]"-                | percentage < 60  = "[**__]"-                | percentage < 80  = "[***_]"-                | otherwise        = "[****]"-          hpIndicator = if bfid b == side then Nothing else Just stars-      return (bname b, hpIndicator)-    Just (TEnemyPos _ lid p _) -> do-      let hotText = if lid == lidV-                    then "hot spot" <+> tshow p-                    else "a hot spot on level" <+> tshow (abs $ fromEnum lid)-      return (hotText, Nothing)-    Just (TPoint lid p) -> do-      pointedText <--        if lid == lidV-        then do-          bag <- getsState $ getCBag (CFloor lid p)-          case EM.assocs bag of-            [] -> return $! "exact spot" <+> tshow p-            [(iid, kit@(k, _))] -> do-              localTime <- getsState $ getLocalTime lid-              itemToF <- itemToFullClient-              let (_, name, stats) = partItem CGround localTime (itemToF iid kit)-              return $! makePhrase $ if k == 1-                                     then [name, stats]  -- "a sword" too wordy-                                     else [MU.CarWs k name, stats]-            _ -> return $! "many items at" <+> tshow p-        else return $! "an exact spot on level" <+> tshow (abs $ fromEnum lid)-      return (pointedText, Nothing)-    Just TVector{} ->-      case mleader of-        Nothing -> return ("a relative shift", Nothing)-        Just aid -> do-          tgtPos <- aidTgtToPos aid lidV target-          let invalidMsg = "an invalid relative shift"-              validMsg p = "shift to" <+> tshow p-          return (maybe invalidMsg validMsg tgtPos, Nothing)-    Nothing -> return ("crosshair location", Nothing)+elapsedSessionTimeGT :: MonadClientUI m => Int -> m Bool+elapsedSessionTimeGT stopAfter = do+  current <- liftIO getPOSIXTime+  sstartPOSIX <- getsSession sstart+  return $! fromIntegral stopAfter + sstartPOSIX <= current -targetDescLeader :: MonadClientUI m => ActorId -> m (Text, Maybe Text)-targetDescLeader leader = do-  tgt <- getsClient $ getTarget leader-  targetDesc tgt+resetSessionStart :: MonadClientUI m => m ()+resetSessionStart = do+  sstart <- liftIO getPOSIXTime+  modifySession $ \sess -> sess {sstart}+  resetGameStart -targetDescCursor :: MonadClientUI m => m (Text, Maybe Text)-targetDescCursor = do-  scursor <- getsClient scursor-  targetDesc $ Just scursor+resetGameStart :: MonadClientUI m => m ()+resetGameStart = do+  sgstart <- liftIO getPOSIXTime+  time <- getsState stime+  nframes <- getsSession snframes+  modifySession $ \cli ->+    cli { sgstart+        , sallTime = absoluteTimeAdd (sallTime cli) time+        , snframes = 0+        , sallNframes = sallNframes cli + nframes } -leaderTgtToPos :: MonadClientUI m => m (Maybe Point)-leaderTgtToPos = do-  lidV <- viewedLevel+-- | The part of speech describing the actor or "you" if a leader+-- of the client's faction. The actor may be not present in the dungeon.+partActorLeader :: MonadClientUI m => ActorId -> ActorUI -> m MU.Part+partActorLeader aid b = do   mleader <- getsClient _sleader-  case mleader of-    Nothing -> return Nothing-    Just aid -> do-      tgt <- getsClient $ getTarget aid-      aidTgtToPos aid lidV tgt+  return $! case mleader of+    Just leader | aid == leader -> "you"+    _ -> partActor b -leaderTgtAims :: MonadClientUI m => m (Either Text Int)-leaderTgtAims = do-  lidV <- viewedLevel+partActorLeaderFun :: MonadClientUI m => m (ActorId -> MU.Part)+partActorLeaderFun = do   mleader <- getsClient _sleader-  case mleader of-    Nothing -> return $ Left "no leader to target with"-    Just aid -> do-      tgt <- getsClient $ getTarget aid-      aidTgtAims aid lidV tgt+  sess <- getSession+  return $! \aid ->+    if mleader == Just aid+    then "you"+    else partActor $ getActorUI aid sess -cursorToPos :: MonadClientUI m => m (Maybe Point)-cursorToPos = do-  lidV <- viewedLevel+-- | The part of speech with the actor's pronoun or "you" if a leader+-- of the client's faction. The actor may be not present in the dungeon.+partPronounLeader :: MonadClient m => ActorId -> ActorUI -> m MU.Part+partPronounLeader aid b = do   mleader <- getsClient _sleader-  scursor <- getsClient scursor-  case mleader of-    Nothing -> return Nothing-    Just aid -> aidTgtToPos aid lidV $ Just scursor+  return $! case mleader of+    Just leader | aid == leader -> "you"+    _ -> partPronoun b++-- | The part of speech describing the actor (designated by actor id+-- and present in the dungeon) or a special name if a leader+-- of the observer's faction.+partAidLeader :: MonadClientUI m => ActorId -> m MU.Part+partAidLeader aid = do+  b <- getsSession $ getActorUI aid+  partActorLeader aid b++tryRestore :: MonadClientUI m => m (Maybe (State, StateClient, Maybe SessionUI))+tryRestore = do+  cops@Kind.COps{corule} <- getsState scops+  bench <- getsClient $ sbenchmark . sdebugCli+  if bench then return Nothing+  else do+    side <- getsClient sside+    prefix <- getsClient $ ssavePrefixCli . sdebugCli+    let fileName = prefix <.> Save.saveNameCli side+    res <- liftIO $ Save.restoreGame cops fileName+    let stdRuleset = Kind.stdRuleset corule+        cfgUIName = rcfgUIName stdRuleset+        content = rcfgUIDefault stdRuleset+    dataDir <- liftIO appDataDir+    liftIO $ tryWriteFile (dataDir </> cfgUIName) content+    return res++leaderSkillsClientUI :: MonadClientUI m => m Ability.Skills+leaderSkillsClientUI = do+  leader <- getLeaderUI+  maxActorSkillsClient leader

+ Game/LambdaHack/Client/UI/Msg.hs view

@@ -0,0 +1,170 @@+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}+-- | Game messages displayed on top of the screen for the player to read.+module Game.LambdaHack.Client.UI.Msg+  ( -- * Msg+    Msg, toMsg, toPrompt+    -- * Report+  , RepMsgN, Report, emptyReport, nullReport, singletonReport+  , snocReport, consReportNoScrub+  , renderReport, findInReport, lastMsgOfReport+    -- * History+  , History, emptyHistory, addReport, lengthHistory+  , lastReportOfHistory, splitReportForHistory, renderHistory+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Data.Binary+import Data.Vector.Binary ()+import qualified Data.Vector.Unboxed as U+import Data.Word (Word32)+import GHC.Generics (Generic)++import Game.LambdaHack.Client.UI.Overlay+import qualified Game.LambdaHack.Common.Color as Color+import Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.RingBuffer as RB+import Game.LambdaHack.Common.Time++-- * UAttrLine++type UAttrLine = U.Vector Word32++uToAttrLine :: UAttrLine -> AttrLine+uToAttrLine v = map Color.AttrCharW32 $ U.toList v++attrLineToU :: AttrLine -> UAttrLine+attrLineToU l = U.fromList $ map Color.attrCharW32 l++-- * Msg++-- | The type of a single game message.+data Msg = Msg+  { msgLine :: !AttrLine  -- ^ the colours and characters of the message+  , msgHist :: !Bool      -- ^ whether message should be recorded in history+  }+  deriving (Show, Eq, Generic)++instance Binary Msg++toMsg :: AttrLine -> Msg+toMsg l = Msg { msgLine = l+              , msgHist = True }++toPrompt :: AttrLine -> Msg+toPrompt l = Msg { msgLine = l+                 , msgHist = False }++-- * Report++data RepMsgN = RepMsgN {repMsg :: !Msg, _repN :: !Int}+  deriving (Show, Generic)++instance Binary RepMsgN++-- | The set of messages, with repetitions, to show at the screen at once.+newtype Report = Report [RepMsgN]+  deriving (Show, Binary)++-- | Empty set of messages.+emptyReport :: Report+emptyReport = Report []++-- | Test if the set of messages is empty.+nullReport :: Report -> Bool+nullReport (Report l) = null l++-- | Construct a singleton set of messages.+singletonReport :: Msg -> Report+singletonReport = snocReport emptyReport++-- | Add a message to the end of report. Deletes old prompt messages.+snocReport :: Report -> Msg -> Report+snocReport (Report !r) y =+  let scrubPrompts = filter (msgHist . repMsg)+  in case scrubPrompts r of+    _ | null $ msgLine y -> Report r+    RepMsgN x n : xns | x == y -> Report $ RepMsgN x (n + 1) : xns+    xns -> Report $ RepMsgN y 1 : xns++-- | Add a message to the end of report. Does not delete old prompt messages+-- nor handle repetitions.+consReportNoScrub :: Msg -> Report -> Report+consReportNoScrub Msg{msgLine=[]} rep = rep+consReportNoScrub y (Report r) = Report $ r ++ [RepMsgN y 1]++-- | Render a report as a (possibly very long) 'AttrLine'.+renderReport :: Report -> AttrLine+renderReport (Report []) = []+renderReport (Report (x : xs)) =+  renderReport (Report xs) <+:> renderRepetition x++renderRepetition :: RepMsgN -> AttrLine+renderRepetition (RepMsgN s 1) = msgLine s+renderRepetition (RepMsgN s n) = msgLine s ++ stringToAL ("<x" ++ show n ++ ">")++findInReport :: (AttrLine -> Bool) -> Report -> Maybe Msg+findInReport f (Report xns) = find (f . msgLine) $ map repMsg xns++lastMsgOfReport :: Report -> (AttrLine, Report)+lastMsgOfReport (Report rep) = case rep of+  [] -> ([], Report [])+  RepMsgN lmsg 1 : repRest -> (msgLine lmsg, Report repRest)+  RepMsgN lmsg n : repRest ->+    let !repMsg = RepMsgN lmsg (n - 1)+    in (msgLine lmsg, Report $ repMsg : repRest)++-- * History++-- | The history of reports. This is a ring buffer of the given length+data History = History !Time !Report !(RB.RingBuffer UAttrLine)+  deriving (Show, Generic)++instance Binary History++-- | Empty history of reports of the given maximal length.+emptyHistory :: Int -> History+emptyHistory size = History timeZero emptyReport $ RB.empty size U.empty++-- | Add a report to history, handling repetitions.+addReport :: History -> Time -> Report -> History+addReport histOld@(History oldT oldRep@(Report h) hRest) !time (Report m') =+  let rep@(Report m) = Report $ filter (msgHist . repMsg) m'+  in if null m then histOld else+    case (reverse m, h) of+      -- This and the previous @==@ almost fully evaluates history.+      (RepMsgN s1 n1 : rs, RepMsgN s2 n2 : hhs) | s1 == s2 ->+        let rephh = Report $ RepMsgN s2 (n1 + n2) : hhs+        in if null rs+           then History oldT rephh hRest+           else let repr = Report $ reverse rs+                    !lU = attrLineToU $ renderTimeReport oldT rephh+                in History time repr $ RB.cons lU hRest+      (_, []) -> History time rep hRest+      _ -> let !lU = attrLineToU $ renderTimeReport oldT oldRep+           in History time rep $ RB.cons lU hRest++renderTimeReport :: Time -> Report -> AttrLine+renderTimeReport !t !r =+  let turns = t `timeFitUp` timeTurn+  in stringToAL (show turns ++ ": ") ++ renderReport r++lengthHistory :: History -> Int+lengthHistory (History _ r rs) = RB.length rs + if nullReport r then 0 else 1++lastReportOfHistory :: History -> Report+lastReportOfHistory (History _ r _) = r++splitReportForHistory :: X -> AttrLine -> [AttrLine]+splitReportForHistory w l =+  let ts = splitAttrLine (w - 1) l+  in case ts of+    [] -> []+    hd : tl -> hd : map ([Color.spaceAttrW32] ++) tl++-- | Render history as many lines of text, wrapping if necessary.+renderHistory :: History -> [AttrLine]+renderHistory (History t r rb) =+  map uToAttrLine (RB.toList rb) ++ [renderTimeReport t r]

− Game/LambdaHack/Client/UI/MsgClient.hs

@@ -1,149 +0,0 @@--- | Client monad for interacting with a human through UI.-module Game.LambdaHack.Client.UI.MsgClient-  ( msgAdd, msgReset, recordHistory-  , SlideOrCmd, failWith, failSlides, failSer, failMsg-  , lookAt, itemOverlay-  ) where--import Control.Applicative-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.Maybe-import Data.Monoid-import Data.Text (Text)-import qualified Data.Text as T-import qualified Game.LambdaHack.Common.Kind as Kind-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.ItemSlot-import Game.LambdaHack.Client.MonadClient hiding (liftIO)-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Client.UI.WidgetClient-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemDescription-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import qualified Game.LambdaHack.Content.TileKind as TK---- | Add a message to the current report.-msgAdd :: MonadClientUI m => Msg -> m ()-msgAdd msg = modifyClient $ \d -> d {sreport = addMsg (sreport d) msg}---- | Wipe out and set a new value for the current report.-msgReset :: MonadClientUI m => Msg -> m ()-msgReset msg = modifyClient $ \d -> d {sreport = singletonReport msg}---- | Store current report in the history and reset report.-recordHistory :: MonadClientUI m => m ()-recordHistory = do-  time <- getsState stime-  StateClient{sreport, shistory} <- getClient-  unless (nullReport sreport) $ do-    msgReset ""-    let nhistory = addReport shistory time sreport-    modifyClient $ \cli -> cli {shistory = nhistory}--type SlideOrCmd a = Either Slideshow a--failWith :: MonadClientUI m => Msg -> m (SlideOrCmd a)-failWith msg = do-  stopPlayBack-  let starMsg = "*" <> msg <> "*"-  assert (not $ T.null msg) $ Left <$> promptToSlideshow starMsg--failSlides :: MonadClientUI m => Slideshow -> m (SlideOrCmd a)-failSlides slides = do-  stopPlayBack-  return $ Left slides--failSer :: MonadClientUI m => ReqFailure -> m (SlideOrCmd a)-failSer = failWith . showReqFailure--failMsg :: MonadClientUI m => Msg -> m Slideshow-failMsg msg = do-  stopPlayBack-  let starMsg = "*" <> msg <> "*"-  assert (not $ T.null msg) $ promptToSlideshow starMsg---- | Produces a textual description of the terrain and items at an already--- explored position. Mute for unknown positions.--- The detailed variant is for use in the targeting mode.-lookAt :: MonadClientUI m-       => Bool       -- ^ detailed?-       -> Text       -- ^ how to start tile description-       -> Bool       -- ^ can be seen right now?-       -> Point      -- ^ position to describe-       -> ActorId    -- ^ the actor that looks-       -> Text       -- ^ an extra sentence to print-       -> m Text-lookAt detailed tilePrefix canSee pos aid msg = do-  cops@Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops-  itemToF <- itemToFullClient-  b <- getsState $ getActorBody aid-  stgtMode <- getsClient stgtMode-  let lidV = maybe (blid b) tgtLevelId stgtMode-  lvl <- getLevel lidV-  localTime <- getsState $ getLocalTime lidV-  subject <- partAidLeader aid-  is <- getsState $ getCBag $ CFloor lidV pos-  let verb = MU.Text $ if pos == bpos b-                       then "stand on"-                       else if canSee then "notice" else "remember"-  let nWs (iid, kit@(k, _)) = partItemWs k CGround localTime (itemToF iid kit)-      isd = case detailed of-              _ | EM.size is == 0 -> ""-              _ | EM.size is <= 2 ->-                makeSentence [ MU.SubjectVerbSg subject verb-                             , MU.WWandW $ map nWs $ EM.assocs is]--- TODO: detailed unused here; disabled together with overlay in doLook              True -> "\n"-              _ -> makeSentence [MU.Cardinal (EM.size is), "items here"]-      tile = lvl `at` pos-      obscured | knownLsecret lvl-                 && tile /= hideTile cops lvl pos = "partially obscured"-               | otherwise = ""-      tileText = obscured <+> TK.tname (okind tile)-      tilePart | T.null tilePrefix = MU.Text tileText-               | otherwise = MU.AW $ MU.Text tileText-      tileDesc = [MU.Text tilePrefix, tilePart]-  if not (null (Tile.causeEffects cotile tile)) then-    return $! makeSentence ("activable:" : tileDesc)-              <+> msg <+> isd-  else if detailed then-    return $! makeSentence tileDesc-              <+> msg <+> isd-  else return $! msg <+> isd---- | Create a list of item names.-itemOverlay :: MonadClient m-            => CStore -> LevelId -> ItemBag -> m Overlay-itemOverlay c lid bag = do-  localTime <- getsState $ getLocalTime lid-  itemToF <- itemToFullClient-  (itemSlots, organSlots) <- getsClient sslots-  let isOrgan = c == COrgan-      lSlots = if isOrgan then organSlots else itemSlots-  let !_A = assert (all (`elem` EM.elems lSlots) (EM.keys bag)-                    `blame` (c, lid, bag, lSlots)) ()-  let pr (l, iid) =-        case EM.lookup iid bag of-          Nothing -> Nothing-          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 c localTime itemFull ]-                      <> "  "-  return $! toOverlay $ mapMaybe pr $ EM.assocs lSlots

+ Game/LambdaHack/Client/UI/MsgM.hs view

@@ -0,0 +1,40 @@+-- | Client monad for interacting with a human through UI.+module Game.LambdaHack.Client.UI.MsgM+  ( msgAdd, promptAdd, promptAddAttr, recordHistory+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Game.LambdaHack.Client.UI.MonadClientUI+import Game.LambdaHack.Client.UI.Msg+import Game.LambdaHack.Client.UI.Overlay+import Game.LambdaHack.Client.UI.SessionUI+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.State++-- | Add a message to the current report.+msgAdd :: MonadClientUI m => Text -> m ()+msgAdd msg = modifySession $ \sess ->+  sess {_sreport = snocReport (_sreport sess) (toMsg $ textToAL msg)}++-- | Add a prompt to the current report.+promptAdd :: MonadClientUI m => Text -> m ()+promptAdd msg = modifySession $ \sess ->+  sess {_sreport = snocReport (_sreport sess) (toPrompt $ textToAL msg)}++-- | Add a prompt to the current report.+promptAddAttr :: MonadClientUI m => AttrLine -> m ()+promptAddAttr msg = modifySession $ \sess ->+  sess {_sreport = snocReport (_sreport sess) (toPrompt msg)}++-- | Store current report in the history and reset report.+recordHistory :: MonadClientUI m => m ()+recordHistory = do+  time <- getsState stime+  SessionUI{_sreport, shistory} <- getSession+  unless (nullReport _sreport) $ do+    let nhistory = addReport shistory time _sreport+    modifySession $ \sess -> sess { _sreport = emptyReport+                                  , shistory = nhistory }

+ Game/LambdaHack/Client/UI/Overlay.hs view

@@ -0,0 +1,228 @@+{-# LANGUAGE RankNTypes #-}+-- | Screen overlays.+module Game.LambdaHack.Client.UI.Overlay+  ( -- * AttrLine+    AttrLine, emptyAttrLine, textToAL, fgToAL, stringToAL+  , (<+:>), splitAttrLine, itemDesc, glueLines, updateLines+    -- * Overlay+  , Overlay+    -- * Misc+  , ColorMode(..)+  , FrameST, FrameForall(..), writeLine+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Control.Monad.ST.Strict+import qualified Data.EnumMap.Strict as EM+import qualified Data.Text as T+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as VM+import Data.Word+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Client.UI.EffectDescription+import Game.LambdaHack.Client.UI.ItemDescription+import qualified Game.LambdaHack.Common.Color as Color+import qualified Game.LambdaHack.Common.Dice as Dice+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.ItemStrongest+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Time+import qualified Game.LambdaHack.Content.ItemKind as IK++-- * AttrLine++type AttrLine = [Color.AttrCharW32]++emptyAttrLine :: Int -> AttrLine+emptyAttrLine xsize = replicate xsize Color.spaceAttrW32++textToAL :: Text -> AttrLine+textToAL !t =+  let f c l = let !ac = Color.attrChar1ToW32 c+              in ac : l+  in T.foldr f [] t++fgToAL :: Color.Color -> Text -> AttrLine+fgToAL !fg !t =+  let f c l = let !ac = Color.attrChar2ToW32 fg c+              in ac : l+  in T.foldr f [] t++stringToAL :: String -> AttrLine+stringToAL = map Color.attrChar1ToW32++infixr 6 <+:>  -- matches Monoid.<>+(<+:>) :: AttrLine -> AttrLine -> AttrLine+(<+:>) [] l2 = l2+(<+:>) l1 [] = l1+(<+:>) l1 l2 = l1 ++ [Color.spaceAttrW32] ++ l2++-- | Split a string into lines. Avoids ending the line with a character+-- other than whitespace or punctuation. Space characters are removed+-- from the start, but never from the end of lines. Newlines are respected.+splitAttrLine :: X -> AttrLine -> [AttrLine]+splitAttrLine w l =+  concatMap (splitAttrPhrase w . dropWhile (== Color.spaceAttrW32))+  $ linesAttr l++linesAttr :: AttrLine -> [AttrLine]+linesAttr l | null l = []+            | otherwise = h : if null t then [] else linesAttr (tail t)+ where (h, t) = span (/= Color.retAttrW32) l++splitAttrPhrase :: X -> AttrLine -> [AttrLine]+splitAttrPhrase w xs+  | w >= length xs = [xs]  -- no problem, everything fits+  | otherwise =+      let (pre, post) = splitAt w xs+          (ppre, ppost) = break (== Color.spaceAttrW32) $ reverse pre+          testPost = dropWhileEnd (== Color.spaceAttrW32) ppost+      in if null testPost+         then pre : splitAttrPhrase w post+         else reverse ppost : splitAttrPhrase w (reverse ppre ++ post)++itemDesc :: FactionId -> FactionDict -> Int -> CStore -> Time -> ItemFull+         -> AttrLine+itemDesc side factionD aHurtMeleeOfOwner store localTime+         itemFull@ItemFull{itemBase} =+  let (_, unique, name, stats) =+        partItemHigh side factionD store localTime itemFull+      nstats = makePhrase [name, stats]+      IK.ThrowMod{IK.throwVelocity, IK.throwLinger} = strengthToThrow itemBase+      speed = speedFromWeight (jweight itemBase) throwVelocity+      range = rangeFromSpeedAndLinger speed throwLinger+      tspeed = "When thrown, it flies with speed of"+               <+> tshow (fromSpeed speed `divUp` 10)+               <> if throwLinger /= 100+                  then " m/s and range" <+> tshow range <+> "m."+                  else " m/s."+      (desc, featureSentences, damageAnalysis) = case itemDisco itemFull of+        Nothing -> ("This item is as unremarkable as can be.", "", tspeed)+        Just ItemDisco{itemKind, itemAspect} ->+          let sentences = mapMaybe featureToSentence (IK.ifeature itemKind)+              hurtMeleeAspect :: IK.Aspect -> Bool+              hurtMeleeAspect IK.AddHurtMelee{} = True+              hurtMeleeAspect _ = False+              aHurtMeleeOfItem = case itemAspect of+                Just aspectRecord -> aHurtMelee aspectRecord+                Nothing -> case find hurtMeleeAspect (IK.iaspects itemKind) of+                  Just (IK.AddHurtMelee d) -> Dice.meanDice d+                  _ -> 0+              meanDmg = Dice.meanDice (jdamage itemBase)+              dmgAn = if meanDmg <= 0 then "" else+                let multRaw = aHurtMeleeOfOwner+                              + if store `elem` [CEqp, COrgan]+                                then 0+                                else aHurtMeleeOfItem+                    mult = 100 + min 99 (max (-99) multRaw)+                    minDeltaHP = xM meanDmg `divUp` 100+                    rawDeltaHP = fromIntegral mult * minDeltaHP+                    pmult = 100 + min 99 (max (-99) aHurtMeleeOfItem)+                    prawDeltaHP = fromIntegral pmult * minDeltaHP+                    pdeltaHP = modifyDamageBySpeed prawDeltaHP speed+                    mDeltaHP = modifyDamageBySpeed minDeltaHP speed+                in "Against defenceless targets you would inflict around"+                     -- rounding and non-id items+                   <+> tshow meanDmg+                   <> "*" <> tshow mult <> "%"+                   <> "=" <> show64With2 rawDeltaHP+                   <+> "melee damage (min" <+> show64With2 minDeltaHP+                   <> ") and"+                   <+> tshow meanDmg+                   <> "*" <> tshow pmult <> "%"+                   <> "*" <> "speed^2"+                   <> "/" <> tshow (fromSpeed speedThrust `divUp` 10) <> "^2"+                   <> "=" <> show64With2 pdeltaHP+                   <+> "ranged damage (min" <+> show64With2 mDeltaHP+                   <> ") with it"+                   <> if Dice.minDice (jdamage itemBase)+                         == Dice.maxDice (jdamage itemBase)+                      then "."+                      else "on average."+          in (IK.idesc itemKind, T.intercalate " " sentences, tspeed <+> dmgAn)+      eqpSlotSentence = case strengthEqpSlot itemFull of+        Just es -> slotToSentence es+        Nothing -> ""+      weight = jweight itemBase+      (scaledWeight, unitWeight)+        | weight > 1000 =+          (tshow $ fromIntegral weight / (1000 :: Double), "kg")+        | otherwise = (tshow weight, "g")+      onLevel = "on level" <+> tshow (abs $ fromEnum $ jlid itemBase) <> "."+      sourceDesc =+        case jfid itemBase of+          Just fid -> "First created"+                      <+> (if fid == side+                           then "by us"+                           else "by" <+> gname (factionD EM.! fid))+                      <+> onLevel+          Nothing -> (if unique then "Discovered" else "First seen")+                     <+> onLevel+      colorSymbol = viewItem itemBase+      blurb =+        " "+        <> nstats+        <> ":"+        <+> desc+        <+> (if weight > 0+             then makeSentence ["Weighs", MU.Text scaledWeight <> unitWeight]+             else "")+        <+> featureSentences+        <+> eqpSlotSentence+        <+> sourceDesc+        <+> damageAnalysis+  in colorSymbol : textToAL blurb++glueLines :: [AttrLine] -> [AttrLine] -> [AttrLine]+glueLines ov1 ov2 = reverse $ glue (reverse ov1) ov2+ where glue [] l = l+       glue m [] = m+       glue (mh : mt) (lh : lt) = reverse lt ++ (mh <+:> lh) : mt++-- @f@ should not enlarge the line beyond screen width.+updateLines :: Int -> (AttrLine -> AttrLine) -> [AttrLine] -> [AttrLine]+updateLines n f ov =+  let upd k (l : ls) = if k == 0+                       then f l : ls+                       else l : upd (k - 1) ls+      upd _ [] = []+  in upd n ov++-- blurb about [AttrLine]:+-- | A series of screen lines that either fit the width of the screen+-- or are intended for truncation when displayed. The length of overlay+-- may exceed the length of the screen, unlike in @SingleFrame@.+-- An exception is lines generated from animation, which have to fit+-- in either dimension.++-- * Overlay++type Overlay = [(Int, AttrLine)]++-- * Misc++-- | Color mode for the display.+data ColorMode =+    ColorFull  -- ^ normal, with full colours+  | ColorBW    -- ^ black+white only+  deriving Eq++type FrameST s = G.Mutable U.Vector s Word32 -> ST s ()++newtype FrameForall = FrameForall {unFrameForall :: forall s. FrameST s}++writeLine :: Int -> AttrLine -> FrameForall+{-# INLINE writeLine #-}+writeLine offset l = FrameForall $ \v -> do+  let writeAt _ [] = return ()+      writeAt off (ac32 : rest) = do+        VM.write v off (Color.attrCharW32 ac32)+        writeAt (off + 1) rest+  writeAt offset l

+ Game/LambdaHack/Client/UI/OverlayM.hs view

@@ -0,0 +1,85 @@+-- | A set of Overlay monad operations.+module Game.LambdaHack.Client.UI.OverlayM+  ( describeMainKeys, lookAt+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.Text as T+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Client.CommonM+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Client.UI.Config+import Game.LambdaHack.Client.UI.ItemDescription+import Game.LambdaHack.Client.UI.MonadClientUI+import Game.LambdaHack.Client.UI.SessionUI+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Content.TileKind as TK++describeMainKeys :: MonadClientUI m => m Text+describeMainKeys = do+  saimMode <- getsSession saimMode+  Config{configVi, configLaptop} <- getsSession sconfig+  xhair <- getsSession sxhair+  let moveKeys | configVi = "keypad or hjklyubn"+               | configLaptop = "keypad or uk8o79jl"+               | otherwise = "keypad"+      keys | isNothing saimMode =+        "Explore with" <+> moveKeys <+> "keys or mouse."+           | otherwise =+        "Aim" <+> tgtKindDescription xhair+        <+> "with" <+> moveKeys <+> "keys or mouse."+  return $! keys++-- | Produces a textual description of the terrain and items at an already+-- explored position. Mute for unknown positions.+-- The detailed variant is for use in the aiming mode.+lookAt :: MonadClientUI m+       => Bool       -- ^ detailed?+       -> Text       -- ^ how to start tile description+       -> Bool       -- ^ can be seen right now?+       -> Point      -- ^ position to describe+       -> ActorId    -- ^ the actor that looks+       -> Text       -- ^ an extra sentence to print+       -> m Text+lookAt detailed tilePrefix canSee pos aid msg = do+  Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops+  itemToF <- itemToFullClient+  b <- getsState $ getActorBody aid+  lidV <- viewedLevelUI+  lvl <- getLevel lidV+  localTime <- getsState $ getLocalTime lidV+  subject <- partAidLeader aid+  is <- getsState $ getFloorBag lidV pos+  side <- getsClient sside+  factionD <- getsState sfactionD+  let verb = MU.Text $ if | pos == bpos b -> "stand on"+                          | canSee -> "notice"+                          | otherwise -> "remember"+  let nWs (iid, kit@(k, _)) =+        partItemWs side factionD k CGround localTime (itemToF iid kit)+      isd = if EM.size is == 0 then ""+            else makeSentence [ MU.SubjectVerbSg subject verb+                              , MU.WWandW $ map nWs $ EM.assocs is]+      tile = lvl `at` pos+      tileText = TK.tname (okind tile)+      tilePart | T.null tilePrefix = MU.Text tileText+               | otherwise = MU.AW $ MU.Text tileText+      tileDesc = [MU.Text tilePrefix, tilePart]+  if | detailed ->+       return $! makeSentence tileDesc <+> msg <+> isd+     | otherwise ->+       return $! msg <+> isd

− Game/LambdaHack/Client/UI/RunClient.hs

@@ -1,238 +0,0 @@-{-# LANGUAGE RankNTypes #-}--- | Running and disturbance.------ The general rule is: whatever is behind you (and so ignored previously),--- determines what you ignore moving forward. This is calcaulated--- separately for the tiles to the left, to the right and in the middle--- along the running direction. So, if you want to ignore something--- start running when you stand on it (or to the right or left, respectively)--- or by entering it (or passing to the right or left, respectively).------ Some things are never ignored, such as: enemies seen, imporant messages--- heard, solid tiles and actors in the way.-module Game.LambdaHack.Client.UI.RunClient-  ( continueRun-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.ByteString.Char8 as BS-import qualified Data.EnumMap.Strict as EM-import Data.Function-import Data.List-import Data.Maybe--import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Vector-import qualified Game.LambdaHack.Content.TileKind as TK---- | Continue running in the given direction.-continueRun :: MonadClient m-            => LevelId -> RunParams-            -> m (Either Msg RequestAnyAbility)-continueRun arena paramOld = case paramOld of-  RunParams{ runMembers = []-           , runStopMsg = Just stopMsg } -> return $ Left stopMsg-  RunParams{ runMembers = []-           , runStopMsg = Nothing } ->-    return $ Left "selected actors no longer there"-  RunParams{ runLeader-           , runMembers = r : rs-           , runInitial-           , runStopMsg } -> do-    -- If runInitial and r == runLeader, it means the leader moves-    -- again, after all other members, in step 0,-    -- so we call continueRunDir with True to change direction once-    -- and then unset runInitial.-    let runInitialNew = runInitial && r /= runLeader-        paramIni = paramOld {runInitial = runInitialNew}-    onLevel <- getsState $ memActor r arena-    onLevelLeader <- getsState $ memActor runLeader arena-    if not onLevel then do-      let paramNew = paramIni {runMembers = rs }-      continueRun arena paramNew-    else if not onLevelLeader then do-      let paramNew = paramIni {runLeader = r}-      continueRun arena paramNew-    else do-      mdirOrRunStopMsgCurrent <- continueRunDir paramOld-      let runStopMsgCurrent =-            either Just (const Nothing) mdirOrRunStopMsgCurrent-          runStopMsgNew = runStopMsg `mplus` runStopMsgCurrent-          -- We check @runStopMsgNew@, because even if the current actor-          -- runs OK, we want to stop soon if some others had to stop.-          runMembersNew = if isJust runStopMsgNew then rs else rs ++ [r]-          paramNew = paramIni { runMembers = runMembersNew-                              , runStopMsg = runStopMsgNew }-      case mdirOrRunStopMsgCurrent of-        Left _ -> continueRun arena paramNew-                    -- run all others undisturbed; one time-        Right dir -> do-          s <- getState-          modifyClient $ updateLeader r s-          modifyClient $ \cli -> cli {srunning = Just paramNew}-          return $ Right $ RequestAnyAbility $ ReqMove dir-      -- The potential invisible actor is hit. War is started without asking.---- | This function implements the actual logic of running. It checks if we--- have to stop running because something interesting cropped up,--- it ajusts the direction given by the vector if we reached--- a corridor's corner (we never change direction except in corridors)--- and it increments the counter of traversed tiles.------ Note that while goto-cursor commands ignore items on the way,--- here we stop wnenever we touch an item. Running is more cautious--- to compensate that the player cannot specify the end-point of running.--- It's also more suited to open, already explored terrain. Goto-cursor--- works better with unknown terrain, e.g., it stops whenever an item--- is spotted, but then ignores the item, leaving it to the player--- to mark the item position as a goal of the next goto.-continueRunDir :: MonadClient m-               => RunParams -> m (Either Msg Vector)-continueRunDir params = case params of-  RunParams{ runMembers = [] } -> assert `failure` params-  RunParams{ runLeader-           , runMembers = aid : _-           , runInitial } -> do-    sreport <- getsClient sreport -- TODO: check the message before it goes into history-    let boringMsgs = map BS.pack [ "You hear a distant"-                                 , "reveals that the" ]-        boring repLine = any (`BS.isInfixOf` repLine) boringMsgs-        -- TODO: use a regexp from the UI config instead-        -- or have symbolic messages and pattern-match-        msgShown  = isJust $ findInReport (not . boring) sreport-    if msgShown then return $ Left "message shown"-    else do-      cops@Kind.COps{cotile} <- getsState scops-      rbody <- getsState $ getActorBody runLeader-      let rposHere = bpos rbody-          rposLast = fromMaybe (assert `failure` (runLeader, rbody))-                               (boldpos rbody)-          -- Match run-leader dir, because we want runners to keep formation.-          dir = rposHere `vectorToFrom` rposLast-      body <- getsState $ getActorBody aid-      let lid = blid body-      lvl <- getLevel lid-      let posHere = bpos body-          posThere = posHere `shift` dir-      actorsThere <- getsState $ posToActors posThere lid-      let openableLast = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir))-          check-            | not $ null actorsThere = return $ Left "actor in the way"-                -- don't displace actors, except with leader in step 0-            | accessibleDir cops lvl posHere dir =-                if runInitial && aid /= runLeader-                then return $ Right dir  -- zeroth step always OK-                else checkAndRun aid dir-            | not (runInitial && aid == runLeader) = return $ Left "blocked"-                -- don't change direction, except in step 1 and by run-leader-            | openableLast = return $ Left "blocked by a closed door"-                -- the player may prefer to open the door-            | otherwise =-                -- Assume turning is permitted, because this is the start-                -- of the run, so the situation is mostly known to the player-                tryTurning aid-      check--tryTurning :: MonadClient m-           => ActorId -> m (Either Msg Vector)-tryTurning aid = do-  cops@Kind.COps{cotile} <- getsState scops-  body <- getsState $ getActorBody aid-  let lid = blid body-  lvl <- getLevel lid-  let posHere = bpos body-      posLast = fromMaybe (assert `failure` (aid, body)) (boldpos body)-      dirLast = posHere `vectorToFrom` posLast-  let openableDir dir = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir))-      dirEnterable dir = accessibleDir cops lvl posHere dir || openableDir dir-      dirNearby dir1 dir2 = euclidDistSqVector dir1 dir2 `elem` [1, 2]-      dirSimilar dir = dirNearby dirLast dir && dirEnterable dir-      dirsSimilar = filter dirSimilar moves-  case dirsSimilar of-    [] -> return $ Left "dead end"-    d1 : ds | all (dirNearby d1) ds ->  -- only one or two directions possible-      case sortBy (compare `on` euclidDistSqVector dirLast)-           $ filter (accessibleDir cops lvl posHere) $ d1 : ds of-        [] ->-          return $ Left "blocked and all similar directions are closed doors"-        d : _ -> checkAndRun aid d-    _ -> return $ Left "blocked and many distant similar directions found"---- The direction is different than the original, if called from @tryTurning@--- and the same if from @continueRunDir@.-checkAndRun :: MonadClient m-            => ActorId -> Vector -> m (Either Msg Vector)-checkAndRun aid dir = do-  Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops-  body <- getsState $ getActorBody aid-  smarkSuspect <- getsClient smarkSuspect-  let lid = blid body-  lvl <- getLevel lid-  let posHere = bpos body-      posHasItems pos = EM.member pos $ lfloor lvl-      posThere = posHere `shift` dir-  actorsThere <- getsState $ posToActors posThere lid-  let posLast = fromMaybe (assert `failure` (aid, body)) (boldpos body)-      dirLast = posHere `vectorToFrom` posLast-      -- This is supposed to work on unit vectors --- diagonal, as well as,-      -- vertical and horizontal.-      anglePos :: Point -> Vector -> RadianAngle -> Point-      anglePos pos d angle = shift pos (rotate angle d)-      -- We assume the tiles have not changes since last running step.-      -- If they did, we don't care --- running should be stopped-      -- because of the change of nearby tiles then (TODO).-      -- We don't take into account the two tiles at the rear of last-      -- surroundings, because the actor may have come from there-      -- (via a diagonal move) and if so, he may be interested in such tiles.-      -- If he arrived directly from the right or left, he is responsible-      -- for starting the run further away, if he does not want to ignore-      -- such tiles as the ones he came from.-      tileLast = lvl `at` posLast-      tileHere = lvl `at` posHere-      tileThere = lvl `at` posThere-      leftPsLast = map (anglePos posHere dirLast) [pi/2, 3*pi/4]-                   ++ map (anglePos posHere dir) [pi/2, 3*pi/4]-      rightPsLast = map (anglePos posHere dirLast) [-pi/2, -3*pi/4]-                    ++ map (anglePos posHere dir) [-pi/2, -3*pi/4]-      leftForwardPosHere = anglePos posHere dir (pi/4)-      rightForwardPosHere = anglePos posHere dir (-pi/4)-      leftTilesLast = map (lvl `at`) leftPsLast-      rightTilesLast = map (lvl `at`) rightPsLast-      leftForwardTileHere = lvl `at` leftForwardPosHere-      rightForwardTileHere = lvl `at` rightForwardPosHere-      featAt = TK.actionFeatures smarkSuspect . okind-      terrainChangeMiddle = null (Tile.causeEffects cotile tileThere)-                              -- step into; will stop next turn due to message-                            && featAt tileThere-                               `notElem` map featAt [tileLast, tileHere]-      terrainChangeLeft = featAt leftForwardTileHere-                          `notElem` map featAt leftTilesLast-      terrainChangeRight = featAt rightForwardTileHere-                           `notElem` map featAt rightTilesLast-      itemChangeLeft = posHasItems leftForwardPosHere-                       `notElem` map posHasItems leftPsLast-      itemChangeRight = posHasItems rightForwardPosHere-                        `notElem` map posHasItems rightPsLast-      check-        | not $ null actorsThere = return $ Left "actor in the way"-            -- Actor in possibly another direction tnan original.-            -- (e.g., called from @tryTurning@).-        | terrainChangeLeft = return $ Left "terrain change on the left"-        | terrainChangeRight = return $ Left "terrain change on the right"-        | itemChangeLeft = return $ Left "item change on the left"-        | itemChangeRight = return $ Left "item change on the right"-        | terrainChangeMiddle = return $ Left "terrain change in the middle"-        | otherwise = return $ Right dir-  check

+ Game/LambdaHack/Client/UI/RunM.hs view

@@ -0,0 +1,244 @@+{-# LANGUAGE RankNTypes #-}+-- | Running and disturbance.+--+-- The general rule is: whatever is behind you (and so ignored previously),+-- determines what you ignore moving forward. This is calcaulated+-- separately for the tiles to the left, to the right and in the middle+-- along the running direction. So, if you want to ignore something+-- start running when you stand on it (or to the right or left, respectively)+-- or by entering it (or passing to the right or left, respectively).+--+-- Some things are never ignored, such as: enemies seen, imporant messages+-- heard, solid tiles and actors in the way.+module Game.LambdaHack.Client.UI.RunM+  ( continueRun+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.EnumMap.Strict as EM+import Data.Function++import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Client.UI.MonadClientUI+import Game.LambdaHack.Client.UI.Msg+import Game.LambdaHack.Client.UI.Overlay+import Game.LambdaHack.Client.UI.SessionUI+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+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.TileKind as TK++-- | Continue running in the given direction.+continueRun :: MonadClientUI m+            => LevelId -> RunParams+            -> m (Either Text RequestAnyAbility)+continueRun arena paramOld = case paramOld of+  RunParams{ runMembers = []+           , runStopMsg = Just stopMsg } -> return $ Left stopMsg+  RunParams{ runMembers = []+           , runStopMsg = Nothing } ->+    return $ Left "selected actors no longer there"+  RunParams{ runLeader+           , runMembers = r : rs+           , runInitial+           , runStopMsg } -> do+    -- If runInitial and r == runLeader, it means the leader moves+    -- again, after all other members, in step 0,+    -- so we call continueRunDir with True to change direction once+    -- and then unset runInitial.+    let runInitialNew = runInitial && r /= runLeader+        paramIni = paramOld {runInitial = runInitialNew}+    onLevel <- getsState $ memActor r arena+    onLevelLeader <- getsState $ memActor runLeader arena+    if | not onLevel -> do+         let paramNew = paramIni {runMembers = rs }+         continueRun arena paramNew+       | not onLevelLeader -> do+         let paramNew = paramIni {runLeader = r}+         continueRun arena paramNew+       | otherwise -> do+         mdirOrRunStopMsgCurrent <- continueRunDir paramOld+         let runStopMsgCurrent =+               either Just (const Nothing) mdirOrRunStopMsgCurrent+             runStopMsgNew = runStopMsg `mplus` runStopMsgCurrent+             -- We check @runStopMsgNew@, because even if the current actor+             -- runs OK, we want to stop soon if some others had to stop.+             runMembersNew = if isJust runStopMsgNew then rs else rs ++ [r]+             paramNew = paramIni { runMembers = runMembersNew+                                 , runStopMsg = runStopMsgNew }+         case mdirOrRunStopMsgCurrent of+           Left _ -> continueRun arena paramNew+                       -- run all others undisturbed; one time+           Right dir -> do+             s <- getState+             modifyClient $ updateLeader r s+             modifySession $ \sess -> sess {srunning = Just paramNew}+             return $ Right $ RequestAnyAbility $ ReqMove dir+         -- The potential invisible actor is hit. War is started without asking.++-- | This function implements the actual logic of running. It checks if we+-- have to stop running because something interesting cropped up,+-- it ajusts the direction given by the vector if we reached+-- a corridor's corner (we never change direction except in corridors)+-- and it increments the counter of traversed tiles.+--+-- Note that while goto-xhair commands ignore items on the way,+-- here we stop wnenever we touch an item. Running is more cautious+-- to compensate that the player cannot specify the end-point of running.+-- It's also more suited to open, already explored terrain. Goto-xhair+-- works better with unknown terrain, e.g., it stops whenever an item+-- is spotted, but then ignores the item, leaving it to the player+-- to mark the item position as a goal of the next goto.+continueRunDir :: MonadClientUI m+               => RunParams -> m (Either Text Vector)+continueRunDir params = case params of+  RunParams{ runMembers = [] } -> assert `failure` params+  RunParams{ runLeader+           , runMembers = aid : _+           , runInitial } -> do+    report <- getsSession _sreport+    let boringMsgs = map stringToAL+          [ "You hear a distant"+          , "reveals that the"+          , "Macro will be recorded"+          , "Macro activated"+          , "Voicing '" ]+        boring l = any (`isInfixOf` l) boringMsgs+        msgShown = isJust $ findInReport (not . boring) report+    if msgShown then return $ Left "message shown"+    else do+      cops@Kind.COps{cotile} <- getsState scops+      rbody <- getsState $ getActorBody runLeader+      let rposHere = bpos rbody+          rposLast = fromMaybe (assert `failure` (runLeader, rbody))+                               (boldpos rbody)+          -- Match run-leader dir, because we want runners to keep formation.+          dir = rposHere `vectorToFrom` rposLast+      body <- getsState $ getActorBody aid+      let lid = blid body+      lvl <- getLevel lid+      let posHere = bpos body+          posThere = posHere `shift` dir+          actorsThere = posToAidsLvl posThere lvl+      let openableLast = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir))+          check+            | not $ null actorsThere = return $ Left "actor in the way"+                -- don't displace actors, except with leader in step 0+            | enterableDir cops lvl posHere dir =+                if runInitial && aid /= runLeader+                then return $ Right dir  -- zeroth step always OK+                else checkAndRun aid dir+            | not (runInitial && aid == runLeader) = return $ Left "blocked"+                -- don't change direction, except in step 1 and by run-leader+            | openableLast = return $ Left "blocked by a closed door"+                -- the player may prefer to open the door+            | otherwise =+                -- Assume turning is permitted, because this is the start+                -- of the run, so the situation is mostly known to the player+                tryTurning aid+      check++enterableDir :: Kind.COps -> Level -> Point -> Vector -> Bool+enterableDir Kind.COps{coTileSpeedup} lvl spos dir =+  Tile.isWalkable coTileSpeedup $ lvl `at` (spos `shift` dir)++tryTurning :: MonadClient m+           => ActorId -> m (Either Text Vector)+tryTurning aid = do+  cops@Kind.COps{cotile} <- getsState scops+  body <- getsState $ getActorBody aid+  let lid = blid body+  lvl <- getLevel lid+  let posHere = bpos body+      posLast = fromMaybe (assert `failure` (aid, body)) (boldpos body)+      dirLast = posHere `vectorToFrom` posLast+  let openableDir dir = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir))+      dirEnterable dir = enterableDir cops lvl posHere dir || openableDir dir+      dirNearby dir1 dir2 = euclidDistSqVector dir1 dir2 `elem` [1, 2]+      dirSimilar dir = dirNearby dirLast dir && dirEnterable dir+      dirsSimilar = filter dirSimilar moves+  case dirsSimilar of+    [] -> return $ Left "dead end"+    d1 : ds | all (dirNearby d1) ds ->  -- only one or two directions possible+      case sortBy (compare `on` euclidDistSqVector dirLast)+           $ filter (enterableDir cops lvl posHere) $ d1 : ds of+        [] ->+          return $ Left "blocked and all similar directions are closed doors"+        d : _ -> checkAndRun aid d+    _ -> return $ Left "blocked and many distant similar directions found"++-- The direction is different than the original, if called from @tryTurning@+-- and the same if from @continueRunDir@.+checkAndRun :: MonadClient m+            => ActorId -> Vector -> m (Either Text Vector)+checkAndRun aid dir = do+  Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops+  body <- getsState $ getActorBody aid+  smarkSuspect <- getsClient smarkSuspect+  let lid = blid body+  lvl <- getLevel lid+  let posHere = bpos body+      posHasItems pos = EM.member pos $ lfloor lvl+      posThere = posHere `shift` dir+      actorsThere = posToAidsLvl posThere lvl+  let posLast = fromMaybe (assert `failure` (aid, body)) (boldpos body)+      dirLast = posHere `vectorToFrom` posLast+      -- This is supposed to work on unit vectors --- diagonal, as well as,+      -- vertical and horizontal.+      anglePos :: Point -> Vector -> RadianAngle -> Point+      anglePos pos d angle = shift pos (rotate angle d)+      -- We assume the tiles have not changed since last running step.+      -- If they did, we don't care --- running should be stopped+      -- because of the change of nearby tiles then.+      -- We don't take into account the two tiles at the rear of last+      -- surroundings, because the actor may have come from there+      -- (via a diagonal move) and if so, he may be interested in such tiles.+      -- If he arrived directly from the right or left, he is responsible+      -- for starting the run further away, if he does not want to ignore+      -- such tiles as the ones he came from.+      tileLast = lvl `at` posLast+      tileHere = lvl `at` posHere+      tileThere = lvl `at` posThere+      leftPsLast = map (anglePos posHere dirLast) [pi/2, 3*pi/4]+                   ++ map (anglePos posHere dir) [pi/2, 3*pi/4]+      rightPsLast = map (anglePos posHere dirLast) [-pi/2, -3*pi/4]+                    ++ map (anglePos posHere dir) [-pi/2, -3*pi/4]+      leftForwardPosHere = anglePos posHere dir (pi/4)+      rightForwardPosHere = anglePos posHere dir (-pi/4)+      leftTilesLast = map (lvl `at`) leftPsLast+      rightTilesLast = map (lvl `at`) rightPsLast+      leftForwardTileHere = lvl `at` leftForwardPosHere+      rightForwardTileHere = lvl `at` rightForwardPosHere+      featAt = TK.actionFeatures (smarkSuspect > 0) . okind+      terrainChangeMiddle =+        featAt tileThere `notElem` map featAt [tileLast, tileHere]+      terrainChangeLeft = featAt leftForwardTileHere+                          `notElem` map featAt leftTilesLast+      terrainChangeRight = featAt rightForwardTileHere+                           `notElem` map featAt rightTilesLast+      itemChangeLeft = posHasItems leftForwardPosHere+                       `notElem` map posHasItems leftPsLast+      itemChangeRight = posHasItems rightForwardPosHere+                        `notElem` map posHasItems rightPsLast+      check+        | not $ null actorsThere = return $ Left "actor in the way"+            -- Actor in possibly another direction tnan original.+            -- (e.g., called from @tryTurning@).+        | terrainChangeLeft = return $ Left "terrain change on the left"+        | terrainChangeRight = return $ Left "terrain change on the right"+        | itemChangeLeft = return $ Left "item change on the left"+        | itemChangeRight = return $ Left "item change on the right"+        | terrainChangeMiddle = return $ Left "terrain change in the middle"+        | otherwise = return $ Right dir+  check

+ Game/LambdaHack/Client/UI/SessionUI.hs view

@@ -0,0 +1,210 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | The client UI session state.+module Game.LambdaHack.Client.UI.SessionUI+  ( SessionUI(..), emptySessionUI+  , AimMode(..), RunParams(..), LastRecord, KeysHintMode(..)+  , toggleMarkVision, toggleMarkSmell, getActorUI+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Data.Binary+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.Map.Strict as M+import Data.Time.Clock.POSIX++import Game.LambdaHack.Client.UI.ActorUI+import Game.LambdaHack.Client.UI.Config+import Game.LambdaHack.Client.UI.Frontend+import Game.LambdaHack.Client.UI.ItemSlot+import qualified Game.LambdaHack.Client.UI.Key as K+import Game.LambdaHack.Client.UI.KeyBindings+import Game.LambdaHack.Client.UI.Msg+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Vector++-- | The information that is used across a client playing session,+-- including many consecutive games in a single session.+-- Some of it is saved, some is reset when a new playing session starts.+-- An important component is a frontend session.+data SessionUI = SessionUI+  { sxhair         :: !Target             -- ^ the common xhair+  , sactorUI       :: !ActorDictUI        -- ^ assigned actor UI presentations+  , sslots         :: !ItemSlots          -- ^ map from slots to items+  , slastSlot      :: !SlotChar           -- ^ last used slot+  , schanF         :: !ChanFrontend       -- ^ connection with the frontend+  , sbinding       :: !Binding            -- ^ binding of keys to commands+  , sconfig        :: !Config+  , saimMode       :: !(Maybe AimMode)    -- ^ aiming mode+  , sxhairMoused   :: !Bool               -- ^ last mouse aiming not vacuus+  , sitemSel       :: !(Maybe (CStore, ItemId))  -- ^ selected item, if any+  , sselected      :: !(ES.EnumSet ActorId)+                                      -- ^ the set of currently selected actors+  , srunning       :: !(Maybe RunParams)+                                      -- ^ parameters of the current run, if any+  , _sreport       :: !Report        -- ^ current messages+  , shistory       :: !History       -- ^ history of messages+  , spointer       :: !Point         -- ^ mouse pointer position+  , 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+  , smarkVision    :: !Bool          -- ^ mark leader and party FOV+  , smarkSmell     :: !Bool          -- ^ mark smell, if the leader can smell+  , smenuIxMap     :: !(M.Map String Int)+                                     -- ^ indices of last used menu items+  , sdisplayNeeded :: !Bool          -- ^ something to display on current level+  , skeysHintMode  :: !KeysHintMode  -- ^ how to show keys hints when no messages+  , sstart         :: !POSIXTime     -- ^ this session start time+  , sgstart        :: !POSIXTime     -- ^ this game start time+  , sallTime       :: !Time          -- ^ clips from start of session to current game start+  , snframes       :: !Int           -- ^ this game current frame count+  , sallNframes    :: !Int           -- ^ frame count from start of session to current game start+  }++-- | Current aiming mode of a client.+newtype AimMode = AimMode { aimLevelId :: LevelId }+  deriving (Show, Eq, Binary)++-- | Parameters of the current run.+data RunParams = RunParams+  { runLeader  :: !ActorId         -- ^ the original leader from run start+  , runMembers :: ![ActorId]       -- ^ the list of actors that take part+  , runInitial :: !Bool            -- ^ initial run continuation by any+                                   --   run participant, including run leader+  , runStopMsg :: !(Maybe Text)    -- ^ message with the next stop reason+  , runWaiting :: !Int             -- ^ waiting for others to move out of the way+  }+  deriving (Show)++type LastRecord = ( [K.KM]  -- accumulated keys of the current command+                  , [K.KM]  -- keys of the rest of the recorded command batch+                  , Int     -- commands left to record for this batch+                  )++data KeysHintMode =+    KeysHintBlocked+  | KeysHintAbsent+  | KeysHintPresent+  deriving (Eq, Enum, Bounded)++-- | Initial empty game client state.+emptySessionUI :: Config -> SessionUI+emptySessionUI sconfig =+  SessionUI+    { sxhair = TVector $ Vector 0 0+    , sactorUI = EM.empty+    , sslots = ItemSlots EM.empty EM.empty+    , slastSlot = SlotChar 0 'Z'+    , schanF = ChanFrontend $ const $+        assert `failure` ("emptySessionUI: ChanFrontend " :: String)+    , sbinding = Binding M.empty [] M.empty+    , sconfig+    , saimMode = Nothing+    , sxhairMoused = True+    , sitemSel = Nothing+    , sselected = ES.empty+    , srunning = Nothing+    , _sreport = emptyReport+    , shistory = emptyHistory 0+    , spointer = originPoint+    , slastRecord = ([], [], 0)+    , slastPlay = []+    , slastLost = ES.empty+    , swaitTimes = 0+    , smarkVision = False+    , smarkSmell = True+    , smenuIxMap = M.singleton "main" 2+    , sdisplayNeeded = False+    , skeysHintMode = KeysHintPresent+    , sstart = 0+    , sgstart = 0+    , sallTime = timeZero+    , snframes = 0+    , sallNframes = 0+    }++toggleMarkVision :: SessionUI -> SessionUI+toggleMarkVision s@SessionUI{smarkVision} = s {smarkVision = not smarkVision}++toggleMarkSmell :: SessionUI -> SessionUI+toggleMarkSmell s@SessionUI{smarkSmell} = s {smarkSmell = not smarkSmell}++getActorUI :: ActorId -> SessionUI -> ActorUI+getActorUI aid sess =+  EM.findWithDefault (assert `failure` (aid, sactorUI sess)) aid+  $ sactorUI sess++instance Binary SessionUI where+  put SessionUI{..} = do+    put sxhair+    put sactorUI+    put sslots+    put slastSlot+    put sconfig+    put saimMode+    put sitemSel+    put sselected+    put srunning+    put _sreport+    put shistory+    put smarkVision+    put smarkSmell+    put sdisplayNeeded+  get = do+    sxhair <- get+    sactorUI <- get+    sslots <- get+    slastSlot <- get+    sconfig <- get  -- is overwritten ASAP, but useful for, e.g., crash debug+    saimMode <- get+    sitemSel <- get+    sselected <- get+    srunning <- get+    _sreport <- get+    shistory <- get+    smarkVision <- get+    smarkSmell <- get+    sdisplayNeeded <- get+    let schanF = ChanFrontend $ const $+          assert `failure` ("Binary: ChanFrontend" :: String)+        sbinding = Binding M.empty [] M.empty+        sxhairMoused = True+        spointer = originPoint+        slastRecord = ([], [], 0)+        slastPlay = []+        slastLost = ES.empty+        swaitTimes = 0+        smenuIxMap = M.singleton "main" 7+        skeysHintMode = KeysHintAbsent+        sstart = 0+        sgstart = 0+        sallTime = timeZero+        snframes = 0+        sallNframes = 0+    return $! SessionUI{..}++instance Binary RunParams where+  put RunParams{..} = do+    put runLeader+    put runMembers+    put runInitial+    put runStopMsg+    put runWaiting+  get = do+    runLeader <- get+    runMembers <- get+    runInitial <- get+    runStopMsg <- get+    runWaiting <- get+    return $! RunParams{..}

+ Game/LambdaHack/Client/UI/Slideshow.hs view

@@ -0,0 +1,120 @@+-- | Slideshows.+module Game.LambdaHack.Client.UI.Slideshow+  ( KYX, OKX, Slideshow(slideshow)+  , emptySlideshow, unsnoc, toSlideshow, menuToSlideshow+  , wrapOKX, splitOverlay, splitOKX+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Game.LambdaHack.Client.UI.ItemSlot+import qualified Game.LambdaHack.Client.UI.Key as K+import Game.LambdaHack.Client.UI.Msg+import Game.LambdaHack.Client.UI.Overlay+import qualified Game.LambdaHack.Common.Color as Color+import Game.LambdaHack.Common.Point++type KYX = (Either [K.KM] SlotChar, (Y, X, X))++type OKX = ([AttrLine], [KYX])++-- May be empty, but both of each @OKX@ list have to be nonempty.+-- Guaranteed by construction.+newtype Slideshow = Slideshow {slideshow :: [OKX]}+  deriving (Show, Eq)++emptySlideshow :: Slideshow+emptySlideshow = Slideshow []++unsnoc :: Slideshow -> Maybe (Slideshow, OKX)+unsnoc Slideshow{slideshow} =+  case reverse slideshow of+    [] -> Nothing+    okx : rest -> Just (Slideshow $ reverse rest, okx)++toSlideshow :: [OKX] -> Slideshow+toSlideshow okxs = Slideshow $ addFooters False okxs+ where+  addFooters _ [] = assert `failure` okxs+  addFooters _ [(als, [])] =+    [( als ++ [stringToAL endMsg]+     , [(Left [K.safeSpaceKM], (length als, 0, 15))] )]+  addFooters False [(als, kxs)] = [(als, kxs)]+  addFooters True [(als, kxs)] =+    [( als ++ [stringToAL endMsg]+     , kxs ++ [(Left [K.safeSpaceKM], (length als, 0, 15))] )]+  addFooters _ ((als, kxs) : rest) =+    ( als ++ [stringToAL moreMsg]+    , kxs ++ [(Left [K.safeSpaceKM], (length als, 0, 8))] )+    : addFooters True rest++moreMsg :: String+moreMsg = "--more--  "++endMsg :: String+endMsg = "--back to top--  "++menuToSlideshow :: OKX -> Slideshow+menuToSlideshow (als, kxs) =+  assert (not (null als || null kxs)) $ Slideshow [(als, kxs)]++wrapOKX :: Y -> X -> X -> [(K.KM, String)] -> OKX+wrapOKX ystart xstart xBound ks =+  let f ((y, x), (kL, kV, kX)) (key, s) =+        let len = length s+        in if x + len > xBound+           then f ((y + 1, 0), ([], kL : kV, kX)) (key, s)+           else ( (y, x + len + 1)+                , (s : kL, kV, (Left [key], (y, x, x + len)) : kX) )+      (kL1, kV1, kX1) = snd $ foldl' f ((ystart, xstart), ([], [], [])) ks+      catL = stringToAL . intercalate " " . reverse+  in (reverse $ map catL $ kL1 : kV1, reverse kX1)++keysOKX :: Y -> X -> X -> [K.KM] -> OKX+keysOKX ystart xstart xBound keys =+  let wrapB :: String -> String+      wrapB s = "[" ++ s ++ "]"+      ks = map (\key -> (key, wrapB $ K.showKM key)) keys+  in wrapOKX ystart xstart xBound ks++splitOverlay :: X -> Y -> Report -> [K.KM] -> OKX -> Slideshow+splitOverlay lxsize yspace report keys (ls0, kxs0) =+  toSlideshow $ splitOKX lxsize yspace (renderReport report) keys (ls0, kxs0)++splitOKX :: X -> Y -> AttrLine -> [K.KM] -> OKX -> [OKX]+splitOKX lxsize yspace rrep keys (ls0, kxs0) =+  assert (yspace > 2) $  -- and kxs0 is sorted+  let msgRaw = splitAttrLine lxsize rrep+      (lX0, keysX0) = keysOKX 0 0 maxBound keys+      (lX, keysX) | null msgRaw = (lX0, keysX0)+                  | otherwise = keysOKX (length msgRaw - 1)+                                        (length (last msgRaw) + 1)+                                        lxsize keys+      msgOkx = (glueLines msgRaw lX, keysX)+      ((lsInit, kxsInit), (header, rkxs)) =+        -- Check whether most space taken by report and keys.+        if length (glueLines msgRaw lX0) * 2 > yspace+        then (msgOkx, ( [intercalate [Color.spaceAttrW32] lX0 <+:> rrep]+                      , keysX0 ))+               -- will display "$" (unless has EOLs)+        else (([], []), msgOkx)+      renumber y (km, (y0, x1, x2)) = (km, (y0 + y, x1, x2))+      splitO yoffset (hdr, rk) (ls, kxs) =+        let zipRenumber = map $ renumber $ length hdr - yoffset+            (pre, post) = splitAt (yspace - 1) $ hdr ++ ls+            yoffsetNew = yoffset + yspace - length hdr - 1+        in if null post+           then [(pre, rk ++ zipRenumber kxs)]  -- all fits on one screen+           else let (preX, postX) =+                      break (\(_, (y1, _, _)) -> y1 >= yoffsetNew) kxs+                in (pre, rk ++ zipRenumber preX)+                   : splitO yoffsetNew (hdr, rk) (post, postX)+      initSlides = if null lsInit+                   then assert (null kxsInit) []+                   else splitO 0 ([], []) (lsInit, kxsInit)+      mainSlides = if null ls0 && not (null lsInit)+                   then assert (null kxs0) []+                   else splitO 0 (header, rkxs) (ls0, kxs0)+  in initSlides ++ mainSlides

+ Game/LambdaHack/Client/UI/SlideshowM.hs view

@@ -0,0 +1,198 @@+-- | A set of Slideshow monad operations.+module Game.LambdaHack.Client.UI.SlideshowM+  ( overlayToSlideshow, reportToSlideshow, reportToSlideshowKeep+  , displaySpaceEsc, displayMore, displayMoreKeep, displayYesNo, getConfirms+  , displayChoiceScreen+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Game.LambdaHack.Client.UI.FrameM+import Game.LambdaHack.Client.UI.ItemSlot+import qualified Game.LambdaHack.Client.UI.Key as K+import Game.LambdaHack.Client.UI.MonadClientUI+import Game.LambdaHack.Client.UI.MsgM+import Game.LambdaHack.Client.UI.Overlay+import Game.LambdaHack.Client.UI.SessionUI+import Game.LambdaHack.Client.UI.Slideshow+import qualified Game.LambdaHack.Common.Color as Color+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Point++-- | Add current report to the overlay, split the result and produce,+-- possibly, many slides.+overlayToSlideshow :: MonadClientUI m => Y -> [K.KM] -> OKX -> m Slideshow+overlayToSlideshow y keys okx = do+  lidV <- viewedLevelUI+  Level{lxsize} <- getLevel lidV+  report <- getReportUI+  recordHistory  -- report will be shown soon, remove it to history+  return $! splitOverlay lxsize y report keys okx++-- | Split current report into a slideshow.+reportToSlideshow :: MonadClientUI m => [K.KM] -> m Slideshow+reportToSlideshow keys = do+  lidV <- viewedLevelUI+  Level{lysize} <- getLevel lidV+  overlayToSlideshow (lysize + 1) keys ([], [])++-- | Split current report into a slideshow. Keep report unchanged.+reportToSlideshowKeep :: MonadClientUI m => [K.KM] -> m Slideshow+reportToSlideshowKeep keys = do+  lidV <- viewedLevelUI+  Level{lxsize, lysize} <- getLevel lidV+  report <- getReportUI+  -- Don't do @recordHistory@; the message is important, but related+  -- to the messages that come after, so should be shown together.+  return $! splitOverlay lxsize (lysize + 1) report keys ([], [])++-- | Display a message. Return value indicates if the player wants to continue.+-- Feature: if many pages, only the last SPACE exits (but first ESC).+displaySpaceEsc :: MonadClientUI m => ColorMode -> Text -> m Bool+displaySpaceEsc dm prompt = do+  promptAdd prompt+  -- Two frames drawn total (unless @prompt@ very long).+  slides <- reportToSlideshow [K.spaceKM, K.escKM]+  km <- getConfirms dm [K.spaceKM, K.escKM] slides+  return $! km == K.spaceKM++-- | Display a message. Ignore keypresses.+-- Feature: if many pages, only the last SPACE exits (but first ESC).+displayMore :: MonadClientUI m => ColorMode -> Text -> m ()+displayMore dm prompt = do+  promptAdd prompt+  slides <- reportToSlideshow [K.spaceKM]+  void $ getConfirms dm [K.spaceKM, K.escKM] slides++displayMoreKeep :: MonadClientUI m => ColorMode -> Text -> m ()+displayMoreKeep dm prompt = do+  promptAdd prompt+  slides <- reportToSlideshowKeep [K.spaceKM]+  void $ getConfirms dm [K.spaceKM, K.escKM] slides++-- | Print a yes/no question and return the player's answer. Use black+-- and white colours to turn player's attention to the choice.+displayYesNo :: MonadClientUI m => ColorMode -> Text -> m Bool+displayYesNo dm prompt = do+  promptAdd prompt+  let yn = map K.mkChar ['y', 'n']+  slides <- reportToSlideshow yn+  km <- getConfirms dm (K.escKM : yn) slides+  return $! km == K.mkChar 'y'++getConfirms :: MonadClientUI m+            => ColorMode -> [K.KM] -> Slideshow -> m K.KM+getConfirms dm extraKeys slides = do+  (ekm, _) <- displayChoiceScreen dm False 0 slides extraKeys+  return $! either id (assert `failure` ekm) ekm++-- This is the only source of menus and so, effectively, UI modes.+displayChoiceScreen :: forall m . MonadClientUI m+                    => ColorMode -> Bool -> Int -> Slideshow -> [K.KM]+                    -> m (Either K.KM SlotChar, Int)+displayChoiceScreen dm sfBlank pointer0 frsX extraKeys = do+  let frs = slideshow frsX+      keys = concatMap (concatMap (either id (const []) . fst) . snd) frs+             ++ extraKeys+      !_A = assert (K.escKM `elem` extraKeys) ()+      navigationKeys = [ K.leftButtonReleaseKM, K.rightButtonReleaseKM+                       , K.returnKM, K.spaceKM+                       , K.upKM, K.leftKM, K.downKM, K.rightKM+                       , K.pgupKM, K.pgdnKM, K.wheelNorthKM, K.wheelSouthKM+                       , K.homeKM, K.endKM ]+      legalKeys = keys ++ navigationKeys+      -- The arguments go from first menu line and menu page to the last,+      -- in order. Their indexing is from 0. We select the nearest item+      -- with the index equal or less to the pointer.+      findKYX :: Int -> [OKX] -> Maybe (OKX, KYX, Int)+      findKYX _ [] = Nothing+      findKYX pointer (okx@(_, kyxs) : frs2) =+        case drop pointer kyxs of+          [] ->  -- not enough menu items on this page+            case findKYX (pointer - length kyxs) frs2 of+              Nothing ->  -- no more menu items in later pages+                case reverse kyxs of+                  [] -> Nothing+                  kyx : _ -> Just (okx, kyx, length kyxs - 1)+              res -> res+          kyx : _ -> Just (okx, kyx, pointer)+      maxIx = length (concatMap snd frs) - 1+      page :: Int -> m (Either K.KM SlotChar, Int)+      page pointer = assert (pointer >= 0) $ case findKYX pointer frs of+        Nothing -> assert `failure` "no menu keys" `twith` frs+        Just ((ov, kyxs), (ekm, (y, x1, x2)), ixOnPage) -> do+          let highableAttrs =+                [Color.defAttr, Color.defAttr {Color.fg = Color.BrBlack}]+              highAttr x | Color.acAttr x `notElem` highableAttrs = x+              highAttr x = x {Color.acAttr =+                                (Color.acAttr x) {Color.fg = Color.BrWhite}}+              drawHighlight xs =+                let (xs1, xsRest) = splitAt x1 xs+                    (xs2, xs3) = splitAt (x2 - x1) xsRest+                    highW32 = Color.attrCharToW32+                              . highAttr+                              . Color.attrCharFromW32+                in xs1 ++ map highW32 xs2 ++ xs3+              ov1 = updateLines y drawHighlight ov+              ignoreKey = page pointer+              pageLen = length kyxs+              xix (_, (_, x1', _)) = x1' == x1+              interpretKey :: K.KM -> m (Either K.KM SlotChar, Int)+              interpretKey ikm =+                case K.key ikm of+                  K.Return | ekm /= Left [K.returnKM] -> case ekm of+                    Left (km : _) -> interpretKey km+                    Left [] -> assert `failure` ikm+                    Right c -> return (Right c, pointer)+                  K.LeftButtonRelease -> do+                    Point{..} <- getsSession spointer+                    let onChoice (_, (cy, cx1, cx2)) =+                          cy == py && cx1 <= px && cx2 > px+                    case find onChoice kyxs of+                      Nothing | ikm `elem` keys -> return (Left ikm, pointer)+                      Nothing -> if K.spaceKM `elem` keys+                                 then return (Left K.spaceKM, pointer)+                                 else ignoreKey+                      Just (ckm, _) -> case ckm of+                        Left (km : _) -> interpretKey km+                        Left [] -> assert `failure` ikm+                        Right c  -> return (Right c, pointer)+                  K.RightButtonRelease ->+                    if | ikm `elem` keys -> return (Left ikm, pointer)+                       | K.escKM `elem` keys -> return (Left K.escKM, pointer)+                       | otherwise -> ignoreKey+                  K.Space | pointer + pageLen - ixOnPage <= maxIx ->+                    page (pointer + pageLen - ixOnPage)+                  K.Unknown "SAFE_SPACE" ->+                    if pointer + pageLen - ixOnPage <= maxIx+                    then page (pointer + pageLen - ixOnPage)+                    else page 0+                  _ | ikm `elem` keys ->+                    return (Left ikm, pointer)+                  K.Up -> case findIndex xix $ reverse $ take ixOnPage kyxs of+                    Nothing -> interpretKey ikm{K.key=K.Left}+                    Just ix -> page (max 0 (pointer - ix - 1))+                  K.Left -> if pointer == 0 then page maxIx+                            else page (max 0 (pointer - 1))+                  K.Down -> case findIndex xix $ drop (ixOnPage + 1) kyxs of+                    Nothing -> interpretKey ikm{K.key=K.Right}+                    Just ix -> page (pointer + ix + 1)+                  K.Right -> if pointer == maxIx then page 0+                             else page (min maxIx (pointer + 1))+                  K.Home -> page 0+                  K.End -> page maxIx+                  _ | K.key ikm `elem` [K.PgUp, K.WheelNorth] ->+                    page (max 0 (pointer - ixOnPage - 1))+                  _ | K.key ikm `elem` [K.PgDn, K.WheelSouth] ->+                    page (min maxIx (pointer + pageLen - ixOnPage))+                  K.Space -> ignoreKey+                  _ -> assert `failure` "unknown key" `twith` ikm+          pkm <- promptGetKey dm ov1 sfBlank legalKeys+          interpretKey pkm+  (km, pointer) <- if null frs+                   then return (Left K.escKM, pointer0)+                   else page pointer0+  assert (either (`elem` keys) (const True) km) $ return (km, pointer)

− Game/LambdaHack/Client/UI/StartupFrontendClient.hs

@@ -1,67 +0,0 @@--- | Startup up the frontend together with the server, which starts up clients.-module Game.LambdaHack.Client.UI.StartupFrontendClient-  ( srtFrontend-  ) where--import Control.Concurrent.Async-import qualified Control.Concurrent.STM as STM-import Control.Exception.Assert.Sugar--import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.Config-import Game.LambdaHack.Client.UI.Content.KeyKind-import Game.LambdaHack.Client.UI.Frontend-import Game.LambdaHack.Client.UI.KeyBindings-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Common.ClientOptions-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.State---- | Wire together game content, the main loops of game clients,--- the main game loop assigned to this frontend (possibly containing--- the server loop, if the whole game runs in one process),--- UI config and the definitions of game commands.-srtFrontend :: (DebugModeCli -> SessionUI -> State -> StateClient-                -> chanServerUI-                -> IO ())    -- ^ UI main loop-            -> (DebugModeCli -> SessionUI -> State -> StateClient-                -> chanServerAI-                -> IO ())    -- ^ AI main loop-            -> KeyKind       -- ^ key and command content-            -> Kind.COps     -- ^ game content-            -> DebugModeCli  -- ^ client debug parameters-            -> ((FactionId -> chanServerUI -> IO ())-               -> (FactionId -> chanServerAI -> IO ())-               -> IO ())     -- ^ frontend main loop-            -> IO ()-srtFrontend executorUI executorAI-            copsClient cops sdebugCli exeServer = do-  -- UI config reloaded at each client start.-  sconfig <- mkConfig cops-  let !sbinding = stdBinding copsClient sconfig  -- evaluate to check for errors-      sdebugMode = applyConfigToDebug sconfig sdebugCli cops-  defaultHist <- defaultHistory $ configHistoryMax sconfig-  let cli = defStateClient defaultHist emptyReport-      s = updateCOps (const cops) emptyState-      exeClientAI fid =-        let noSession = assert `failure` "AI client needs no UI session"-                               `twith` fid-        in executorAI sdebugMode noSession s (cli fid True)-      exeClientUI sescMVar loopFrontend fid chanServerUI = do-        responseF <- STM.newTQueueIO-        requestF <- STM.newTQueueIO-        let schanF = ChanFrontend{..}-        a <- async $ loopFrontend schanF-        link a-        executorUI sdebugMode SessionUI{..} s (cli fid False) chanServerUI-        STM.atomically $ STM.writeTQueue requestF FrontFinish-        wait a-  -- TODO: let each client start his own raw frontend (e.g., gtk, though-  -- that leads to disaster); then don't give server as the argument-  -- to startupF, but the Client.hs (when it ends, gtk ends); server is-  -- then forked separately and client doesn't need to know about-  -- starting servers.-  startupF sdebugMode $ \sescMVar loopFrontend ->-    exeServer (exeClientUI sescMVar loopFrontend) exeClientAI

− Game/LambdaHack/Client/UI/WidgetClient.hs

@@ -1,217 +0,0 @@--- | A set of widgets for UI clients.-module Game.LambdaHack.Client.UI.WidgetClient-  ( displayMore, displayYesNo, displayChoiceUI, displayPush, describeMainKeys-  , promptToSlideshow, overlayToSlideshow, overlayToBlankSlideshow-  , animate, fadeOutOrIn-  ) where--import Control.Applicative-import qualified Data.EnumMap.Strict as EM-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Monoid-import qualified Data.Text as T--import Game.LambdaHack.Client.BfsClient-import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.MonadClient hiding (liftIO)-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.Animation-import Game.LambdaHack.Client.UI.Config-import Game.LambdaHack.Client.UI.Content.KeyKind-import Game.LambdaHack.Client.UI.DrawClient-import Game.LambdaHack.Client.UI.HumanCmd-import Game.LambdaHack.Client.UI.KeyBindings-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Common.ClientOptions-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.State---- | A yes-no confirmation.-getYesNo :: MonadClientUI m => SingleFrame -> m Bool-getYesNo frame = do-  let keys = [ K.toKM K.NoModifier (K.Char 'y')-             , K.toKM K.NoModifier (K.Char 'n')-             , K.escKM-             ]-  K.KM {key} <- promptGetKey keys frame-  case key of-    K.Char 'y' -> return True-    _          -> return False---- | Display a message with a @-more-@ prompt.--- Return value indicates if the player tried to cancel/escape.-displayMore :: MonadClientUI m => ColorMode -> Msg -> m Bool-displayMore dm prompt = do-  slides <- promptToSlideshow $ prompt <+> moreMsg-  -- Two frames drawn total (unless 'prompt' very long).-  getInitConfirms dm [] $ slides <> toSlideshow Nothing [[]]---- | Print a yes/no question and return the player's answer. Use black--- and white colours to turn player's attention to the choice.-displayYesNo :: MonadClientUI m => ColorMode -> Msg -> m Bool-displayYesNo dm prompt = do-  sli <- promptToSlideshow $ prompt <+> yesnoMsg-  frame <- drawOverlay False dm $ head . snd $ slideshow sli-  getYesNo frame---- TODO: generalize getInitConfirms and displayChoiceUI to a single op--- | Print a prompt and an overlay and wait for a player keypress.--- If many overlays, scroll screenfuls with SPACE. Do not wrap screenfuls--- (in some menus @?@ cycles views, so the user can restart from the top).-displayChoiceUI :: MonadClientUI m-                => Msg -> Overlay -> [K.KM] -> m (Either Slideshow K.KM)-displayChoiceUI prompt ov keys = do-  (_, ovs) <- slideshow <$> overlayToSlideshow (prompt <> ", ESC]") ov-  let extraKeys = [K.spaceKM, K.escKM, K.pgupKM, K.pgdnKM]-      legalKeys = keys ++ extraKeys-      loop frs srf =-        case frs of-          [] -> Left <$> promptToSlideshow "*never mind*"-          x : xs -> do-            frame <- drawOverlay False ColorFull x-            km@K.KM{..} <- promptGetKey legalKeys frame-            case key of-              _ | km `elem` keys -> return $ Right km  -- km can be PgUp, etc.-              K.Esc -> Left <$> promptToSlideshow "*never mind*"-              K.PgUp -> case srf of-                [] -> loop frs srf-                y : ys -> loop (y : frs) ys-              K.Space -> case xs of-                [] -> Left <$> promptToSlideshow "*never mind*"-                _ -> loop xs (x : srf)-              _ -> case xs of  -- K.PgDn and any other permitted key-                [] -> loop frs srf-                _ -> loop xs (x : srf)-  loop ovs []---- TODO: if more slides, don't take head, but do as in getInitConfirms,--- but then we have to clear the messages or they get redisplayed--- each time screen is refreshed.--- | Push the frame depicting the current level to the frame queue.--- Only one screenful of the report is shown, the rest is ignored.-displayPush :: MonadClientUI m => Msg -> m ()-displayPush prompt = do-  sls <- promptToSlideshow prompt-  let slide = head . snd $ slideshow sls-  frame <- drawOverlay False ColorFull slide-  displayFrame (Just frame)--describeMainKeys :: MonadClientUI m => m Msg-describeMainKeys = do-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  let underAI = isAIFact fact-  stgtMode <- getsClient stgtMode-  Binding{brevMap} <- askBinding-  Config{configVi, configLaptop} <- askConfig-  cursor <- getsClient scursor-  let kmLeftButtonPress =-        M.findWithDefault (K.toKM K.NoModifier K.LeftButtonPress)-                          macroLeftButtonPress brevMap-      kmEscape =-        M.findWithDefault (K.toKM K.NoModifier K.Esc) Cancel brevMap-      kmCtrlx =-        M.findWithDefault (K.toKM K.Control (K.KP 'x')) GameExit brevMap-      kmRightButtonPress =-        M.findWithDefault (K.toKM K.NoModifier K.RightButtonPress)-                          TgtPointerEnemy brevMap-      kmReturn =-        M.findWithDefault (K.toKM K.NoModifier K.Return) Accept brevMap-      moveKeys | configVi = "hjklyubn, "-               | configLaptop = "uk8o79jl, "-               | otherwise = ""-      tgtKind = case cursor of-        TEnemy _ True -> "at actor"-        TEnemy _ False -> "at enemy"-        TEnemyPos _ _ _ True -> "at actor"-        TEnemyPos _ _ _ False -> "at enemy"-        TPoint{} -> "at position"-        TVector{} -> "with a vector"-      keys | underAI = ""-           | isNothing stgtMode =-        "Explore with keypad or keys or mouse: ["-        <> moveKeys-        <> T.intercalate ", "-             (map K.showKM [kmLeftButtonPress, kmCtrlx, kmEscape])-        <> "]"-           | otherwise =-        "Aim" <+> tgtKind <+> "with keypad or keys or mouse: ["-        <> moveKeys-        <> T.intercalate ", "-             (map K.showKM [kmRightButtonPress, kmReturn, kmEscape])-        <> "]"-  report <- getsClient sreport-  return $! if nullReport report then keys else ""---- | The prompt is shown after the current message, but not added to history.--- This is useful, e.g., in targeting mode, not to spam history.-promptToSlideshow :: MonadClientUI m => Msg -> m Slideshow-promptToSlideshow prompt = overlayToSlideshow prompt emptyOverlay---- | The prompt is shown after the current message at the top of each slide.--- Together they may take more than one line. The prompt is not added--- to history. The portions of overlay that fit on the the rest--- of the screen are displayed below. As many slides as needed are shown.-overlayToSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow-overlayToSlideshow prompt overlay = do-  promptAI <- msgPromptAI-  lid <- getArenaUI-  Level{lxsize, lysize} <- getLevel lid  -- TODO: screen length or viewLevel-  sreport <- getsClient sreport-  let msg = splitReport lxsize (prependMsg promptAI (addMsg sreport prompt))-  return $! splitOverlay Nothing (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-                        => Bool -> Msg -> Overlay -> m Slideshow-overlayToBlankSlideshow startAtTop prompt overlay = do-  lid <- getArenaUI-  Level{lysize} <- getLevel lid  -- TODO: screen length or viewLevel-  return $! splitOverlay (Just startAtTop) (lysize + 3)-                         (toOverlay [prompt]) overlay---- TODO: restrict the animation to 'per' before drawing.--- | Render animations on top of the current screen frame.-animate :: MonadClientUI m => LevelId -> Animation -> m Frames-animate arena anim = do-  sreport <- getsClient sreport-  mleader <- getsClient _sleader-  Level{lxsize, lysize} <- getLevel arena-  tgtPos <- leaderTgtToPos-  cursorPos <- cursorToPos-  let anyPos = fromMaybe (Point 0 0) cursorPos-        -- if cursor invalid, e.g., on a wrong level; @draw@ ignores it later on-      pathFromLeader leader = Just <$> getCacheBfsAndPath leader anyPos-  bfsmpath <- maybe (return Nothing) pathFromLeader mleader-  tgtDesc <- maybe (return ("------", Nothing)) targetDescLeader mleader-  cursorDesc <- targetDescCursor-  promptAI <- msgPromptAI-  let over = renderReport (prependMsg promptAI sreport)-      topLineOnly = truncateToOverlay over-  basicFrame <--    draw ColorFull arena cursorPos tgtPos-         bfsmpath cursorDesc tgtDesc topLineOnly-  snoAnim <- getsClient $ snoAnim . sdebugCli-  return $! if fromMaybe False snoAnim-            then [Just basicFrame]-            else renderAnim lxsize lysize basicFrame anim--fadeOutOrIn :: MonadClientUI m => Bool -> m ()-fadeOutOrIn out = do-  let topRight = True-  lid <- getArenaUI-  Level{lxsize, lysize} <- getLevel lid-  animMap <- rndToAction $ fadeout out topRight 2 lxsize lysize-  animFrs <- animate lid animMap-  mapM_ displayFrame animFrs

Game/LambdaHack/Common/Ability.hs view

@@ -2,15 +2,22 @@ -- | AI strategy abilities. module Game.LambdaHack.Common.Ability   ( Ability(..), Skills-  , zeroSkills, unitSkills, addSkills, scaleSkills+  , zeroSkills, unitSkills, addSkills, scaleSkills, tacticSkills   , blockOnly, meleeAdjacent, meleeAndRanged, ignoreItems   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude++import Control.DeepSeq import Data.Binary import qualified Data.EnumMap.Strict as EM import Data.Hashable (Hashable) import GHC.Generics (Generic) +import Game.LambdaHack.Common.Misc+ -- | Actor and faction abilities corresponding to client-server requests. data Ability =     AbMove@@ -21,12 +28,26 @@   | AbMoveItem   | AbProject   | AbApply-  | AbTrigger-  deriving (Read, Eq, Ord, Generic, Enum, Bounded)+  deriving (Eq, Ord, Generic, Enum, Bounded) --- skill level in particular abilities.+-- | Skill level in particular abilities.+--+-- This representation is sparse, so better than a record when there are more+-- item kinds (with few abilities) than actors (with many abilities),+-- especially if the number of abilities grows as the engine is developed.+-- It's also easier to code and maintain. type Skills = EM.EnumMap Ability Int +tacticSkills :: Tactic -> Skills+tacticSkills TExplore = zeroSkills+tacticSkills TFollow = zeroSkills+tacticSkills TFollowNoItems = ignoreItems+tacticSkills TMeleeAndRanged = meleeAndRanged+tacticSkills TMeleeAdjacent = meleeAdjacent+tacticSkills TBlock = blockOnly+tacticSkills TRoam = zeroSkills+tacticSkills TPatrol = zeroSkills+ zeroSkills :: Skills zeroSkills = EM.empty @@ -42,7 +63,7 @@ minusTen, blockOnly, meleeAdjacent, meleeAndRanged, ignoreItems :: Skills  -- To make sure only a lot of weak items can override move-only-leader, etc.-minusTen = EM.fromList $ zip [minBound..maxBound] [-10, -10..]+minusTen = EM.fromDistinctAscList $ zip [minBound..maxBound] (repeat (-10))  blockOnly = EM.delete AbWait minusTen @@ -51,7 +72,7 @@ -- Melee and reaction fire. meleeAndRanged = EM.delete AbProject meleeAdjacent -ignoreItems = EM.fromList $ zip [AbMoveItem, AbProject, AbApply] [-10, -10..]+ignoreItems = EM.fromList $ zip [AbMoveItem, AbProject, AbApply] (repeat (-10))  instance Show Ability where   show AbMove = "move"@@ -62,7 +83,8 @@   show AbMoveItem = "manage items"   show AbProject = "fling"   show AbApply = "apply"-  show AbTrigger = "trigger floor"++instance NFData Ability  instance Binary Ability where   put = putWord8 . toEnum . fromEnum

Game/LambdaHack/Common/Actor.hs view

@@ -1,38 +1,36 @@+{-# LANGUAGE DeriveGeneric #-} -- | Actors in the game: heroes, monsters, etc. No operation in this module -- involves the 'State' or 'Action' type. module Game.LambdaHack.Common.Actor   ( -- * Actor identifiers and related operations-    ActorId, monsterGenChance, partActor, partPronoun+    ActorId, monsterGenChance     -- * The@ Acto@r type-  , Actor(..), ResDelta(..)-  , deltaSerious, deltaMild, xM, minusM, minusTwoM, oneM-  , bspeed, actorTemplate, braced, waitedLastTurn-  , actorDying, actorNewBorn, unoccupied-  , hpTooLow, hpHuge, calmEnough, calmEnough10, hpEnough, hpEnough10+  , Actor(..), ResDelta(..), ActorAspect+  , deltaSerious, deltaMild, actorCanMelee+  , bspeed, actorTemplate, braced, waitedLastTurn, actorDying+  , hpTooLow, calmEnough, hpEnough     -- * Assorted   , ActorDict, smellTimeout, checkAdjacent-  , keySelected, ppContainer, ppCStore, ppCStoreIn, verbCStore+  , eqpOverfull, eqpFreeN   ) where -import Control.Exception.Assert.Sugar+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Data.Binary import qualified Data.EnumMap.Strict as EM import Data.Int (Int64)-import Data.Maybe import Data.Ratio-import Data.Text (Text)-import qualified NLP.Miniutter.English as MU+import GHC.Generics (Generic) -import qualified Game.LambdaHack.Common.Color as Color+import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemStrongest import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.Time 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@,@@ -40,64 +38,66 @@ -- to the original value from @ActorKind@ over time. E.g., HP. data Actor = Actor   { -- The trunk of the actor's body (present also in @borgan@ or @beqp@)-    btrunk        :: !ItemId--    -- Presentation-  , bsymbol       :: !Char         -- ^ individual map symbol-  , bname         :: !Text         -- ^ individual name-  , bpronoun      :: !Text         -- ^ individual pronoun-  , bcolor        :: !Color.Color  -- ^ individual map color+    btrunk      :: !ItemId      -- Resources-  , btime         :: !Time         -- ^ absolute time of next action-  , bhp           :: !Int64        -- ^ current hit points * 1M-  , bhpDelta      :: !ResDelta     -- ^ HP delta this turn * 1M-  , bcalm         :: !Int64        -- ^ current calm * 1M-  , bcalmDelta    :: !ResDelta     -- ^ calm delta this turn * 1M+  , bhp         :: !Int64        -- ^ current hit points * 1M+  , bhpDelta    :: !ResDelta     -- ^ HP delta this turn * 1M+  , bcalm       :: !Int64        -- ^ current calm * 1M+  , bcalmDelta  :: !ResDelta     -- ^ calm delta this turn * 1M      -- Location-  , bpos          :: !Point        -- ^ current position-  , boldpos       :: !(Maybe Point)  -- ^ previous position, if any-  , blid          :: !LevelId      -- ^ current level-  , boldlid       :: !LevelId      -- ^ previous level-  , bfid          :: !FactionId    -- ^ faction the actor currently belongs to-  , bfidImpressed :: !FactionId    -- ^ the faction actor is attracted to-  , bfidOriginal  :: !FactionId    -- ^ the original faction of the actor-  , btrajectory   :: !(Maybe ([Vector], Speed))-                                   -- ^ trajectory the actor must-                                   --   travel and his travel speed+  , bpos        :: !Point        -- ^ current position+  , boldpos     :: !(Maybe Point)+                                 -- ^ previous position, if any+  , blid        :: !LevelId      -- ^ current level+  , bfid        :: !FactionId    -- ^ faction the actor currently belongs to+  , btrajectory :: !(Maybe ([Vector], Speed))+                                 -- ^ trajectory the actor must+                                 --   travel and his travel speed      -- Items-  , borgan        :: !ItemBag      -- ^ organs-  , beqp          :: !ItemBag      -- ^ personal equipment-  , binv          :: !ItemBag      -- ^ personal inventory+  , borgan      :: !ItemBag      -- ^ organs+  , beqp        :: !ItemBag      -- ^ personal equipment+  , binv        :: !ItemBag      -- ^ personal inventory pack+  , bweapon     :: !Int          -- ^ number of weapons among eqp and organs      -- Assorted-  , bwait         :: !Bool         -- ^ is the actor waiting right now?-  , bproj         :: !Bool         -- ^ is a projectile? (shorthand only,-                                   --   this can be deduced from bkind)+  , bwait       :: !Bool         -- ^ is the actor waiting right now?+  , bproj       :: !Bool         -- ^ is a projectile? (shorthand only,+                                 --   this can be deduced from btrunk)   }-  deriving (Show, Eq)+  deriving (Show, Eq, Generic) +instance Binary Actor++-- The resource changes in the tuple are negative and positive, respectively. data ResDelta = ResDelta-  { resCurrentTurn  :: !Int64  -- ^ resource change this player turn-  , resPreviousTurn :: !Int64  -- ^ resource change last player turn+  { resCurrentTurn  :: !(Int64, Int64)  -- ^ resource change this player turn+  , resPreviousTurn :: !(Int64, Int64)  -- ^ resource change last player turn   }-  deriving (Show, Eq)+  deriving (Show, Eq, Generic) +instance Binary ResDelta++type ActorAspect = EM.EnumMap ActorId AspectRecord+ deltaSerious :: ResDelta -> Bool-deltaSerious ResDelta{..} = resCurrentTurn < minusM || resPreviousTurn < minusM+deltaSerious ResDelta{..} =+  fst resCurrentTurn < 0 && fst resCurrentTurn /= minusM+  || fst resPreviousTurn < 0 && fst resPreviousTurn /= minusM  deltaMild :: ResDelta -> Bool-deltaMild ResDelta{..} = resCurrentTurn == minusM || resPreviousTurn == minusM--xM :: Int -> Int64-xM k = fromIntegral k * 1000000+deltaMild ResDelta{..} = fst resCurrentTurn == minusM+                         || fst resPreviousTurn == minusM -minusM, minusTwoM, oneM :: Int64-minusM = xM (-1)-minusTwoM = xM (-2)-oneM = xM 1+actorCanMelee :: ActorAspect -> ActorId -> Actor -> Bool+actorCanMelee actorAspect aid b =+  let ar = actorAspect EM.! aid+      actorMaxSk = aSkills ar+      condUsableWeapon = bweapon b >= 0+      canMelee = EM.findWithDefault 0 Ability.AbMelee actorMaxSk > 0+  in condUsableWeapon && canMelee  -- | Chance that a new monster is generated. Currently depends on the -- number of monsters already present, and on the level. In the future,@@ -115,44 +115,28 @@         numSpawnedCoeff = lvlSpawned `div` 2     in chance $ 1%(fromIntegral                      ((actorCoeff * (numSpawnedCoeff - scaledDepth))-                      `max` 1))---- | The part of speech describing the actor.-partActor :: Actor -> MU.Part-partActor b = MU.Text $ bname b---- | The part of speech containing the actor pronoun.-partPronoun :: Actor -> MU.Part-partPronoun b = MU.Text $ bpronoun b---- Actor operations+                      `max` 1))  -- monsters up to level depth spawned at once  -- | A template for a new actor.-actorTemplate :: ItemId -> Char -> Text -> Text-              -> Color.Color -> Int64 -> Int64-              -> Point -> LevelId -> Time -> FactionId+actorTemplate :: ItemId -> Int64 -> Int64 -> Point -> LevelId -> FactionId               -> Actor-actorTemplate btrunk bsymbol bname bpronoun bcolor bhp bcalm-              bpos blid btime bfid =+actorTemplate btrunk bhp bcalm bpos blid bfid =   let btrajectory = Nothing       boldpos = Nothing-      boldlid = blid+      borgan  = EM.empty       beqp    = EM.empty       binv    = EM.empty-      borgan  = EM.empty+      bweapon = 0       bwait   = False-      bfidImpressed = bfid-      bfidOriginal = bfid-      bhpDelta = ResDelta 0 0-      bcalmDelta = ResDelta 0 0+      bhpDelta = ResDelta (0, 0) (0, 0)+      bcalmDelta = ResDelta (0, 0) (0, 0)       bproj = False   in Actor{..} -bspeed :: Actor -> [ItemFull] -> Speed-bspeed b activeItems =+bspeed :: Actor -> AspectRecord -> Speed+bspeed !b AspectRecord{aSpeed} =   case btrajectory b of-    Nothing -> toSpeed $ max 1  -- avoid infinite wait-               $ sumSlotNoFilter IK.EqpSlotAddSpeed activeItems+    Nothing -> toSpeed aSpeed     Just (_, speed) -> speed  -- | Whether an actor is braced for combat this clip.@@ -167,39 +151,19 @@ actorDying b = bhp b <= 0                || bproj b && maybe True (null . fst) (btrajectory b) -actorNewBorn :: Actor -> Bool-actorNewBorn b = isNothing (boldpos b)-                 && not (waitedLastTurn b)-                 && btime b >= timeTurn--hpTooLow :: Actor -> [ItemFull] -> Bool-hpTooLow b activeItems =-  let maxHP = sumSlotNoFilter IK.EqpSlotAddMaxHP activeItems-  in bhp b <= oneM || 5 * bhp b < xM maxHP && bhp b <= xM 10--hpHuge :: Actor -> Bool-hpHuge b = bhp b > xM 40--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 xM hpMax <= 3 * bhp b+hpTooLow :: Actor -> AspectRecord -> Bool+hpTooLow b AspectRecord{aMaxHP} =+  bhp b <= oneM || 5 * bhp b < xM aMaxHP && bhp b <= xM 40 -hpEnough10 :: Actor -> [ItemFull] -> Bool-hpEnough10 b activeItems = hpEnough b activeItems && bhp b > xM 10+calmEnough :: Actor -> AspectRecord -> Bool+calmEnough b AspectRecord{aMaxCalm} =+  let calmMax = max 1 aMaxCalm+  in 2 * xM calmMax <= 3 * bcalm b && bcalm b > xM 10 --- | Checks for the presence of actors in a position.--- Does not check if the tile is walkable.-unoccupied :: [Actor] -> Point -> Bool-unoccupied actors pos = all (\b -> bpos b /= pos) actors+hpEnough :: Actor -> AspectRecord -> Bool+hpEnough b AspectRecord{aMaxHP} =+  let hpMax = max 1 aMaxHP+  in xM hpMax <= 2 * bhp b && bhp b > xM 1  -- | How long until an actor's smell vanishes from a tile. smellTimeout :: Delta Time@@ -211,89 +175,12 @@ checkAdjacent :: Actor -> Actor -> Bool checkAdjacent sb tb = blid sb == blid tb && adjacent (bpos sb) (bpos tb) -keySelected :: (ActorId, Actor) -> (Bool, Bool, Char, Color.Color, ActorId)-keySelected (aid, Actor{bsymbol, bcolor, bhp}) =-  (bhp > 0, bsymbol /= '@', bsymbol, bcolor, aid)--ppContainer :: Container -> Text-ppContainer CFloor{} = "nearby"-ppContainer CEmbed{} = "embedded nearby"-ppContainer (CActor _ cstore) = ppCStoreIn cstore-ppContainer c@CTrunk{} = assert `failure` c--ppCStore :: CStore -> (Text, Text)-ppCStore CGround = ("on", "the ground")-ppCStore COrgan = ("among", "organs")-ppCStore CEqp = ("in", "equipment")-ppCStore CInv = ("in", "pack")-ppCStore CSha = ("in", "shared stash")--ppCStoreIn :: CStore -> Text-ppCStoreIn c = let (tIn, t) = ppCStore c in tIn <+> t--verbCStore :: CStore -> Text-verbCStore CGround = "drop"-verbCStore COrgan = "implant"-verbCStore CEqp = "equip"-verbCStore CInv = "pack"-verbCStore CSha = "stash"--instance Binary Actor where-  put Actor{..} = do-    put btrunk-    put bsymbol-    put bname-    put bpronoun-    put bcolor-    put bhp-    put bhpDelta-    put bcalm-    put bcalmDelta-    put btrajectory-    put bpos-    put boldpos-    put blid-    put boldlid-    put binv-    put beqp-    put borgan-    put btime-    put bwait-    put bfid-    put bfidImpressed-    put bfidOriginal-    put bproj-  get = do-    btrunk <- get-    bsymbol <- get-    bname <- get-    bpronoun <- get-    bcolor <- get-    bhp <- get-    bhpDelta <- get-    bcalm <- get-    bcalmDelta <- get-    btrajectory <- get-    bpos <- get-    boldpos <- get-    blid <- get-    boldlid <- get-    binv <- get-    beqp <- get-    borgan <- get-    btime <- get-    bwait <- get-    bfid <- get-    bfidImpressed <- get-    bfidOriginal <- get-    bproj <- get-    return $! Actor{..}+eqpOverfull :: Actor -> Int -> Bool+eqpOverfull b n = let size = sum $ map fst $ EM.elems $ beqp b+                  in assert (size <= 10 `blame` (b, n, size))+                     $ size + n > 10 -instance Binary ResDelta where-  put ResDelta{..} = do-    put resCurrentTurn-    put resPreviousTurn-  get = do-    resCurrentTurn <- get-    resPreviousTurn <- get-    return $! ResDelta{..}+eqpFreeN :: Actor -> Int+eqpFreeN b = let size = sum $ map fst $ EM.elems $ beqp b+             in assert (size <= 10 `blame` (b, size))+                $ 10 - size

Game/LambdaHack/Common/ActorState.hs view

@@ -1,38 +1,33 @@ {-# LANGUAGE TupleSections #-} -- | Operations on the 'Actor' type that need the 'State' type,--- but not the 'Action' type.--- TODO: Document an export list after it's rewritten according to #17.+-- but not our custom monad types. module Game.LambdaHack.Common.ActorState-  ( fidActorNotProjAssocs, fidActorNotProjList-  , actorAssocsLvl, actorAssocs, actorList-  , actorRegularAssocsLvl, actorRegularAssocs, actorRegularList+  ( fidActorNotProjAssocs, actorAssocs, actorRegularAssocs+  , warActorRegularList, friendlyActorRegularList, fidActorRegularIds   , bagAssocs, bagAssocsK, calculateTotal-  , mergeItemQuant, sharedAllOwnedFid, findIid-  , getCBag, getActorBag, getBodyActorBag, mapActorItems_, getActorAssocs-  , nearbyFreePoints, whereTo, getCarriedAssocs, getCarriedIidCStore-  , posToActors, getItemBody, memActor, getActorBody-  , tryFindHeroK, getLocalTime, itemPrice, regenCalmDelta-  , actorInAmbient, actorSkills, dispEnemy, fullAssocs, itemToFull-  , goesIntoEqp, goesIntoInv, goesIntoSha, eqpOverfull, eqpFreeN-  , storeFromC, lidFromC, aidFromC, hasCharge-  , strongestMelee, isMelee, isMeleeEqp+  , mergeItemQuant, sharedEqp, sharedAllOwnedFid, findIid+  , getContainerBag, getFloorBag, getEmbedBag, getBodyStoreBag+  , mapActorItems_, getActorAssocs+  , nearbyFreePoints, getCarriedAssocs, getCarriedIidCStore+  , posToAidsLvl, posToAids, posToAssocs+  , getItemBody, memActor, getActorBody, getLocalTime, regenCalmDelta+  , actorInAmbient, canDeAmbientList, actorSkills, dispEnemy, fullAssocs+  , storeFromC, lidFromC, posFromC, aidFromC, isEscape, isStair+  , anyFoeAdj, actorAdjacentAssocs, armorHurtBonus   ) where -import Control.Applicative-import Control.Exception.Assert.Sugar-import qualified Data.Char as Char+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import qualified Data.EnumMap.Strict as EM import Data.Int (Int64)-import Data.List-import Data.Maybe-import qualified Data.Ord as Ord+import GHC.Exts (inline)  import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor-import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc@@ -41,7 +36,6 @@ 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 (TileKind) @@ -50,45 +44,34 @@   let f (_, b) = not (bproj b) && bfid b == fid   in filter f $ EM.assocs $ sactorD s -fidActorNotProjList :: FactionId -> State -> [Actor]-fidActorNotProjList fid s = map snd $ fidActorNotProjAssocs fid s--actorAssocsLvl :: (FactionId -> Bool) -> Level -> ActorDict-               -> [(ActorId, Actor)]-actorAssocsLvl p lvl actorD =-  mapMaybe (\aid -> let b = actorD EM.! aid-                    in if p (bfid b)-                       then Just (aid, b)-                       else Nothing)-  $ concat $ EM.elems $ lprio lvl- actorAssocs :: (FactionId -> Bool) -> LevelId -> State             -> [(ActorId, Actor)] actorAssocs p lid s =-  actorAssocsLvl p (sdungeon s EM.! lid) (sactorD s)--actorList :: (FactionId -> Bool) -> LevelId -> State-          -> [Actor]-actorList p lid s = map snd $ actorAssocs p lid s--actorRegularAssocsLvl :: (FactionId -> Bool) -> Level -> ActorDict-                      -> [(ActorId, Actor)]-actorRegularAssocsLvl p lvl actorD =-  mapMaybe (\aid -> let b = actorD EM.! aid-                    in if not (bproj b) && bhp b > 0 && p (bfid b)-                       then Just (aid, b)-                       else Nothing)-  $ concat $ EM.elems $ lprio lvl+  let f (_, b) = blid b == lid && p (bfid b)+  in filter f $ EM.assocs $ sactorD s  actorRegularAssocs :: (FactionId -> Bool) -> LevelId -> State                    -> [(ActorId, Actor)]+{-# INLINE actorRegularAssocs #-} actorRegularAssocs p lid s =-  actorRegularAssocsLvl p (sdungeon s EM.! lid) (sactorD s)+  let f (_, b) = not (bproj b) && blid b == lid && p (bfid b) && bhp b > 0+  in filter f $ EM.assocs $ sactorD s -actorRegularList :: (FactionId -> Bool) -> LevelId -> State-                 -> [Actor]-actorRegularList p lid s = map snd $ actorRegularAssocs p lid s+warActorRegularList :: FactionId -> LevelId -> State -> [Actor]+warActorRegularList fid lid s =+  let fact = (EM.! fid) . sfactionD $ s+  in map snd $ actorRegularAssocs (inline isAtWar fact) lid s +friendlyActorRegularList :: FactionId -> LevelId -> State -> [Actor]+friendlyActorRegularList fid lid s =+  let fact = (EM.! fid) . sfactionD $ s+      friendlyFid fid2 = fid2 == fid || inline isAllied fact fid2+  in map snd $ actorRegularAssocs friendlyFid lid s++fidActorRegularIds :: FactionId -> LevelId -> State -> [ActorId]+fidActorRegularIds fid lid s =+  map fst $ actorRegularAssocs (== fid) lid s+ getItemBody :: ItemId -> State -> Item getItemBody iid s =   let assFail = assert `failure` "item body not found" `twith` (iid, s)@@ -104,163 +87,117 @@   let iidItem (iid, kit) = (iid, (getItemBody iid s, kit))   in map iidItem $ EM.assocs bag --- | Finds all actors at a position on the current level.-posToActors :: Point -> LevelId -> State -> [(ActorId, Actor)]-posToActors pos lid s =-  let as = actorAssocs (const True) lid s-      l = filter (\(_, b) -> bpos b == pos) as-  in assert (length l <= 1 || all (bproj . snd) l-             `blame` "many actors at the same position" `twith` l)-     l+posToAidsLvl :: Point -> Level -> [ActorId]+{-# INLINE posToAidsLvl #-}+posToAidsLvl pos lvl = EM.findWithDefault [] pos $ lactor lvl +posToAids :: Point -> LevelId -> State -> [ActorId]+posToAids pos lid s = posToAidsLvl pos $ sdungeon s EM.! lid++posToAssocs :: Point -> LevelId -> State -> [(ActorId, Actor)]+posToAssocs pos lid s =+  let l = posToAidsLvl pos $ sdungeon s EM.! lid+  in map (\aid -> (aid, getActorBody aid s)) l+ nearbyFreePoints :: (Kind.Id TileKind -> Bool) -> Point -> LevelId -> State                  -> [Point] nearbyFreePoints f start lid s =-  let Kind.COps{cotile} = scops s-      lvl@Level{lxsize, lysize} = sdungeon s EM.! lid-      as = actorList (const True) lid s+  let lvl@Level{lxsize, lysize} = sdungeon s EM.! lid       good p = f (lvl `at` p)-               && Tile.isWalkable cotile (lvl `at` p)-               && unoccupied as p+               && Tile.isWalkable (Kind.coTileSpeedup $ scops s) (lvl `at` p)+               && null (posToAidsLvl p lvl)       ps = nub $ start : concatMap (vicinity lxsize lysize) ps   in filter good ps --- | Calculate loot's worth for a faction of a given actor.-calculateTotal :: Actor -> State -> (ItemBag, Int)-calculateTotal body s =-  let bag = sharedAllOwned body s+-- | Calculate loot's worth for a given faction.+calculateTotal :: FactionId -> State -> (ItemBag, Int)+calculateTotal fid s =+  let bag = sharedAllOwned fid 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)+mergeItemQuant (k2, it2) (k1, it1) = (k1 + k2, it1 ++ it2) -sharedInv :: Actor -> State -> ItemBag-sharedInv body s =-  let bs = fidActorNotProjList (bfid body) s-  in EM.unionsWith mergeItemQuant-     $ map binv $ if null bs then [body] else bs+sharedInv :: FactionId -> State -> ItemBag+sharedInv fid s =+  let bs = inline fidActorNotProjAssocs fid s+  in EM.unionsWith mergeItemQuant $ map (binv . snd) bs -sharedEqp :: Actor -> State -> ItemBag-sharedEqp body s =-  let bs = fidActorNotProjList (bfid body) s-  in EM.unionsWith mergeItemQuant-     $ map beqp $ if null bs then [body] else bs+sharedEqp :: FactionId -> State -> ItemBag+sharedEqp fid s =+  let bs = inline fidActorNotProjAssocs fid s+  in EM.unionsWith mergeItemQuant $ map (beqp . snd) bs -sharedAllOwned :: Actor -> State -> ItemBag-sharedAllOwned body s =-  let shaBag = gsha $ sfactionD s EM.! bfid body-  in EM.unionsWith mergeItemQuant [sharedEqp body s, sharedInv body s, shaBag]+sharedAllOwned :: FactionId -> State -> ItemBag+sharedAllOwned fid s =+  let shaBag = gsha $ sfactionD s EM.! fid+  in EM.unionsWith mergeItemQuant [sharedEqp fid s, sharedInv fid s, shaBag]  sharedAllOwnedFid :: Bool -> FactionId -> State -> ItemBag sharedAllOwnedFid onlyOrgans fid s =   let shaBag = gsha $ sfactionD s EM.! fid-      bs = fidActorNotProjList fid s+      bs = map snd $ inline fidActorNotProjAssocs fid s   in EM.unionsWith mergeItemQuant      $ if onlyOrgans        then map borgan bs        else map binv bs ++ map beqp bs ++ [shaBag] -findIid :: ActorId -> FactionId -> ItemId -> State -> [(Actor, CStore)]+findIid :: ActorId -> FactionId -> ItemId -> State+        -> [(ActorId, (Actor, CStore))] findIid leader fid iid s =   let actors = fidActorNotProjAssocs fid s       itemsOfActor (aid, b) =         let itemsOfCStore store =-              let bag = getBodyActorBag b store s-              in map (\iid2 -> (iid2, (b, store))) (EM.keys bag)-            stores = [CInv, CEqp] ++ [CSha | aid == leader]+              let bag = getBodyStoreBag b store s+              in map (\iid2 -> (iid2, (aid, (b, store)))) (EM.keys bag)+            stores = [CInv, CEqp, COrgan] ++ [CSha | aid == leader]         in concatMap itemsOfCStore stores       items = concatMap itemsOfActor actors   in map snd $ filter ((== iid) . fst) items --- | Price an item, taking count into consideration.-itemPrice :: (Item, Int) -> Int-itemPrice (item, jcount) =-  case jsymbol item of-    '$' -> jcount-    '*' -> jcount * 100-    _   -> 0---- * These few operations look at, potentially, all levels of the dungeon.---- | Tries to finds an actor body satisfying a predicate on any level.-tryFindActor :: State -> (Actor -> Bool) -> Maybe (ActorId, Actor)-tryFindActor s p =-  find (p . snd) $ EM.assocs $ sactorD s--tryFindHeroK :: FactionId -> Int -> State -> Maybe (ActorId, Actor)-tryFindHeroK fact k s =-  let c | k == 0          = '@'-        | k > 0 && k < 10 = Char.intToDigit k-        | otherwise       = assert `failure` "no digit" `twith` k-  in tryFindActor s (\body -> bsymbol body == c-                              && not (bproj body)-                              && bfid body == fact)---- | Compute the level identifier and starting position on the level,--- after a level change.-whereTo :: LevelId  -- ^ level of the stairs-        -> Point    -- ^ position of the stairs-        -> Int      -- ^ jump up this many levels-        -> Dungeon  -- ^ current game dungeon-        -> (LevelId, Point)-                    -- ^ target level and the position of its receiving stairs-whereTo lid pos k dungeon = assert (k /= 0) $-  let lvl = dungeon EM.! lid-      stairs = (if k < 0 then snd else fst) (lstair lvl)-      defaultStairs = 0  -- for ascending via, e.g., spells-      mindex = elemIndex pos stairs-      i = fromMaybe defaultStairs mindex-  in case ascendInBranch dungeon k lid of-    [] | isNothing mindex -> (lid, pos)  -- spell fizzles-    [] -> assert `failure` "no dungeon level to go to" `twith` (lid, pos, k)-    ln : _ -> let lvlTgt = dungeon EM.! ln-                  stairsTgt = (if k < 0 then fst else snd) (lstair lvlTgt)-              in if length stairsTgt < i + 1-                 then assert `failure` "no stairs at index"-                             `twith` (lid, pos, k, ln, stairsTgt, i)-                 else (ln, stairsTgt !! i)---- * The operations below disregard levels other than the current.---- | Gets actor body from the current level. Error if not found. getActorBody :: ActorId -> State -> Actor-getActorBody aid s =-  let assFail = assert `failure` "body not found" `twith` (aid, s)-  in EM.findWithDefault assFail aid $ sactorD s+{-# INLINE getActorBody #-}+getActorBody aid s = sactorD s EM.! aid  getCarriedAssocs :: Actor -> State -> [(ItemId, Item)] getCarriedAssocs b s =-  bagAssocs s $ EM.unionsWith const [binv b, beqp b, borgan b]+  -- The trunk is important for a case of spotting a caught projectile+  -- that is one with a stolen trunk organ (the projectile item).+  -- This actually does happen.+  let trunk = EM.singleton (btrunk b) (1, [])+  in bagAssocs s $ EM.unionsWith const [binv b, beqp b, borgan b, trunk]  getCarriedIidCStore :: Actor -> [(ItemId, CStore)] getCarriedIidCStore b =-  let bagCarried (cstore, bag) = map (,cstore) $ EM.keys bag-  in concatMap bagCarried-               [(CInv, binv b), (CEqp, beqp b), (COrgan, borgan b)]+  -- The trunk is important for a case of dominating an actor with stolen+  -- trunk organ.+  let trunk = EM.singleton (btrunk b) (1, [])+      bagCarried (cstore, bag) = map (,cstore) $ EM.keys bag+  in concatMap bagCarried [ (CInv, binv b)+                          , (CEqp, beqp b)+                          , (COrgan, EM.unionWith const (borgan b) trunk) ] -getCBag :: Container -> State -> ItemBag-{-# INLINE getCBag #-}-getCBag c s = case c of-  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+getContainerBag :: Container -> State -> ItemBag+getContainerBag c s = case c of+  CFloor lid p -> getFloorBag lid p s+  CEmbed lid p -> getEmbedBag lid p s+  CActor aid cstore -> let b = getActorBody aid s+                       in getBodyStoreBag b cstore s   CTrunk{} -> assert `failure` c -getActorBag :: ActorId -> CStore -> State -> ItemBag-{-# INLINE getActorBag #-}-getActorBag aid cstore s =-  let b = getActorBody aid s-  in getBodyActorBag b cstore s+getFloorBag :: LevelId -> Point -> State -> ItemBag+getFloorBag lid p s = EM.findWithDefault EM.empty p+                      $ lfloor (sdungeon s EM.! lid) -getBodyActorBag :: Actor -> CStore -> State -> ItemBag-{-# INLINE getBodyActorBag #-}-getBodyActorBag b cstore s =+getEmbedBag :: LevelId -> Point -> State -> ItemBag+getEmbedBag lid p s = EM.findWithDefault EM.empty p+                      $ lembed (sdungeon s EM.! lid)++getBodyStoreBag :: Actor -> CStore -> State -> ItemBag+getBodyStoreBag b cstore s =   case cstore of-    CGround -> EM.findWithDefault EM.empty (bpos b)-               $ lfloor (sdungeon s EM.! blid b)+    CGround -> getFloorBag (blid b) (bpos b) s     COrgan -> borgan b     CEqp -> beqp b     CInv -> binv b@@ -274,15 +211,19 @@   let notProcessed = [CGround]       sts = [minBound..maxBound] \\ notProcessed       g cstore = do-        let bag = getBodyActorBag b cstore s+        let bag = getBodyStoreBag b cstore s         mapM_ (uncurry $ f cstore) $ EM.assocs bag   mapM_ g sts  getActorAssocs :: ActorId -> CStore -> State -> [(ItemId, Item)]-getActorAssocs aid cstore s = bagAssocs s $ getActorBag aid cstore s+getActorAssocs aid cstore s =+  let b = getActorBody aid s+  in bagAssocs s $ getBodyStoreBag b cstore s  getActorAssocsK :: ActorId -> CStore -> State -> [(ItemId, (Item, ItemQuant))]-getActorAssocsK aid cstore s = bagAssocsK s $ getActorBag aid cstore s+getActorAssocsK aid cstore s =+  let b = getActorBody aid s+  in bagAssocsK s $ getBodyStoreBag b cstore s  -- | Checks if the actor is present on the current level. -- The order of argument here and in other functions is set to allow@@ -296,112 +237,79 @@ getLocalTime :: LevelId -> State -> Time getLocalTime lid s = ltime $ sdungeon s EM.! lid -regenCalmDelta :: Actor -> [ItemFull] -> State -> Int64-regenCalmDelta b activeItems s =-  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 steps.-      fact = (EM.! bfid b) . sfactionD $ s-      allFoes = actorRegularList (isAtWar fact) (blid b) s-      isHeard body = not (waitedLastTurn body)-                     && chessDist (bpos b) (bpos body) <= 3-      noisyFoes = filter isHeard allFoes-  in if null noisyFoes-     then min calmIncr maxDeltaCalm-     else minusM  -- even if all calmness spent, keep informing the client+regenCalmDelta :: Actor -> AspectRecord -> State -> Int64+regenCalmDelta body AspectRecord{aMaxCalm} s =+  let calmIncr = oneM  -- normal rate of calm regen+      maxDeltaCalm = xM aMaxCalm - bcalm body+      fact = (EM.! bfid body) . sfactionD $ s+      -- Worry actor by (even projectile) enemies felt (even if not seen)+      -- on the level within 3 steps. Even dying, but not hiding in wait.+      isHeardFoe b = blid b == blid body+                     && chessDist (bpos b) (bpos body) <= 3  -- a bit costly+                     && not (waitedLastTurn b)  -- uncommon+                     && inline isAtWar fact (bfid b)  -- costly+  in if any isHeardFoe $ EM.elems $ sactorD s+     then minusM  -- even if all calmness spent, keep informing the client+     else min calmIncr (max 0 maxDeltaCalm)  -- in case Calm is over max  actorInAmbient :: Actor -> State -> Bool actorInAmbient b s =-  let Kind.COps{cotile} = scops s+  let lvl = (EM.! blid b) . sdungeon $ s+  in Tile.isLit (Kind.coTileSpeedup $ scops s) (lvl `at` bpos b)++canDeAmbientList :: Actor -> State -> [Point]+canDeAmbientList b s =+  let Kind.COps{coTileSpeedup} = scops s       lvl = (EM.! blid b) . sdungeon $ s-  in Tile.isLit cotile (lvl `at` bpos b)+      posDeAmbient p =+        let t = lvl `at` p+        in Tile.isWalkable coTileSpeedup t  -- no time to waste altering+           && not (Tile.isLit coTileSpeedup t)+  in if Tile.isLit coTileSpeedup (lvl `at` bpos b)+     then filter posDeAmbient (vicinityUnsafe $ bpos b)+     else [] -actorSkills :: Maybe ActorId -> ActorId -> [ItemFull] -> State -> Ability.Skills-actorSkills mleader aid activeItems s =+actorSkills :: Maybe ActorId -> ActorId -> AspectRecord -> State+            -> Ability.Skills+actorSkills mleader aid ar s =   let body = getActorBody aid s       player = gplayer . (EM.! bfid body) . sfactionD $ s-      skillsFromTactic = tacticSkills $ ftactic player+      skillsFromTactic = Ability.tacticSkills $ ftactic player       factionSkills         | Just aid == mleader = Ability.zeroSkills         | otherwise = fskillsOther player `Ability.addSkills` skillsFromTactic-      itemSkills = sumSkills activeItems+      itemSkills = aSkills ar   in itemSkills `Ability.addSkills` factionSkills -tacticSkills :: Tactic -> Ability.Skills-tacticSkills TExplore = Ability.zeroSkills-tacticSkills TFollow = Ability.zeroSkills-tacticSkills TFollowNoItems = Ability.ignoreItems-tacticSkills TMeleeAndRanged = Ability.meleeAndRanged-tacticSkills TMeleeAdjacent = Ability.meleeAdjacent-tacticSkills TBlock = Ability.blockOnly-tacticSkills TRoam = Ability.zeroSkills-tacticSkills TPatrol = Ability.zeroSkills- -- Check whether an actor can displace an enemy. We assume they are adjacent.-dispEnemy :: ActorId -> ActorId -> [ItemFull] -> State -> Bool-dispEnemy source target activeItems s =+-- If the actor is not, in fact, an enemy, we let it displace.+dispEnemy :: ActorId -> ActorId -> Ability.Skills -> State -> Bool+dispEnemy source target actorMaxSk s =   let hasSupport b =-        let fact = (EM.! bfid b) . sfactionD $ s+        let adjacentAssocs = actorAdjacentAssocs b s+            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-      actorMaxSk = sumSkills activeItems+            friend (_, b2) =+              not (bproj b2) && friendlyFid (bfid b2) && bhp b2 > 0+        in any friend adjacentAssocs       sb = getActorBody source s       tb = getActorBody target s   in bproj tb+     || not (isAtWar ((EM.! bfid tb) . sfactionD $ s) (bfid sb))      || not (actorDying tb              || braced tb              || EM.findWithDefault 0 Ability.AbMove actorMaxSk <= 0              || hasSupport sb && hasSupport tb)  -- solo actors are flexible -fullAssocs :: Kind.COps -> DiscoveryKind -> DiscoveryEffect+fullAssocs :: Kind.COps -> DiscoveryKind -> DiscoveryAspect            -> ActorId -> [CStore] -> State            -> [(ItemId, ItemFull)]-fullAssocs cops disco discoEffect aid cstores s =+fullAssocs cops disco discoAspect aid cstores s =   let allAssocs = concatMap (\cstore -> getActorAssocsK aid cstore s) cstores       iToFull (iid, (item, kit)) =-        (iid, itemToFull cops disco discoEffect iid item kit)+        (iid, itemToFull cops disco discoAspect iid item kit)   in map iToFull allAssocs -itemToFull :: Kind.COps -> DiscoveryKind -> DiscoveryEffect -> ItemId -> Item-           -> ItemQuant-           -> ItemFull-itemToFull Kind.COps{coitem=Kind.Ops{okind}}-           disco discoEffect iid itemBase (itemK, itemTimer) =-  let itemDisco = case EM.lookup (jkindIx itemBase) disco of-        Nothing -> Nothing-        Just itemKindId -> Just ItemDisco{ itemKindId-                                         , itemKind = okind itemKindId-                                         , itemAE = EM.lookup iid discoEffect }-  in ItemFull {..}---- Non-durable item that hurts doesn't go into equipment by default,--- but if it is in equipment or among organs, it's used for melee--- nevertheless, e.g., thorns.-goesIntoEqp :: ItemFull -> Bool-goesIntoEqp itemFull = isJust (strengthEqpSlot $ itemBase itemFull)--- TODO: not needed if EqpSlotWeapon stays         || isMeleeEqp itemFull)--goesIntoInv :: ItemFull -> Bool-goesIntoInv itemFull = IK.Precious `notElem` jfeature (itemBase itemFull)-                       && not (goesIntoEqp itemFull)--goesIntoSha :: ItemFull -> Bool-goesIntoSha itemFull = IK.Precious `elem` jfeature (itemBase itemFull)-                       && not (goesIntoEqp itemFull)--eqpOverfull :: Actor -> Int -> Bool-eqpOverfull b n = let size = sum $ map fst $ EM.elems $ beqp b-                  in assert (size <= 10 `blame` (b, n, size))-                     $ size + n > 10--eqpFreeN :: Actor -> Int-eqpFreeN b = let size = sum $ map fst $ EM.elems $ beqp b-             in assert (size <= 10 `blame` (b, size))-                $ 10 - size- storeFromC :: Container -> CStore storeFromC c = case c of   CFloor{} -> CGround@@ -409,6 +317,12 @@   CActor _ cstore -> cstore   CTrunk{} -> assert `failure` c +aidFromC :: Container -> Maybe ActorId+aidFromC CFloor{} = Nothing+aidFromC CEmbed{} = Nothing+aidFromC (CActor aid _) = Just aid+aidFromC c@CTrunk{} = assert `failure` c+ -- | Determine the dungeon level of the container. If the item is in a shared -- stash, the level depends on which actor asks. lidFromC :: Container -> State -> LevelId@@ -417,70 +331,63 @@ lidFromC (CActor aid _) s = blid $ getActorBody aid s lidFromC c@CTrunk{} _ = assert `failure` c -aidFromC :: Container -> Maybe ActorId-aidFromC CFloor{} = Nothing-aidFromC CEmbed{} = Nothing-aidFromC (CActor aid _) = Just aid-aidFromC c@CTrunk{} = assert `failure` c+posFromC :: Container -> State -> Point+posFromC (CFloor _ pos) _ = pos+posFromC (CEmbed _ pos) _ = pos+posFromC (CActor aid _) s = bpos $ getActorBody aid s+posFromC c@CTrunk{} _ = assert `failure` c -hasCharge :: Time -> ItemFull -> Bool-hasCharge localTime itemFull@ItemFull{..} =-  let it1 = case strengthFromEqpSlot IK.EqpSlotTimeout itemFull of-        Nothing -> []  -- if item not IDed, assume no timeout, to ID by use-        Just timeout ->-          let timeoutTurns = timeDeltaScale (Delta timeTurn) timeout-              charging startT = timeShift startT timeoutTurns > localTime-          in filter charging itemTimer-      len = length it1-  in len < itemK+isEscape :: LevelId -> Point -> State -> Bool+isEscape lid p s =+  let bag = getEmbedBag lid p s+      is = map (`getItemBody` s) $ EM.keys bag+      -- Contrived, for now.+      isE Item{jname} = jname == "escape"+  in any isE is -strMelee :: Bool -> Time -> ItemFull -> Maybe Int-strMelee effectBonus localTime itemFull =-  let durable = IK.Durable `elem` jfeature (itemBase itemFull)-      recharged = hasCharge localTime itemFull-      -- We assume extra weapon effects are useful and so such-      -- weapons are preferred over weapons with no effects.-      -- If the player doesn't like a particular weapon's extra effect,-      -- he has to manage this manually.-      p (IK.Hurt d) = [Dice.meanDice d]-      p (IK.Burn d) = [Dice.meanDice d]-      p IK.NoEffect{} = []-      p IK.OnSmash{} = []-      -- Hackish extra bonus to force Summon as first effect used-      -- before Calm of enemy is depleted.-      p (IK.Recharging IK.Summon{}) = [999 | recharged && effectBonus]-      -- We assume the weapon is still worth using, even if some effects-      -- are charging; in particular, we assume Hurt or Burn are not-      -- under Recharging.-      p IK.Recharging{} = [100 | recharged && effectBonus]-      p IK.Temporary{} = []-      p _ = [100 | effectBonus]-      psum = sum (strengthEffect p itemFull)-  in if not (isMelee itemFull) || psum == 0-     then Nothing-     else Just $ psum + if durable then 1000 else 0+isStair :: LevelId -> Point -> State -> Bool+isStair lid p s =+  let bag = getEmbedBag lid p s+      is = map (`getItemBody` s) $ EM.keys bag+      -- Contrived, for now.+      isE Item{jname} = jname == "staircase up" || jname == "staircase down"+  in any isE is -strongestMelee :: Bool -> Time -> [(ItemId, ItemFull)]-               -> [(Int, (ItemId, ItemFull))]-strongestMelee effectBonus localTime is =-  let f = strMelee effectBonus localTime-      g (iid, itemFull) = (\v -> (v, (iid, itemFull))) <$> f itemFull-  in sortBy (flip $ Ord.comparing fst) $ mapMaybe g is+-- | Require that any non-dying foe is adjacent. We include even+-- projectiles that explode when stricken down, because they can be caught+-- and then they don't explode, so it makes sense to focus on handling them.+-- If there are many projectiles in a single adjacent position, we only test+-- the first one, the one that would be hit in melee (this is not optimal+-- if the actor would need to flee instead of meleeing, but fleeing+-- with *many* projectiles adjacent is a possible waste of a move anyway).+anyFoeAdj :: ActorId -> State -> Bool+anyFoeAdj aid s =+  let body = getActorBody aid s+      lvl = (EM.! blid body) . sdungeon $ s+      fact = (EM.! bfid body) . sfactionD $ s+      f !mv = case posToAidsLvl (shift (bpos body) mv) lvl of+        [] -> False+        aid2 : _ -> g $ getActorBody aid2 s+      g !b = isAtWar fact (bfid b) && bhp b > 0+  in any f moves -isMelee :: ItemFull -> Bool-isMelee itemFull =-  let p IK.Hurt{} = True-      p IK.Burn{} = True-      p _ = False-  in case itemDisco itemFull of-    Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} ->-      any p jeffects-    Just ItemDisco{itemKind=IK.ItemKind{IK.ieffects}} ->-      any p ieffects-    Nothing -> False+actorAdjacentAssocs :: Actor -> State -> [(ActorId, Actor)]+{-# INLINE actorAdjacentAssocs #-}+actorAdjacentAssocs body s =+  let lvl = (EM.! blid body) . sdungeon $ s+      f !mv = posToAidsLvl (shift (bpos body) mv) lvl+      g !aid = (aid, getActorBody aid s)+  in map g $ concatMap f moves --- Melee weapon so good (durable) that goes into equipment by default.-isMeleeEqp :: ItemFull -> Bool-isMeleeEqp itemFull =-  let durable = IK.Durable `elem` jfeature (itemBase itemFull)-  in isMelee itemFull && durable+armorHurtBonus :: ActorAspect -> ActorId -> ActorId -> State -> Int+armorHurtBonus actorAspect source target s =+  let sb = getActorBody source s+      tb = getActorBody target s+      trim200 n = min 200 $ max (-200) n+      block200 b n = min 200 $ max (-200) $ n + if braced tb then b else 0+      sar = actorAspect EM.! source+      tar = actorAspect EM.! target+      itemBonus = trim200 (aHurtMelee sar) - if bproj sb+                                             then block200 25 (aArmorRanged tar)+                                             else block200 50 (aArmorMelee tar)+  in 100 + min 99 (max (-99) itemBonus)  -- at least 1% of damage gets through

Game/LambdaHack/Common/ClientOptions.hs view

@@ -4,39 +4,53 @@   ( DebugModeCli(..), defDebugModeCli   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Data.Binary import GHC.Generics (Generic)  data DebugModeCli = DebugModeCli-  { sfont           :: !(Maybe String)-      -- ^ Font to use for the main game window.-  , scolorIsBold    :: !(Maybe Bool)+  { sgtkFontFamily    :: !(Maybe Text)+      -- ^ Font family to use for the GTK main game window.+  , sdlFontFile       :: !(Maybe Text)+      -- ^ Font file to use for the SDL2 main game window.+  , sdlTtfSizeAdd     :: !(Maybe Int)+      -- ^ Pixels to add to map cells on top of scalable font max glyph height.+  , sdlFonSizeAdd     :: !(Maybe Int)+      -- ^ Pixels to add to map cells on top of .fon font max glyph height.+  , sfontSize         :: !(Maybe Int)+      -- ^ Font size to use for the main game window.+  , scolorIsBold      :: !(Maybe Bool)       -- ^ Whether to use bold attribute for colorful characters.-  , smaxFps         :: !(Maybe Int)+  , smaxFps           :: !(Maybe Int)       -- ^ Maximal frames per second.       -- This is better low and fixed, to avoid jerkiness and delays       -- that tell the player there are many intelligent enemies on the level.       -- That's better than scaling AI sofistication down based       -- on the FPS setting and machine speed.-  , snoDelay        :: !Bool-      -- ^ Don't maintain any requested delays between frames,-      -- e.g., for screensaver.-  , sdisableAutoYes :: !Bool+  , sdisableAutoYes   :: !Bool       -- ^ Never auto-answer all prompts, even if under AI control.-  , snoAnim         :: !(Maybe Bool)+  , 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.-  , ssavePrefixCli  :: !(Maybe String)-      -- ^ Prefix of the save game file.-  , sfrontendStd    :: !Bool-      -- ^ Whether to use the stdout/stdin frontend for all clients.-  , sfrontendNull   :: !Bool-      -- ^ Whether to use void (no input/output) frontend for all clients.-  , sdbgMsgCli      :: !Bool+  , stitle            :: !(Maybe Text)+  , ssavePrefixCli    :: !String+      -- ^ Prefix of the save game file name.+  , sfrontendTeletype :: !Bool+      -- ^ Whether to use the stdout/stdin frontend.+  , sfrontendNull     :: !Bool+      -- ^ Whether to use null (no input/output) frontend.+  , sfrontendLazy     :: !Bool+      -- ^ Whether to use lazy (output not even calculated) frontend.+  , sdbgMsgCli        :: !Bool       -- ^ Show clients' internal debug messages.+  , sstopAfterSeconds :: !(Maybe Int)+  , sstopAfterFrames  :: !(Maybe Int)   }   deriving (Show, Eq, Generic) @@ -44,16 +58,23 @@  defDebugModeCli :: DebugModeCli defDebugModeCli = DebugModeCli-  { sfont = Nothing+  { sgtkFontFamily = Nothing+  , sdlFontFile = Nothing+  , sdlTtfSizeAdd = Nothing+  , sdlFonSizeAdd = Nothing+  , sfontSize = Nothing   , scolorIsBold = Nothing   , smaxFps = Nothing-  , snoDelay = False   , sdisableAutoYes = False   , snoAnim = Nothing   , snewGameCli = False   , sbenchmark = False-  , ssavePrefixCli = Nothing-  , sfrontendStd = False+  , stitle = Nothing+  , ssavePrefixCli = "save"+  , sfrontendTeletype = False   , sfrontendNull = False+  , sfrontendLazy = False   , sdbgMsgCli = False+  , sstopAfterSeconds = Nothing+  , sstopAfterFrames = Nothing   }

Game/LambdaHack/Common/Color.hs view

@@ -1,23 +1,34 @@-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, MagicHash #-} -- | Colours and text attributes. module Game.LambdaHack.Common.Color   ( -- * Colours-    Color(..), defBG, defFG, isBright, legalBG, darkCol, brightCol, stdCol+    Color(..), defFG, isBright, darkCol, brightCol, stdCol   , colorToRGB+  , Highlight (..)     -- * Text attributes and the screen-  , Attr(..), defAttr, AttrChar(..)+  , Attr(..), defAttr+  , AttrChar(..)+  , AttrCharW32(..)+  , attrCharToW32, attrCharFromW32+  , fgFromW32, bgFromW32, charFromW32, attrFromW32, attrEnumFromW32+  , spaceAttrW32, retAttrW32+  , attrChar2ToW32, attrChar1ToW32   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Data.Binary import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.))+import qualified Data.Char as Char import Data.Hashable (Hashable)+import Data.Word (Word32)+import GHC.Exts (Int (I#)) import GHC.Generics (Generic)+import GHC.Prim (int2Word#)+import GHC.Word (Word32 (W32#)) --- TODO: since this type may be essential to speed, consider implementing--- it as an Int, with color numbered as they are on terminals, see--- http://www.haskell.org/haskellwiki/Performance/Data_types#Enumerations--- If we ever switch to 256 colours, the Int implementation or similar--- will be more natural, anyway. -- | Colours supported by the major frontends. data Color =     Black@@ -38,28 +49,45 @@   | BrWhite   deriving (Show, Eq, Ord, Enum, Bounded, Generic) +instance Binary Color where+  put = putWord8 . toEnum . fromEnum+  get = fmap (toEnum . fromEnum) getWord8+ instance Hashable Color  -- | The default colours, to optimize attribute setting.-defBG, defFG :: Color-defBG = Black+defFG :: Color defFG = White +data Highlight =+    HighlightNone+  | HighlightRed+  | HighlightBlue+  | HighlightYellow+  | HighlightGrey+  deriving (Show, Eq, Ord, Enum, Bounded, Generic)++instance Binary Highlight where+  put = putWord8 . toEnum . fromEnum+  get = fmap (toEnum . fromEnum) getWord8++instance Hashable Highlight+ -- | Text attributes: foreground and backgroud colors. data Attr = Attr-  { fg :: !Color  -- ^ foreground colour-  , bg :: !Color  -- ^ backgroud color+  { fg :: !Color      -- ^ foreground colour+  , bg :: !Highlight  -- ^ backgroud highlight   }   deriving (Show, Eq, Ord)  instance Enum Attr where-  fromEnum Attr{..} = fromEnum fg + unsafeShiftL (fromEnum bg) 8-  toEnum n = Attr (toEnum $ n .&. (2 ^ (8 :: Int)  - 1))-                  (toEnum $ unsafeShiftR n 8)+  fromEnum Attr{..} = unsafeShiftL (fromEnum fg) 8 + fromEnum bg+  toEnum n = Attr (toEnum $ unsafeShiftR n 8)+                  (toEnum $ n .&. (2 ^ (8 :: Int) - 1))  -- | The default attribute, to optimize attribute setting. defAttr :: Attr-defAttr = Attr defFG defBG+defAttr = Attr defFG HighlightNone  data AttrChar = AttrChar   { acAttr :: !Attr@@ -67,20 +95,61 @@   }   deriving (Show, Eq, Ord) -instance Enum AttrChar where-  fromEnum AttrChar{..} = fromEnum acAttr + unsafeShiftL (fromEnum acChar) 16-  toEnum n = AttrChar (toEnum $ n .&. (2 ^ (16 :: Int) - 1))-                      (toEnum $ unsafeShiftR n 16)+-- This implementation is faster than @Int@, because some vector updates+-- can be done without going to and from @Int@.+newtype AttrCharW32 = AttrCharW32 {attrCharW32 :: Word32}+  deriving (Show, Eq, Enum, Binary) +attrCharToW32 :: AttrChar -> AttrCharW32+attrCharToW32 AttrChar{acAttr=Attr{..}, acChar} = AttrCharW32 $ toEnum $+  unsafeShiftL (fromEnum fg) 8 + fromEnum bg + unsafeShiftL (Char.ord acChar) 16++attrCharFromW32 :: AttrCharW32 -> AttrChar+attrCharFromW32 !w =+  AttrChar (Attr (toEnum $ fromEnum+                  $ unsafeShiftR (attrCharW32 w) 8 .&. (2 ^ (8 :: Int) - 1))+                 (toEnum $ fromEnum+                  $ attrCharW32 w .&. (2 ^ (8 :: Int) - 1)))+           (Char.chr $ fromEnum $ unsafeShiftR (attrCharW32 w) 16)++{- surprisingly, this is slower:+attrCharFromW32 :: AttrCharW32 -> AttrChar+attrCharFromW32 !w = AttrChar (attrFromW32 w) (charFromW32 w)+-}++fgFromW32 :: AttrCharW32 -> Color+{-# INLINE fgFromW32 #-}+fgFromW32 w =+  toEnum $ fromEnum $ unsafeShiftR (attrCharW32 w) 8 .&. (2 ^ (8 :: Int) - 1)++bgFromW32 :: AttrCharW32 -> Highlight+{-# INLINE bgFromW32 #-}+bgFromW32 w =+  toEnum $ fromEnum $ attrCharW32 w .&. (2 ^ (8 :: Int) - 1)++charFromW32 :: AttrCharW32 -> Char+{-# INLINE charFromW32 #-}+charFromW32 w =+  Char.chr $ fromEnum $ unsafeShiftR (attrCharW32 w) 16++attrFromW32 :: AttrCharW32 -> Attr+{-# INLINE attrFromW32 #-}+attrFromW32 w = Attr (fgFromW32 w) (bgFromW32 w)++attrEnumFromW32 :: AttrCharW32 -> Int+{-# INLINE attrEnumFromW32 #-}+attrEnumFromW32 !w = fromEnum $ attrCharW32 w .&. (2 ^ (16 :: Int) - 1)++spaceAttrW32 :: AttrCharW32+spaceAttrW32 = attrCharToW32 $ AttrChar defAttr ' '++retAttrW32 :: AttrCharW32+retAttrW32 = attrCharToW32 $ AttrChar defAttr '\n'+ -- | A helper for the terminal frontends that display bright via bold. isBright :: Color -> Bool isBright c = c >= BrBlack --- | Due to the limitation of the curses library used in the curses frontend,--- only these are legal backgrounds.-legalBG :: [Color]-legalBG = [Black, White, Blue, Magenta]- -- | Colour sets. darkCol, brightCol, stdCol :: [Color] darkCol   = [Red .. Cyan]@@ -88,11 +157,13 @@ stdCol    = darkCol ++ brightCol  -- | Translationg to heavily modified Linux console color RGB values.-colorToRGB :: Color -> String+--+-- Warning: SDL frontend sadly duplicates this code.+colorToRGB :: Color -> Text colorToRGB Black     = "#000000" colorToRGB Red       = "#D50000" colorToRGB Green     = "#00AA00"-colorToRGB Brown     = "#AA5500"+colorToRGB Brown     = "#CA4A00" colorToRGB Blue      = "#203AF0" colorToRGB Magenta   = "#AA00AA" colorToRGB Cyan      = "#00AAAA"@@ -108,7 +179,7 @@  -- | For reference, the original Linux console colors. -- Good old retro feel and more useful than xterm (e.g. brown).-_olorToRGB :: Color -> String+_olorToRGB :: Color -> Text _olorToRGB Black     = "#000000" _olorToRGB Red       = "#AA0000" _olorToRGB Green     = "#00AA00"@@ -126,6 +197,19 @@ _olorToRGB BrCyan    = "#55FFFF" _olorToRGB BrWhite   = "#FFFFFF" -instance Binary Color where-  put = putWord8 . toEnum . fromEnum-  get = fmap (toEnum . fromEnum) getWord8+attrChar2ToW32 :: Color -> Char -> AttrCharW32+{-# INLINE attrChar2ToW32 #-}+attrChar2ToW32 fg acChar =+  case unsafeShiftL (fromEnum fg) 8 + unsafeShiftL (Char.ord acChar) 16 of+    I# i -> AttrCharW32 $ W32# (int2Word# i)+{- the hacks save one allocation (?) (before fits-in-32bits check) compared to+  unsafeShiftL (fromEnum fg) 8 + unsafeShiftL (Char.ord acChar) 16+-}++attrChar1ToW32 :: Char -> AttrCharW32+{-# INLINE attrChar1ToW32 #-}+attrChar1ToW32 =+  let fgNum = unsafeShiftL (fromEnum White) 8+  in \acChar ->+    case fgNum + unsafeShiftL (Char.ord acChar) 16 of+      I# i -> AttrCharW32 $ W32# (int2Word# i)

Game/LambdaHack/Common/ContentDef.hs view

@@ -7,20 +7,29 @@ -- directory. On the other hand, game content, that is all elements -- of @ContentDef@ instances, are defined in a directory -- of the game code proper, with names corresponding to their kinds.-module Game.LambdaHack.Common.ContentDef (ContentDef(..)) where+module Game.LambdaHack.Common.ContentDef+  ( ContentDef(..), contentFromList+  ) where -import Data.Text (Text)+import Prelude () +import Game.LambdaHack.Common.Prelude++import qualified Data.Vector as V+ import Game.LambdaHack.Common.Misc  -- | 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 a  -- ^ frequency within groups-  , validateSingle :: a -> [Text]+  { 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]+  , 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        :: !(V.Vector a)    -- ^ all content of this type   }++contentFromList :: [a] -> V.Vector a+contentFromList = V.fromList

Game/LambdaHack/Common/Dice.hs view

@@ -1,10 +1,12 @@-{-# LANGUAGE CPP, DeriveGeneric, FlexibleInstances, TypeSynonymInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DeriveGeneric, FlexibleInstances, TypeSynonymInstances #-}+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-orphans #-}+#endif -- | Representation of dice for parameters scaled with current level depth. module Game.LambdaHack.Common.Dice   ( -- * Frequency distribution for casting dice scaled with level depth     Dice, diceConst, diceLevel, diceMult, (|*|)-  , d, ds, dl, intToDice+  , d, dl, intToDice   , maxDice, minDice, meanDice, reduceDice     -- * Dice for rolling a pair of integer parameters representing coordinates.   , DiceXY(..), maxDiceXY, minDiceXY, meanDiceXY@@ -14,20 +16,21 @@ #endif   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Control.Applicative import Control.DeepSeq import Data.Binary import qualified Data.Char as Char import Data.Hashable (Hashable) import qualified Data.IntMap.Strict as IM-import Data.Maybe-import Data.Text (Text) import qualified Data.Text as T import Data.Tuple import GHC.Generics (Generic)  import Game.LambdaHack.Common.Frequency-import Game.LambdaHack.Common.Msg  type SimpleDice = Frequency Int @@ -61,7 +64,7 @@  liftAName :: Text -> (Int -> Int) -> SimpleDice -> SimpleDice liftAName name f fr =-  let frRes = liftA f fr+  let frRes = f <$> fr       nameRes = name <> " (" <> nameFrequency fr  <> ")"   in renameFreq nameRes frRes @@ -84,7 +87,7 @@ zdieSimple n = uniformFreq ("z" <> tshow n) [0..n-1]  dieLevelSimple :: Int -> SimpleDice-dieLevelSimple n = uniformFreq ("ds" <> tshow n) [1..n]+dieLevelSimple n = uniformFreq ("dl" <> tshow n) [1..n]  zdieLevelSimple :: Int -> SimpleDice zdieLevelSimple n = uniformFreq ("zl" <> tshow n) [0..n-1]@@ -94,14 +97,16 @@ -- scaled in proportion to current depth divided by maximal dungeon depth. -- The result if then multiplied by the scale --- to be used to ensure -- that dice results are multiples of, e.g., 10. The scale is set with @|*|@.+--+-- Dice like 100d100 lead to enormous lists, so we help a bit+-- by keeping simple dice nonstrict below. data Dice = Dice   { diceConst :: SimpleDice   , diceLevel :: SimpleDice-  , diceMult  :: Int+  , diceMult  :: !Int   }-  deriving (Read, Eq, Ord, Generic)+  deriving (Eq, Ord, Generic) --- Read and Show should be inverses in this case. instance Show Dice where   show Dice{..} = T.unpack $     let rawMult = nameFrequency diceLevel@@ -109,9 +114,9 @@         signAndMult = case T.uncons scaled of           Just ('-', _) -> scaled           _ -> "+" <+> scaled-    in (if nameFrequency diceLevel == "0" then nameFrequency diceConst-        else if nameFrequency diceConst == "0" then scaled-        else nameFrequency diceConst <+> signAndMult)+    in (if | nameFrequency diceLevel == "0" -> nameFrequency diceConst+           | nameFrequency diceConst == "0" -> scaled+           | otherwise -> nameFrequency diceConst <+> signAndMult)        <+> if diceMult == 1 then "" else "|*|" <+> tshow diceMult  instance Hashable Dice@@ -124,7 +129,8 @@   (Dice dc1 dl1 ds1) + (Dice dc2 dl2 ds2) =     Dice (scaleFreq ds1 dc1 + scaleFreq ds2 dc2)          (scaleFreq ds1 dl1 + scaleFreq ds2 dl2)-         1+         (if ds1 == 1 && ds2 == 1 then 1 else+            assert `failure` (ds1, ds2, "|*| must be at top level" :: Text))   (Dice dc1 dl1 ds1) * (Dice dc2 dl2 ds2) =     -- Hacky, but necessary (unless we forgo general multiplication and     -- stick to multiplications by a scalar from the left and from the right).@@ -142,11 +148,13 @@     Dice (scaleFreq ds1 dc1 * scaleFreq ds2 dc2)          (scaleFreq ds1 dc1 * scaleFreq ds2 dl2           + scaleFreq ds1 dl1 * scaleFreq ds2 dc2)-         1+         (if ds1 == 1 && ds2 == 1 then 1 else+            assert `failure` (ds1, ds2, "|*| must be at top level" :: Text))   (Dice dc1 dl1 ds1) - (Dice dc2 dl2 ds2) =     Dice (scaleFreq ds1 dc1 - scaleFreq ds2 dc2)          (scaleFreq ds1 dl1 - scaleFreq ds2 dl2)-         1+         (if ds1 == 1 && ds2 == 1 then 1 else+            assert `failure` (ds1, ds2, "|*| must be at top level" :: Text))   negate = affectBothDice negate   abs = affectBothDice abs   signum = affectBothDice signum@@ -160,11 +168,8 @@ d n = Dice (dieSimple n) 0 1  -- | Dice scaled with level.-ds :: Int -> Dice-ds n = Dice 0 (dieLevelSimple n) 1- dl :: Int -> Dice-dl = ds+dl n = Dice 0 (dieLevelSimple n) 1  -- Not exposed to save on documentation. _z :: Int -> Dice@@ -182,21 +187,24 @@ (|*|) :: Dice -> Int -> Dice Dice dc1 dl1 ds1 |*| s2 = Dice dc1 dl1 (ds1 * s2) --- | Maximal value of dice. The scaled part taken assuming maximum level.+-- | Maximal value of dice. The scaled part taken assuming median level. maxDice :: Dice -> Int maxDice Dice{..} = (fromMaybe 0 (maxFreq diceConst)-                    + fromMaybe 0 (maxFreq diceLevel))+                    + fromMaybe 0 (maxFreq diceLevel) `div` 2)                    * diceMult --- | Minimal value of dice. The scaled part ignored.+-- | Minimal value of dice. The scaled part taken assuming median level. minDice :: Dice -> Int-minDice Dice{..} = fromMaybe 0 (minFreq diceConst) * diceMult+minDice Dice{..} = (fromMaybe 0 (minFreq diceConst)+                    + fromMaybe 0 (minFreq diceLevel) `div` 2)+                   * diceMult --- | Mean value of dice. The level-dependent part is taken assuming--- the highest level, because that's where the game is the hardest.+-- | Mean value of dice. The scaled part taken assuming median level. -- Assumes the frequencies are not null. meanDice :: Dice -> Int-meanDice Dice{..} = (meanFreq diceConst + meanFreq diceLevel) * diceMult+meanDice Dice{..} = (meanFreq diceConst+                     + meanFreq diceLevel `div` 2)+                    * diceMult  reduceDice :: Dice -> Maybe Int reduceDice de =

− Game/LambdaHack/Common/EffectDescription.hs

@@ -1,187 +0,0 @@--- | Description of effects. No operation in this module--- involves state or monad types.-module Game.LambdaHack.Common.EffectDescription-  ( effectToSuffix, aspectToSuffix, featureToSuff-  , kindEffectToSuffix, kindAspectToSuffix-  ) where--import Control.Exception.Assert.Sugar-import qualified Data.EnumMap.Strict as EM-import Data.Text (Text)-import qualified Data.Text as T-import qualified NLP.Miniutter.English as MU--import qualified Game.LambdaHack.Common.Dice as Dice-import 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.------ 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 _ -> ""  -- printed specially-    Hurt dice -> wrapInParens (tshow dice)-    Burn d -> wrapInParens (tshow d-                            <+> if d > 1 then "burns" else "burn")-    Explode t -> "of" <+> tshow t <+> "explosion"-    RefillHP p | p > 0 ->-      "of limited healing" <+> wrapInParens (affixBonus p)-    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 -> "of repurpose on the ground"-    Identify -> "of identify on the ground"-    SendFlying tmod -> "of impact" <+> tmodToSuff "" tmod-    PushActor tmod -> "of pushing" <+> tmodToSuff "" tmod-    PullActor tmod -> "of pulling" <+> tmodToSuff "" tmod-    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 _ -> ""  -- printed inside a separate section-    Recharging _ -> ""  -- printed inside Periodic or Timeout-    Temporary _ -> ""--tmodToSuff :: Text -> ThrowMod -> Text-tmodToSuff verb ThrowMod{..} =-  let vSuff | throwVelocity == 100 = ""-            | otherwise = "v=" <> tshow throwVelocity <> "%"-      tSuff | throwLinger == 100 = ""-            | otherwise = "t=" <> tshow throwLinger <> "%"-  in if vSuff == "" && tSuff == "" then ""-     else verb <+> "with" <+> vSuff <+> tSuff--rawAspectToSuff :: Aspect Text -> Text-rawAspectToSuff aspect =-  case aspect of-    Unique -> ""  -- marked by capital letters in name-    Periodic{} -> ""  -- printed specially-    Timeout{}  -> ""  -- printed specially-    AddHurtMelee t -> wrapInParens $ t <> "% melee"-    AddHurtRanged  t -> wrapInParens $ t <> "% ranged"-    AddArmorMelee t -> "[" <> t <> "%]"-    AddArmorRanged t -> "{" <> t <> "%}"-    AddMaxHP t -> wrapInParens $ t <+> "HP"-    AddMaxCalm t -> wrapInParens $ t <+> "Calm"-    AddSpeed t -> wrapInParens $ t <+> "speed"-    AddSkills p ->-      let skillToSuff (skill, bonus) =-            (if bonus > 0 then "+" else "")-            <> tshow bonus <+> tshow skill-      in wrapInParens $ T.intercalate " " $ map skillToSuff $ EM.assocs p-    AddSight t -> wrapInParens $ t <+> "sight"-    AddSmell t -> wrapInParens $ t <+> "smell"-    AddLight t -> wrapInParens $ t <+> "light"--featureToSuff :: Feature -> Text-featureToSuff feat =-  case feat of-    Fragile -> wrapInChevrons "fragile"-    Durable -> wrapInChevrons "durable"-    ToThrow tmod -> wrapInChevrons $ tmodToSuff "flies" tmod-    Identified -> ""-    Applicable -> ""-    EqpSlot{} -> ""-    Precious -> wrapInChevrons "precious"-    Tactic tactics -> "overrides tactics to" <+> tshow tactics--effectToSuffix :: Effect -> Text-effectToSuffix = effectToSuff--aspectToSuffix :: Aspect Int -> Text-aspectToSuffix = rawAspectToSuff . fmap affixBonus--affixBonus :: Int -> Text-affixBonus p = case compare p 0 of-  EQ -> ""-  LT -> tshow p-  GT -> "+" <> tshow p--wrapInParens :: Text -> Text-wrapInParens "" = ""-wrapInParens t = "(" <> t <> ")"--wrapInChevrons :: Text -> Text-wrapInChevrons "" = ""-wrapInChevrons t = "<" <> t <> ">"--affixDice :: Dice.Dice -> Text-affixDice d = maybe "+?" affixBonus $ Dice.reduceDice d--kindEffectToSuffix :: Effect -> Text-kindEffectToSuffix = effectToSuffix--kindAspectToSuffix :: Aspect Dice.Dice -> Text-kindAspectToSuffix = rawAspectToSuff . fmap affixDice

Game/LambdaHack/Common/Faction.hs view

@@ -1,23 +1,28 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-} -- | Factions taking part in the game: e.g., two human players controlling -- the hero faction battling the monster and the animal factions. module Game.LambdaHack.Common.Faction   ( FactionId, FactionDict, Faction(..), Diplomacy(..), Status(..)-  , Target(..)-  , isHorrorFact+  , Target(..), TGoal(..), Challenge(..), tgtKindDescription+  , isHorrorFact, nameOfHorrorFact   , noRunWithMulti, isAIFact, autoDungeonLevel, automatePlayer   , isAtWar, isAllied   , difficultyBound, difficultyDefault, difficultyCoeff, difficultyInverse+  , defaultChallenge #ifdef EXPOSE_INTERNAL     -- * Internal operations   , Dipl #endif   ) where -import Control.Monad+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Data.Binary import qualified Data.EnumMap.Strict as EM-import Data.Text (Text)+import qualified Data.IntMap.Strict as IM+import GHC.Generics (Generic)  import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor@@ -34,26 +39,34 @@ type FactionDict = EM.EnumMap FactionId Faction  data Faction = Faction-  { gname    :: !Text            -- ^ individual name-  , gcolor   :: !Color.Color     -- ^ color of actors or their frames-  , 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))-                                 -- ^ the leader of the faction and his target-  , gsha     :: !ItemBag         -- ^ faction's shared inventory-  , gvictims :: !(EM.EnumMap (Kind.Id ItemKind) Int)  -- ^ members killed+  { gname     :: !Text            -- ^ individual name+  , gcolor    :: !Color.Color     -- ^ color of actors or their frames+  , gplayer   :: !Player          -- ^ the player spec for this faction+  , ginitial  :: ![(Int, Int, GroupName ItemKind)]  -- ^ initial actors+  , gdipl     :: !Dipl            -- ^ diplomatic mode+  , gquit     :: !(Maybe Status)  -- ^ cause of game end/exit+  , _gleader  :: !(Maybe ActorId) -- ^ the leader of the faction; don't use+                                  --   in place of _sleader on clients!+  , gsha      :: !ItemBag         -- ^ faction's shared inventory+  , gvictims  :: !(EM.EnumMap (Kind.Id ItemKind) Int)  -- ^ members killed+  , gvictimsD :: !(EM.EnumMap (Kind.Id ModeKind)+                              (IM.IntMap (EM.EnumMap (Kind.Id ItemKind) Int)))+      -- ^ members killed in the past, by game mode and difficulty level   }-  deriving (Show, Eq, Ord)+  deriving (Show, Eq, Ord, Generic) --- | Diplomacy states. Higher overwrite lower in case of assymetric content.+instance Binary Faction++-- | Diplomacy states. Higher overwrite lower in case of asymmetric content. data Diplomacy =     Unknown   | Neutral   | Alliance   | War-  deriving (Show, Eq, Ord, Enum)+  deriving (Show, Eq, Ord, Enum, Generic) +instance Binary Diplomacy+ type Dipl = EM.EnumMap FactionId Diplomacy  -- | Current game status.@@ -63,18 +76,51 @@   , stNewGame :: !(Maybe (GroupName ModeKind))                            -- ^ new game group to start, if any   }-  deriving (Show, Eq, Ord)+  deriving (Show, Eq, Ord, Generic) +instance Binary Status+ -- | The type of na actor target. data Target =     TEnemy !ActorId !Bool     -- ^ target an actor; cycle only trough seen foes, unless the flag is set-  | TEnemyPos !ActorId !LevelId !Point !Bool-    -- ^ last seen position of the targeted actor-  | TPoint !LevelId !Point  -- ^ target a concrete spot+  | TPoint !TGoal !LevelId !Point  -- ^ target a concrete spot   | TVector !Vector         -- ^ target position relative to actor-  deriving (Show, Eq, Ord)+  deriving (Show, Eq, Ord, Generic) +instance Binary Target++data TGoal =+    TEnemyPos !ActorId !Bool+    -- ^ last seen position of the targeted actor+  | TEmbed !ItemBag !Point+    -- ^ in @TPoint (TEmbed bag p) _ q@ usually @bag@ is embbedded in @p@+    --   and @q@ is an adjacent open tile+  | TItem !ItemBag+  | TSmell+  | TUnknown+  | TKnown+  | TAny+  deriving (Show, Eq, Ord, Generic)++instance Binary TGoal++data Challenge = Challenge+  { cdiff :: !Int   -- ^ game difficulty level (HP bonus or malus)+  , cwolf :: !Bool  -- ^ lone wolf challenge (only one starting character)+  , cfish :: !Bool  -- ^ cold fish challenge (no healing from enemies)+  }+  deriving (Show, Eq, Ord, Generic)++instance Binary Challenge++tgtKindDescription :: Target -> Text+tgtKindDescription tgt = case tgt of+  TEnemy _ True -> "at actor"+  TEnemy _ False -> "at enemy"+  TPoint{} -> "at position"+  TVector{} -> "with a vector"+ -- | Tell whether the faction consists of summoned horrors only. -- -- Horror player is special, for summoned actors that don't belong to any@@ -82,10 +128,12 @@ -- a skirmish game between two hero factions land in the horror faction. -- In every game, either all factions for which summoning items exist -- should be present or a horror player should be added to host them.--- Actors that can be summoned should have "horror" in their @ifreq@ set. isHorrorFact :: Faction -> Bool-isHorrorFact fact = fgroup (gplayer fact) == "horror"+isHorrorFact fact = nameOfHorrorFact `elem` fgroups (gplayer fact) +nameOfHorrorFact :: GroupName ItemKind+nameOfHorrorFact = toGroupName "horror"+ -- A faction where other actors move at once or where some of leader change -- is automatic can't run with multiple actors at once. That would be -- overpowered or too complex to keep correct.@@ -116,7 +164,7 @@                           LeaderAI AutoLeader{..} -> (autoDungeon, autoLevel)                           LeaderUI AutoLeader{..} -> (autoDungeon, autoLevel) -automatePlayer :: Bool -> Player a -> Player a+automatePlayer :: Bool -> Player -> Player automatePlayer st pl =   let autoLeader False Player{fleaderMode=LeaderAI auto} = LeaderUI auto       autoLeader True Player{fleaderMode=LeaderUI auto} = LeaderAI auto@@ -145,53 +193,7 @@ difficultyInverse :: Int -> Int difficultyInverse n = difficultyBound + 1 - n -instance Binary Faction where-  put Faction{..} = do-    put gname-    put gcolor-    put gplayer-    put gdipl-    put gquit-    put gleader-    put gsha-    put gvictims-  get = do-    gname <- get-    gcolor <- get-    gplayer <- get-    gdipl <- get-    gquit <- get-    gleader <- get-    gsha <- get-    gvictims <- get-    return $! Faction{..}--instance Binary Diplomacy where-  put = putWord8 . toEnum . fromEnum-  get = fmap (toEnum . fromEnum) getWord8--instance Binary Status where-  put Status{..} = do-    put stOutcome-    put stDepth-    put stNewGame-  get = do-    stOutcome <- get-    stDepth <- get-    stNewGame <- get-    return $! Status{..}--instance Binary Target where-  put (TEnemy a permit) = putWord8 0 >> put a >> put permit-  put (TEnemyPos a lid p permit) =-    putWord8 1 >> put a >> put lid >> put p >> put permit-  put (TPoint lid p) = putWord8 2 >> put lid >> put p-  put (TVector v) = putWord8 3 >> put v-  get = do-    tag <- getWord8-    case tag of-      0 -> liftM2 TEnemy get get-      1 -> liftM4 TEnemyPos get get get get-      2 -> liftM2 TPoint get get-      3 -> liftM TVector get-      _ -> fail "no parse (Target)"+defaultChallenge :: Challenge+defaultChallenge = Challenge { cdiff = difficultyDefault+                             , cwolf = False+                             , cfish = False }

Game/LambdaHack/Common/File.hs view

@@ -1,102 +1,13 @@ -- | Saving/loading with serialization and compression. module Game.LambdaHack.Common.File-  ( encodeEOF, strictDecodeEOF, tryCreateDir, tryCopyDataFiles, appDataDir+  ( encodeEOF, strictDecodeEOF+  , tryCreateDir, doesFileExist, tryWriteFile, readFile, renameFile   ) where -import qualified Codec.Compression.Zlib as Z-import qualified Control.Exception as Ex-import Control.Monad-import Data.Binary-import qualified Data.ByteString.Lazy as LBS-import qualified Data.Char as Char-import System.Directory-import System.Environment-import System.FilePath-import System.IO---- | Serialize, compress and save data.--- Note that LBS.writeFile opens the file in binary mode.-encodeData :: Binary a => FilePath -> a -> IO ()-encodeData f a = do-  let tmpPath = f <.> "tmp"-  Ex.bracketOnError-    (openBinaryFile tmpPath WriteMode)-    (\h -> hClose h >> removeFile tmpPath)-    (\h -> do-       LBS.hPut h . Z.compress . encode $ a-       hClose h-       renameFile tmpPath f-    )---- | Serialize, compress and save data with an EOF marker.--- The @OK@ is used as an EOF marker to ensure any apparent problems with--- corrupted files are reported to the user ASAP.-encodeEOF :: Binary a => FilePath -> a -> IO ()-encodeEOF f a = encodeData f (a, "OK" :: String)---- | Read and decompress the serialized data.-strictReadSerialized :: FilePath -> IO LBS.ByteString-strictReadSerialized f =-  withBinaryFile f ReadMode $ \ h -> do-    c <- LBS.hGetContents h-    let d = Z.decompress c-    LBS.length d `seq` return d---- | Read, decompress and deserialize data.-strictDecodeData :: Binary a => FilePath -> IO a-strictDecodeData = fmap decode . strictReadSerialized---- | Read, decompress and deserialize data with an EOF marker.--- The @OK@ EOF marker ensures any easily detectable file corruption--- is discovered and reported before the function returns.-strictDecodeEOF :: Binary a => FilePath -> IO a-strictDecodeEOF f = do-  (a, n) <- strictDecodeData f-  if n == ("OK" :: String)-    then return $! a-    else error $ "Fatal error: corrupted file " ++ f---- | Try to create a directory, if it doesn't exist. We catch exceptions--- in case many clients try to do the same thing at the same time.-tryCreateDir :: FilePath -> IO ()-tryCreateDir dir = do-  dirExists <- doesDirectoryExist dir-  unless dirExists $-    Ex.handle (\(_ :: Ex.IOException) -> return ())-              (createDirectory dir)---- | Try to copy over data files, if not already there. We catch exceptions--- in case many clients try to do the same thing at the same time.-tryCopyDataFiles :: FilePath-                 -> (FilePath -> IO FilePath)-                 -> [(FilePath, FilePath)]-                 -> IO ()-tryCopyDataFiles dataDir pathsDataFile files =-  let cpFile (fin, fout) = do-        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-            unless bOut $-              Ex.handle (\(_ :: Ex.IOException) -> return ())-                        (copyFile pathsDataIn pathsDataOut)-  in mapM_ cpFile files+import Prelude () --- | Personal data directory for the game. Depends on the OS and the game,--- e.g., for LambdaHack under Linux it's @~\/.LambdaHack\/@.-appDataDir :: IO FilePath-appDataDir = do-  progName <- getProgName-  let name = takeWhile Char.isAlphaNum progName-  getAppUserDataDirectory name+#ifdef USE_JSFILE+import Game.LambdaHack.Common.JSFile+#else+import Game.LambdaHack.Common.HSFile+#endif

Game/LambdaHack/Common/Flavour.hs view

@@ -11,9 +11,12 @@   , colorToTeamName, colorToPlainName, colorToFancyName   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Data.Binary import Data.Hashable (Hashable)-import Data.Text (Text) import GHC.Generics (Generic)  import Game.LambdaHack.Common.Color@@ -25,7 +28,6 @@  instance Binary FancyName --- TODO: add more variety, as the number of items increases -- | The type of item flavours. data Flavour = Flavour   { fancyName :: !FancyName  -- ^ how fancy should the colour description be

Game/LambdaHack/Common/Frequency.hs view

@@ -9,26 +9,20 @@   , scaleFreq, renameFreq, setFreq     -- * Consumption   , nullFreq, runFrequency, nameFrequency-  , maxFreq, minFreq, meanFreq+  , minFreq, maxFreq, mostFreq, meanFreq   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Control.Applicative-import Control.Arrow (first, second) import Control.DeepSeq-import Control.Exception.Assert.Sugar-import Control.Monad import Data.Binary-import Data.Foldable (Foldable)-import qualified Data.Foldable as F import Data.Hashable (Hashable)-import Data.Text (Text)-import Data.Traversable (Traversable)+import Data.Ord (comparing) import GHC.Generics (Generic) -import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg---- TODO: do not expose runFrequency -- | The frequency distribution type. Not normalized (operations may -- or may not group the same elements and sum their frequencies). -- However, elements with zero frequency are removed upon construction.@@ -42,7 +36,7 @@   , nameFrequency :: Text         -- ^ short description for debug, etc.;                                   --   keep it lazy, because it's rarely used   }-  deriving (Show, Read, Eq, Ord, Foldable, Traversable, Generic)+  deriving (Show, Eq, Ord, Foldable, Traversable, Generic)  instance Monad Frequency where   {-# INLINE return #-}@@ -110,21 +104,21 @@  -- | Test if the frequency distribution is empty. nullFreq :: Frequency a -> Bool-{-# INLINE nullFreq #-} nullFreq (Frequency fs _) = null fs +minFreq :: Ord a => Frequency a -> Maybe a+minFreq fr = if nullFreq fr then Nothing else Just $ minimum fr+ maxFreq :: Ord a => Frequency a -> Maybe a-{-# INLINE maxFreq #-}-maxFreq fr = if nullFreq fr then Nothing else Just $ F.maximum fr+maxFreq fr = if nullFreq fr then Nothing else Just $ maximum fr -minFreq :: Ord a => Frequency a -> Maybe a-{-# INLINE minFreq #-}-minFreq fr = if nullFreq fr then Nothing else Just $ F.minimum fr+mostFreq :: Frequency a -> Maybe a+mostFreq fr = if nullFreq fr then Nothing+              else Just $ snd $ maximumBy (comparing fst) $ runFrequency fr  -- | Average value of an @Int@ distribution, rounded up to avoid truncating -- it in the other code higher up, which would equate 1d0 with 1d1. meanFreq :: Frequency Int -> Int-{-# INLINE meanFreq #-} meanFreq fr@(Frequency xs _) = case xs of   [] -> assert `failure` fr   _ -> let sumX = sum [ p * x | (p, x) <- xs ]

+ Game/LambdaHack/Common/HSFile.hs view

@@ -0,0 +1,69 @@+-- | Saving/loading with serialization and compression.+module Game.LambdaHack.Common.HSFile+  ( encodeEOF, strictDecodeEOF+  , tryCreateDir, doesFileExist, tryWriteFile, readFile, renameFile+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Codec.Compression.Zlib as Z+import qualified Control.Exception as Ex+import Data.Binary+import qualified Data.ByteString.Lazy as LBS+import System.Directory+import System.FilePath+import System.IO (IOMode (..), hClose, openBinaryFile, readFile, withBinaryFile,+                  writeFile)++-- | Serialize, compress and save data.+-- Note that LBS.writeFile opens the file in binary mode.+encodeData :: Binary a => FilePath -> a -> IO ()+encodeData path a = do+  let tmpPath = path <.> "tmp"+  Ex.bracketOnError+    (openBinaryFile tmpPath WriteMode)+    (\h -> hClose h >> removeFile tmpPath)+    (\h -> do+       LBS.hPut h . Z.compress . encode $ a+       hClose h+       renameFile tmpPath path+    )++-- | Serialize, compress and save data with an EOF marker.+-- The @OK@ is used as an EOF marker to ensure any apparent problems with+-- corrupted files are reported to the user ASAP.+encodeEOF :: Binary a => FilePath -> a -> IO ()+encodeEOF path a = encodeData path (a, "OK" :: String)++-- | Read, decompress and deserialize data with an EOF marker.+-- The @OK@ EOF marker ensures any easily detectable file corruption+-- is discovered and reported before the function returns.+strictDecodeEOF :: Binary a => FilePath -> IO a+strictDecodeEOF path =+  withBinaryFile path ReadMode $ \h -> do+    c <- LBS.hGetContents h+    let (a, n) = decode $ Z.decompress c+    if n == ("OK" :: String)+    then return $! a+    else fail $ "Fatal error: corrupted file " ++ path++-- | Try to create a directory, if it doesn't exist. We catch exceptions+-- in case many clients try to do the same thing at the same time.+tryCreateDir :: FilePath -> IO ()+tryCreateDir dir = do+  dirExists <- doesDirectoryExist dir+  unless dirExists $+    Ex.handle (\(_ :: Ex.IOException) -> return ())+              (createDirectory dir)++-- | Try to write a file, given content, if the file not already there.+-- We catch exceptions in case many clients try to do the same thing+-- at the same time.+tryWriteFile :: FilePath -> String -> IO ()+tryWriteFile path content = do+  fileExists <- doesFileExist path+  unless fileExists $+    Ex.handle (\(_ :: Ex.IOException) -> return ())+              (writeFile path content)

Game/LambdaHack/Common/HighScore.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE CPP, DeriveGeneric, GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} -- | High score table operations. module Game.LambdaHack.Common.HighScore   ( ScoreDict, ScoreTable@@ -10,21 +9,21 @@ #endif   ) where -import Control.Exception.Assert.Sugar+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Data.Binary import qualified Data.EnumMap.Strict as EM-import Data.List-import Data.Maybe-import Data.Text (Text) import qualified Data.Text as T+import Data.Time.Clock.POSIX+import Data.Time.LocalTime import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU-import System.Time  import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ItemKind (ItemKind) import Game.LambdaHack.Content.ModeKind (HiCondPoly, HiIndeterminant (..),@@ -35,24 +34,15 @@ data ScoreRecord = ScoreRecord   { points       :: !Int        -- ^ the score   , negTime      :: !Time       -- ^ game time spent (negated, so less better)-  , date         :: !ClockTime  -- ^ date of the last game interruption+  , date         :: !POSIXTime  -- ^ date of the last game interruption   , status       :: !Status     -- ^ reason of the game interruption-  , difficulty   :: !Int        -- ^ difficulty of the game+  , challenge    :: !Challenge  -- ^ challenge setup of the game   , gplayerName  :: !Text       -- ^ name of the faction's gplayer   , ourVictims   :: !(EM.EnumMap (Kind.Id ItemKind) Int)  -- ^ allies lost   , theirVictims :: !(EM.EnumMap (Kind.Id ItemKind) Int)  -- ^ foes killed   }   deriving (Eq, Ord, Show, Generic) -instance Binary ClockTime where-  put (TOD cs cp) = do-    put cs-    put cp-  get = do-    cs <- get-    cp <- get-    return $! TOD cs cp- instance Binary ScoreRecord  -- | The list of scores, in decreasing order.@@ -66,24 +56,24 @@ type ScoreDict = EM.EnumMap (Kind.Id ModeKind) ScoreTable  -- | Show a single high score, from the given ranking in the high score table.-showScore :: (Int, ScoreRecord) -> [Text]-showScore (pos, score) =+showScore :: TimeZone -> (Int, ScoreRecord) -> [Text]+showScore tz (pos, score) =   let Status{stOutcome, stDepth} = status score       died = case stOutcome of         Killed   -> "perished on level" <+> tshow (abs stDepth)-        Defeated -> "was defeated"-        Camping  -> "camps somewhere"+        Defeated -> "got defeated"+        Camping  -> "set camp"         Conquer  -> "slew all opposition"         Escape   -> "emerged victorious"         Restart  -> "resigned prematurely"-      curDate = T.pack $ calendarTimeToString . toUTCTime . date $ score+      curDate = tshow . utcToLocalTime tz . posixSecondsToUTCTime . date $ score       turns = absoluteTimeNegate (negTime score) `timeFitUp` timeTurn       tpos = T.justifyRight 3 ' ' $ tshow pos       tscore = T.justifyRight 6 ' ' $ tshow $ points score       victims = let nkilled = sum $ EM.elems $ theirVictims score                     nlost = sum $ EM.elems $ ourVictims score                 in "killed" <+> tshow nkilled <> ", lost" <+> tshow nlost-      diff = difficulty score+      diff = cdiff $ challenge score       diffText | diff == difficultyDefault = ""                | otherwise = "difficulty" <+> tshow diff <> ", "       tturns = makePhrase [MU.CarWs turns "turn"]@@ -118,14 +108,14 @@          -> Int         -- ^ the total value of faction items          -> Time        -- ^ game time spent          -> Status      -- ^ reason of the game interruption-         -> ClockTime   -- ^ current date-         -> Int         -- ^ difficulty level+         -> POSIXTime   -- ^ current date+         -> Challenge   -- ^ challenge setup          -> Text        -- ^ name of the faction's gplayer          -> EM.EnumMap (Kind.Id ItemKind) Int  -- ^ allies lost          -> EM.EnumMap (Kind.Id ItemKind) Int  -- ^ foes killed          -> HiCondPoly          -> (Bool, (ScoreTable, Int))-register table total time status@Status{stOutcome} date difficulty gplayerName+register table total time status@Status{stOutcome} date challenge gplayerName          ourVictims theirVictims hiCondPoly =   let turnsSpent = fromIntegral $ timeFitUp time timeTurn       hiInValue (hi, c) = case hi of@@ -143,36 +133,38 @@         then max 0 (hiPolynomialValue hiPoly)         else 0       hiCondValue = sum . map hiSummandValue+      -- Other challenges than HP difficulty are not reflected in score.       points = (ceiling :: Double -> Int)                $ hiCondValue hiCondPoly-                 * 1.5 ^^ (- (difficultyCoeff difficulty))+                 * 1.5 ^^ (- (difficultyCoeff (cdiff challenge)))       negTime = absoluteTimeNegate time       score = ScoreRecord{..}   in (points > 0, insertPos score table)  -- | Show a screenful of the high scores table. -- Parameter height is the number of (3-line) scores to be shown.-tshowable :: ScoreTable -> Int -> Int -> [Text]-tshowable (ScoreTable table) start height =+showTable :: TimeZone -> ScoreTable -> Int -> Int -> [Text]+showTable tz (ScoreTable table) start height =   let zipped    = zip [1..] table       screenful = take height . drop (start - 1) $ zipped-  in intercalate ["\n"] (map showScore screenful) ++ [moreMsg]+  in "" : intercalate [""] (map (showScore tz) screenful)  -- | Produce a couple of renderings of the high scores table.-showCloseScores :: Int -> ScoreTable -> Int -> [[Text]]-showCloseScores pos h height =+showNearbyScores :: TimeZone -> Int -> ScoreTable -> Int -> [[Text]]+showNearbyScores tz pos h height =   if pos <= height-  then [tshowable h 1 height]-  else [tshowable h 1 height,-        tshowable h (max (height + 1) (pos - height `div` 2)) height]+  then [showTable tz h 1 height]+  else [showTable tz h 1 height,+        showTable tz h (max (height + 1) (pos - height `div` 2)) height]  -- | Generate a slideshow with the current and previous scores. highSlideshow :: ScoreTable -- ^ current score table               -> Int        -- ^ position of the current score in the table               -> Text       -- ^ the name of the game mode-              -> Slideshow-highSlideshow table pos gameModeName =-  let (_, nlines) = normalLevelBound  -- TODO: query terminal size instead+              -> TimeZone   -- ^ the timezone where the game is run+              -> (Text, [[Text]])+highSlideshow table pos gameModeName tz =+  let (_, nlines) = normalLevelBound       height = nlines `div` 3       posStatus = status $ getRecord pos table       (efforts, person, msgUnless) =@@ -184,8 +176,8 @@           Defeated ->             ("your futile efforts", MU.PlEtc, "(no bonus)")           Camping ->-            -- TODO: this is only according to the limited player knowledge;-            -- the final score can be different; say this somewhere+            -- This is only according to the limited player knowledge;+            -- the final score can be different, which is fine:             ("your valiant exploits", MU.PlEtc, "")           Conquer ->             ("your ruthless victory", MU.Sg3rd,@@ -204,4 +196,4 @@       msg = makeSentence         [ MU.SubjectVerb person MU.Yes (MU.Text subject) "award you"         , MU.Ordinal pos, "place", msgUnless ]-  in toSlideshow Nothing $ map ([msg, "\n"] ++) $ showCloseScores pos table height+  in (msg, showNearbyScores tz pos table height)

Game/LambdaHack/Common/Item.hs view

@@ -3,30 +3,41 @@ -- No operation in this module involves the state or any of our custom monads. module Game.LambdaHack.Common.Item   ( -- * The @Item@ type-    ItemId, Item(..), seedToAspectsEffects+    ItemId, Item(..), ItemSource(..)+  , itemPrice, goesIntoEqp, isMelee, goesIntoInv, goesIntoSha+  , seedToAspect, meanAspect, aspectRecordToList+  , aspectRecordFull, aspectsRandom     -- * Item discovery types-  , ItemKindIx, DiscoveryKind, ItemSeed, ItemAspectEffect(..), DiscoveryEffect-  , ItemFull(..), ItemDisco(..), itemNoDisco, itemNoAE+  , ItemKindIx, ItemSeed, KindMean(..), DiscoveryKind+  , Benefit(..), DiscoveryBenefit+  , AspectRecord(..), emptyAspectRecord, sumAspectRecord, DiscoveryAspect+  , ItemFull(..), ItemDisco(..)+  , itemNoDisco, itemToFull     -- * Inventory management types-  , ItemTimer, ItemQuant, ItemBag, ItemDict, ItemKnown+  , ItemTimer, ItemQuant, ItemBag, ItemDict   ) where -import qualified Control.Monad.State as St+import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Control.Monad.Trans.State.Strict as St import Data.Binary import qualified Data.EnumMap.Strict as EM import Data.Hashable (Hashable) import qualified Data.Ix as Ix-import Data.Text (Text)-import Data.Traversable (traverse) import GHC.Generics (Generic) import System.Random (mkStdGen) +import qualified Game.LambdaHack.Common.Ability as Ability+import Game.LambdaHack.Common.Dice (intToDice)+import qualified Game.LambdaHack.Common.Dice as Dice 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+import qualified Game.LambdaHack.Content.ItemKind as IK  -- | A unique identifier of an item in the dungeon. newtype ItemId = ItemId Int@@ -37,37 +48,117 @@ newtype ItemKindIx = ItemKindIx Int   deriving (Show, Eq, Ord, Enum, Ix.Ix, Hashable, Binary) +data KindMean = KindMean+  { kmKind :: !(Kind.Id IK.ItemKind)+  , kmMean :: !AspectRecord+  }+  deriving (Show, Eq, Generic)++instance Binary KindMean+ -- | The map of item kind indexes to item kind ids.--- The full map, as known by the server, is a bijection.-type DiscoveryKind = EM.EnumMap ItemKindIx (Kind.Id ItemKind)+-- The full map, as known by the server, is 1-1.+type DiscoveryKind = EM.EnumMap ItemKindIx KindMean --- | A seed for rolling aspects and effects of an item+-- | Fields are intentionally kept non-strict, because they are recomputed+-- often, but not used every time. The fields are, in order:+-- 1. whether the item should be kept in equipment (not in pack nor stash)+-- 2. the total benefit from picking the item up (to use or to put in equipment)+-- 3. the benefit of applying the item to self+-- 4. the (usually negative) benefit of hitting a foe in meleeing with the item+-- 5. the (usually negative) benefit of flinging an item at an opponent+data Benefit = Benefit+  { benInEqp  :: Bool+  , benPickup :: Int+  , benApply  :: Int+  , benMelee  :: Int+  , benFling  :: Int+  }+  deriving (Show, Generic)++instance Binary Benefit++type DiscoveryBenefit = EM.EnumMap ItemId Benefit++-- | A seed for rolling aspects of an item -- Clients have partial knowledge of how item ids map to the seeds. -- They gain knowledge by identifying items. newtype ItemSeed = ItemSeed Int   deriving (Show, Eq, Ord, Enum, Hashable, Binary) -data ItemAspectEffect = ItemAspectEffect-  { jaspects :: ![Aspect Int]  -- ^ the aspects of the item-  , jeffects :: ![Effect]      -- ^ the effects when applied+data AspectRecord = AspectRecord+  { aTimeout     :: !Int+  , aHurtMelee   :: !Int+  , aArmorMelee  :: !Int+  , aArmorRanged :: !Int+  , aMaxHP       :: !Int+  , aMaxCalm     :: !Int+  , aSpeed       :: !Int+  , aSight       :: !Int+  , aSmell       :: !Int+  , aShine       :: !Int+  , aNocto       :: !Int+  , aAggression  :: !Int+  , aSkills      :: !Ability.Skills   }-  deriving (Show, Eq, Generic)+  deriving (Show, Eq, Ord, Generic) -instance Binary ItemAspectEffect+instance Binary AspectRecord -instance Hashable ItemAspectEffect+instance Hashable AspectRecord --- | The map of item ids to item aspects and effects.+emptyAspectRecord :: AspectRecord+emptyAspectRecord = AspectRecord+  { aTimeout     = 0+  , aHurtMelee   = 0+  , aArmorMelee  = 0+  , aArmorRanged = 0+  , aMaxHP       = 0+  , aMaxCalm     = 0+  , aSpeed       = 0+  , aSight       = 0+  , aSmell       = 0+  , aShine       = 0+  , aNocto       = 0+  , aAggression  = 0+  , aSkills      = Ability.zeroSkills+  }++sumAspectRecord :: [(AspectRecord, Int)] -> AspectRecord+sumAspectRecord l = AspectRecord+  { aTimeout     = 0+  , aHurtMelee   = sum $ mapScale aHurtMelee l+  , aArmorMelee  = sum $ mapScale aArmorMelee l+  , aArmorRanged = sum $ mapScale aArmorRanged l+  , aMaxHP       = sum $ mapScale aMaxHP l+  , aMaxCalm     = sum $ mapScale aMaxCalm l+  , aSpeed       = sum $ mapScale aSpeed l+  , aSight       = sum $ mapScale aSight l+  , aSmell       = sum $ mapScale aSmell l+  , aShine       = sum $ mapScale aShine l+  , aNocto       = sum $ mapScale aNocto l+  , aAggression  = sum $ mapScale aAggression l+  , aSkills      = EM.unionsWith (+) $ mapScaleAbility l+  }+ where+  mapScale f = map (\(ar, k) -> f ar * k)+  mapScaleAbility = map (\(ar, k) -> Ability.scaleSkills k $ aSkills ar)++-- | The map of item ids to item aspects. -- The full map is known by the server.-type DiscoveryEffect = EM.EnumMap ItemId ItemAspectEffect+type DiscoveryAspect = EM.EnumMap ItemId AspectRecord +-- Tiny speedup from making fields non-strict (1%, a bit more GC, less alloc).+-- The fields of @KindMean@ also need to be non-strict then, otherwise slowdown. data ItemDisco = ItemDisco-  { itemKindId :: !(Kind.Id ItemKind)-  , itemKind   :: !ItemKind-  , itemAE     :: !(Maybe ItemAspectEffect)+  { itemKindId     :: !(Kind.Id IK.ItemKind)+  , itemKind       :: !IK.ItemKind+  , itemAspectMean :: !AspectRecord+  , itemAspect     :: !(Maybe AspectRecord)   }   deriving Show +-- No speedup from making fields non-strict. data ItemFull = ItemFull   { itemBase  :: !Item   , itemK     :: !Int@@ -80,11 +171,18 @@ itemNoDisco (itemBase, itemK) =   ItemFull {itemBase, itemK, itemTimer = [], itemDisco=Nothing} -itemNoAE :: ItemFull -> ItemFull-itemNoAE itemFull@ItemFull{..} =-  let f idisco = idisco {itemAE = Nothing}-      newDisco = fmap f itemDisco-  in itemFull {itemDisco = newDisco}+itemToFull :: Kind.COps -> DiscoveryKind -> DiscoveryAspect -> ItemId -> Item+           -> ItemQuant+           -> ItemFull+itemToFull Kind.COps{coitem=Kind.Ops{okind}}+           disco discoAspect iid itemBase (itemK, itemTimer) =+  let itemDisco = case EM.lookup (jkindIx itemBase) disco of+        Nothing -> Nothing+        Just KindMean{..} -> Just ItemDisco{ itemKindId = kmKind+                                           , itemKind = okind kmKind+                                           , itemAspectMean = kmMean+                                           , itemAspect = EM.lookup iid discoAspect }+  in ItemFull {..}  -- | Game items in actor possesion or strewn around the dungeon. -- The fields @jsymbol@, @jname@ and @jflavour@ make it possible to refer to@@ -92,12 +190,15 @@ -- through the @jkindIx@ index as soon as the item is identified. data Item = Item   { jkindIx  :: !ItemKindIx    -- ^ index pointing to the kind of the item-  , jlid     :: !LevelId       -- ^ the level on which item was created+  , jlid     :: !LevelId       -- ^ lowest level the item was created at+  , jfid     :: !(Maybe FactionId)+                               -- ^ the faction that created the item, if any   , jsymbol  :: !Char          -- ^ map symbol   , jname    :: !Text          -- ^ generic name   , jflavour :: !Flavour       -- ^ flavour-  , jfeature :: ![Feature]     -- ^ public properties+  , jfeature :: ![IK.Feature]  -- ^ public properties   , jweight  :: !Int           -- ^ weight in grams, obvious enough+  , jdamage  :: !Dice.Dice     -- ^ impact damage of this particular weapon   }   deriving (Show, Eq, Generic) @@ -105,15 +206,167 @@  instance Binary Item -seedToAspectsEffects :: ItemSeed -> ItemKind -> AbsDepth -> AbsDepth-                     -> ItemAspectEffect-seedToAspectsEffects (ItemSeed itemSeed) kind ldepth totalDepth =-  let castD = castDice ldepth totalDepth-      rollA = mapM (traverse castD) (iaspects kind)-      jaspects = St.evalState rollA (mkStdGen itemSeed)-      jeffects = ieffects kind-  in ItemAspectEffect{..}+data ItemSource =+    ItemSourceLevel !LevelId+  | ItemSourceFaction !FactionId+  deriving (Show, Eq, Generic) +instance Hashable ItemSource++instance Binary ItemSource++-- | Price an item, taking count into consideration.+itemPrice :: (Item, Int) -> Int+itemPrice (item, jcount) =+  case jsymbol item of+    '$' -> jcount+    '*' -> jcount * 100+    _   -> 0++goesIntoEqp :: Item -> Bool+goesIntoEqp item = IK.Equipable `elem` jfeature item+                   || IK.Meleeable `elem` jfeature item++isMelee :: Item -> Bool+isMelee item = IK.Meleeable `elem` jfeature item++goesIntoInv :: Item -> Bool+goesIntoInv item = IK.Precious `notElem` jfeature item+                   && not (goesIntoEqp item)++goesIntoSha :: Item -> Bool+goesIntoSha item = IK.Precious `elem` jfeature item+                   && not (goesIntoEqp item)++aspectRecordToList :: AspectRecord -> [IK.Aspect]+aspectRecordToList AspectRecord{..} =+  [IK.Timeout $ intToDice aTimeout | aTimeout /= 0]+  ++ [IK.AddHurtMelee $ intToDice aHurtMelee | aHurtMelee /= 0]+  ++ [IK.AddArmorMelee $ intToDice aArmorMelee | aArmorMelee /= 0]+  ++ [IK.AddArmorRanged $ intToDice aArmorRanged | aArmorRanged /= 0]+  ++ [IK.AddMaxHP $ intToDice aMaxHP | aMaxHP /= 0]+  ++ [IK.AddMaxCalm $ intToDice aMaxCalm | aMaxCalm /= 0]+  ++ [IK.AddSpeed $ intToDice aSpeed | aSpeed /= 0]+  ++ [IK.AddSight $ intToDice aSight | aSight /= 0]+  ++ [IK.AddSmell $ intToDice aSmell | aSmell /= 0]+  ++ [IK.AddShine $ intToDice aShine | aShine /= 0]+  ++ [IK.AddNocto $ intToDice aNocto | aNocto /= 0]+  ++ [IK.AddAggression $ intToDice aAggression | aAggression /= 0]+  ++ [IK.AddAbility ab $ intToDice n | (ab, n) <- EM.assocs aSkills, n /= 0]++castAspect :: AbsDepth -> AbsDepth -> AspectRecord -> IK.Aspect+           -> Rnd AspectRecord+castAspect !ldepth !totalDepth !ar !asp =+  case asp of+    IK.Timeout d -> do+      n <- castDice ldepth totalDepth d+      return $! assert (aTimeout ar == 0) $ ar {aTimeout = n}+    IK.AddHurtMelee d -> do+      n <- castDice ldepth totalDepth d+      return $! ar {aHurtMelee = n + aHurtMelee ar}+    IK.AddArmorMelee d -> do+      n <- castDice ldepth totalDepth d+      return $! ar {aArmorMelee = n + aArmorMelee ar}+    IK.AddArmorRanged d -> do+      n <- castDice ldepth totalDepth d+      return $! ar {aArmorRanged = n + aArmorRanged ar}+    IK.AddMaxHP d -> do+      n <- castDice ldepth totalDepth d+      return $! ar {aMaxHP = n + aMaxHP ar}+    IK.AddMaxCalm d -> do+      n <- castDice ldepth totalDepth d+      return $! ar {aMaxCalm = n + aMaxCalm ar}+    IK.AddSpeed d -> do+      n <- castDice ldepth totalDepth d+      return $! ar {aSpeed = n + aSpeed ar}+    IK.AddSight d -> do+      n <- castDice ldepth totalDepth d+      return $! ar {aSight = n + aSight ar}+    IK.AddSmell d -> do+      n <- castDice ldepth totalDepth d+      return $! ar {aSmell = n + aSmell ar}+    IK.AddShine d -> do+      n <- castDice ldepth totalDepth d+      return $! ar {aShine = n + aShine ar}+    IK.AddNocto d -> do+      n <- castDice ldepth totalDepth d+      return $! ar {aNocto = n + aNocto ar}+    IK.AddAggression d -> do+      n <- castDice ldepth totalDepth d+      return $! ar {aAggression = n + aAggression ar}+    IK.AddAbility ab d -> do+      n <- castDice ldepth totalDepth d+      return $! ar {aSkills = Ability.addSkills (EM.singleton ab n)+                                                (aSkills ar)}++addMeanAspect :: AspectRecord -> IK.Aspect -> AspectRecord+addMeanAspect !ar !asp =+  case asp of+    IK.Timeout d ->+      let n = Dice.meanDice d+      in assert (aTimeout ar == 0) $ ar {aTimeout = n}+    IK.AddHurtMelee d ->+      let n = Dice.meanDice d+      in ar {aHurtMelee = n + aHurtMelee ar}+    IK.AddArmorMelee d ->+      let n = Dice.meanDice d+      in ar {aArmorMelee = n + aArmorMelee ar}+    IK.AddArmorRanged d ->+      let n = Dice.meanDice d+      in ar {aArmorRanged = n + aArmorRanged ar}+    IK.AddMaxHP d ->+      let n = Dice.meanDice d+      in ar {aMaxHP = n + aMaxHP ar}+    IK.AddMaxCalm d ->+      let n = Dice.meanDice d+      in ar {aMaxCalm = n + aMaxCalm ar}+    IK.AddSpeed d ->+      let n = Dice.meanDice d+      in ar {aSpeed = n + aSpeed ar}+    IK.AddSight d ->+      let n = Dice.meanDice d+      in ar {aSight = n + aSight ar}+    IK.AddSmell d ->+      let n = Dice.meanDice d+      in ar {aSmell = n + aSmell ar}+    IK.AddShine d ->+      let n = Dice.meanDice d+      in ar {aShine = n + aShine ar}+    IK.AddNocto d ->+      let n = Dice.meanDice d+      in ar {aNocto = n + aNocto ar}+    IK.AddAggression d ->+      let n = Dice.meanDice d+      in ar {aAggression = n + aAggression ar}+    IK.AddAbility ab d ->+      let n = Dice.meanDice d+      in ar {aSkills = Ability.addSkills (EM.singleton ab n)+                                         (aSkills ar)}++seedToAspect :: ItemSeed -> IK.ItemKind -> AbsDepth -> AbsDepth -> AspectRecord+seedToAspect (ItemSeed itemSeed) kind ldepth totalDepth =+  let rollM = foldlM' (castAspect ldepth totalDepth) emptyAspectRecord+                      (IK.iaspects kind)+  in St.evalState rollM (mkStdGen itemSeed)++-- If @False@, aspects of this kind are most probably fixed, not random.+aspectsRandom :: IK.ItemKind -> Bool+aspectsRandom kind =+  let rollM = foldlM' (castAspect (AbsDepth 10) (AbsDepth 10))+                      emptyAspectRecord (IK.iaspects kind)+      gen = mkStdGen 0+  in show gen /= show (St.execState rollM gen)++meanAspect :: IK.ItemKind -> AspectRecord+meanAspect kind = foldl' addMeanAspect emptyAspectRecord (IK.iaspects kind)++aspectRecordFull :: ItemFull -> AspectRecord+aspectRecordFull itemFull =+  case itemDisco itemFull of+    Just ItemDisco{itemAspect=Just aspectRecord} -> aspectRecord+    Just ItemDisco{itemAspectMean} -> itemAspectMean+    Nothing -> emptyAspectRecord+ type ItemTimer = [Time]  type ItemQuant = (Int, ItemTimer)@@ -123,10 +376,3 @@ -- | All items in the dungeon (including in actor inventories), -- indexed by item identifier. type ItemDict = EM.EnumMap ItemId Item---- | The essential item properties, used for the @ItemRev@ hash table--- from items to their ids, needed to assign ids to newly generated items.--- All the other meaningul properties can be derived from the two.--- Note that @jlid@ is not meaningful; it gets forgotten if items from--- different levels roll the same random properties and so are merged.-type ItemKnown = (ItemKindIx, ItemAspectEffect)

− Game/LambdaHack/Common/ItemDescription.hs

@@ -1,208 +0,0 @@--- | Descripitons of items.-module Game.LambdaHack.Common.ItemDescription-  ( partItemN, partItem, partItemWs, partItemAW, partItemMediumAW, partItemWownW-  , itemDesc, textAllAE, viewItem-  ) where--import Data.List-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T-import qualified NLP.Miniutter.English as MU--import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.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.Common.Time-import qualified Game.LambdaHack.Content.ItemKind as IK---- | The part of speech describing the item parameterized by the number--- of effects/aspects to show..-partItemN :: Int -> Int -> CStore -> Time -> ItemFull-          -> (Bool, MU.Part, MU.Part)-partItemN fullInfo n c localTime itemFull =-  let genericName = jname $ itemBase itemFull-  in case itemDisco itemFull of-    Nothing ->-      let flav = flavourToName $ jflavour $ itemBase itemFull-      in (False, MU.Text $ flav <+> genericName, "")-    Just iDisco ->-      let (toutN, it1) = case strengthFromEqpSlot IK.EqpSlotTimeout itemFull of-            Nothing -> (0, [])-            Just timeout ->-              let timeoutTurns = timeDeltaScale (Delta timeTurn) timeout-                  charging startT = timeShift startT timeoutTurns > localTime-              in (timeout, filter charging (itemTimer itemFull))-          len = length it1-          chargingAdj | toutN == 0 = "temporary"-                      | otherwise = "charging"-          timer | len == 0 = ""-                | itemK itemFull == 1 && len == 1 = "(" <> chargingAdj <> ")"-                | otherwise = "(" <> tshow len <+> chargingAdj <> ")"-          skipRecharging = fullInfo <= 4 && len >= itemK itemFull-          effTs = filter (not . T.null)-                  $ textAllAE fullInfo skipRecharging c itemFull-          ts = take n effTs-               ++ ["(...)" | length effTs > n]-               ++ [timer]-          isUnique aspects = IK.Unique `elem` aspects-          unique = case iDisco of-            ItemDisco{itemAE=Just ItemAspectEffect{jaspects}} ->-              isUnique jaspects-            ItemDisco{itemKind} ->-              isUnique $ IK.iaspects itemKind-          capName = if unique-                    then MU.Capitalize $ MU.Text genericName-                    else MU.Text genericName-      in (unique, capName, MU.Phrase $ map MU.Text ts)---- | The part of speech describing the item.-partItem :: CStore -> Time -> ItemFull -> (Bool, MU.Part, MU.Part)-partItem = partItemN 5 4--textAllAE :: Int -> Bool -> CStore -> ItemFull -> [Text]-textAllAE fullInfo skipRecharging cstore ItemFull{itemBase, itemDisco} =-  let features | fullInfo >= 9 = map featureToSuff $ sort $ jfeature itemBase-               | otherwise = []-  in case itemDisco of-    Nothing -> features-    Just ItemDisco{itemKind, itemAE} ->-      let periodicAspect :: IK.Aspect a -> Bool-          periodicAspect IK.Periodic = True-          periodicAspect _ = False-          timeoutAspect :: IK.Aspect a -> Bool-          timeoutAspect IK.Timeout{} = True-          timeoutAspect _ = False-          noEffect :: IK.Effect -> Bool-          noEffect IK.NoEffect{} = True-          noEffect _ = False-          hurtEffect :: IK.Effect -> Bool-          hurtEffect (IK.Hurt _) = True-          hurtEffect (IK.Burn _) = True-          hurtEffect _ = False-          notDetail :: IK.Effect -> Bool-          notDetail IK.Explode{} = fullInfo >= 6-          notDetail _ = True-          active = cstore `elem` [CEqp, COrgan]-                   || cstore == CGround && isJust (strengthEqpSlot itemBase)-          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-                mnoEffect = find noEffect effects-                restAs = sort aspects-                (hurtEs, restEs) = partition hurtEffect $ sort-                                   $ filter notDetail effects-                aes = if active-                      then map ppA restAs ++ map ppE restEs-                      else map ppE restEs ++ map ppA restAs-                rechargingTs = T.intercalate (T.singleton ' ')-                               $ filter (not . T.null)-                               $ map ppE $ stripRecharging restEs-                onSmashTs = T.intercalate (T.singleton ' ')-                            $ filter (not . T.null)-                            $ map ppE $ stripOnSmash restEs-                durable = IK.Durable `elem` jfeature itemBase-                periodicOrTimeout = case mperiodic of-                  _ | skipRecharging || 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 <> ")"-                noEff = case mnoEffect of-                  Just (IK.NoEffect t) -> [t]-                  _ -> []-            in noEff ++ if fullInfo >= 5 || fullInfo >= 2 && null noEff-                        then [periodicOrTimeout] ++ map ppE hurtEs ++ aes-                             ++ [onSmash | fullInfo >= 7]-                        else map ppE hurtEs-          aets = case itemAE of-            Just ItemAspectEffect{jaspects, jeffects} ->-              splitAE tshow-                      jaspects aspectToSuffix-                      jeffects effectToSuffix-            Nothing ->-              splitAE (maybe "?" tshow . Dice.reduceDice)-                      (IK.iaspects itemKind) kindAspectToSuffix-                      (IK.ieffects itemKind) kindEffectToSuffix-      in aets ++ features---- TODO: use kit-partItemWs :: Int -> CStore -> Time -> ItemFull -> MU.Part-partItemWs count c localTime itemFull =-  let (unique, name, stats) = partItem c localTime itemFull-  in if unique && count == 1-     then MU.Phrase ["the", name, stats]-     else MU.Phrase [MU.CarWs count name, stats]--partItemAW :: CStore -> Time -> ItemFull -> MU.Part-partItemAW c localTime itemFull =-  let (unique, name, stats) = partItemN 4 4 c localTime itemFull-  in if unique-     then MU.Phrase ["the", name, stats]-     else MU.AW $ MU.Phrase [name, stats]--partItemMediumAW :: CStore -> Time -> ItemFull -> MU.Part-partItemMediumAW c localTime itemFull =-  let (unique, name, stats) = partItemN 5 100 c localTime itemFull-  in if unique-     then MU.Phrase ["the", name, stats]-     else MU.AW $ MU.Phrase [name, stats]--partItemWownW :: MU.Part -> CStore -> Time -> ItemFull -> MU.Part-partItemWownW partA c localTime itemFull =-  let (_, name, stats) = partItemN 4 4 c localTime itemFull-  in MU.WownW partA $ MU.Phrase [name, stats]--itemDesc :: CStore -> Time -> ItemFull -> Overlay-itemDesc c localTime itemFull =-  let (_, name, stats) = partItemN 10 100 c localTime itemFull-      nstats = makePhrase [name, stats]-      desc = case itemDisco itemFull of-        Nothing -> "This item is as unremarkable as can be."-        Just ItemDisco{itemKind} -> IK.idesc itemKind-      weight = jweight (itemBase itemFull)-      (scaledWeight, unitWeight)-        | weight > 1000 =-          (tshow $ fromIntegral weight / (1000 :: Double), "kg")-        | weight > 0 = (tshow weight, "g")-        | otherwise = ("", "")-      ln = abs $ fromEnum $ jlid (itemBase itemFull)-      colorSymbol = uncurry (flip Color.AttrChar) (viewItem $ itemBase itemFull)-      f = Color.AttrChar Color.defAttr-      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]-      splitBlurb = splitText lxsize blurb-      attrBlurb = map (map f . T.unpack) splitBlurb-  in encodeOverlay $ (colorSymbol : tail (head attrBlurb)) : tail attrBlurb--viewItem :: Item -> (Char, Color.Attr)-viewItem item = ( jsymbol item-                , Color.defAttr {Color.fg = flavourToColor $ jflavour item} )

Game/LambdaHack/Common/ItemStrongest.hs view

@@ -3,20 +3,19 @@ module Game.LambdaHack.Common.ItemStrongest   ( -- * Strongest items     strengthOnSmash, strengthCreateOrgan, strengthDropOrgan-  , strengthToThrow, strengthEqpSlot, strengthFromEqpSlot, strengthEffect-  , strongestSlotNoFilter, strongestSlot, sumSlotNoFilter, sumSkills+  , strengthEqpSlot, strengthToThrow, strengthEffect, strongestSlot     -- * Assorted   , totalRange, computeTrajectory, itemTrajectory-  , unknownMelee, allRecharging, stripRecharging, stripOnSmash+  , unknownMelee, filterRecharging, stripRecharging, stripOnSmash+  , hasCharge, damageUsefulness, strongestMelee, prEqpSlot   ) where -import Control.Applicative-import Control.Exception.Assert.Sugar+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import qualified Data.EnumMap.Strict as EM-import Data.List-import Data.Maybe import qualified Data.Ord as Ord-import Data.Text (Text)  import qualified Game.LambdaHack.Common.Ability as Ability import qualified Game.LambdaHack.Common.Dice as Dice@@ -27,38 +26,13 @@ import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ItemKind -strengthAspect :: (Aspect Int -> [b]) -> ItemFull -> [b]-strengthAspect f itemFull =-  case itemDisco itemFull of-    Just ItemDisco{itemAE=Just ItemAspectEffect{jaspects}} ->-      concatMap f jaspects-    Just ItemDisco{itemKind=ItemKind{iaspects}} ->-      -- Approximation. For some effects lower values are better,-      -- so we just offer the mean of the dice. This is also correct-      -- for summation, on average.-      concatMap (f . fmap Dice.meanDice) iaspects-    Nothing -> []--strengthAspectMaybe :: Show b => (Aspect Int -> [b]) -> ItemFull -> Maybe b-strengthAspectMaybe f itemFull =-  case strengthAspect f itemFull of-    [] -> Nothing-    [x] -> Just x-    xs -> assert `failure` (xs, itemFull)- strengthEffect :: (Effect -> [b]) -> ItemFull -> [b]-{-# INLINE strengthEffect #-} strengthEffect f itemFull =   case itemDisco itemFull of-    Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} ->-      concatMap f jeffects     Just ItemDisco{itemKind=ItemKind{ieffects}} ->       concatMap f ieffects     Nothing -> [] -strengthFeature :: (Feature -> [b]) -> Item -> [b]-strengthFeature f item = concatMap f (jfeature item)- strengthOnSmash :: ItemFull -> [Effect] strengthOnSmash =   let p (OnSmash eff) = [eff]@@ -74,103 +48,16 @@  strengthDropOrgan :: ItemFull -> [GroupName ItemKind] strengthDropOrgan =-  let p (DropItem COrgan grp _) = [grp]-      p (Recharging (DropItem COrgan grp _)) = [grp]+  let p (DropItem _ _ COrgan grp) = [grp]+      p (Recharging (DropItem _ _ COrgan grp)) = [grp]       p _ = []   in strengthEffect p -strengthPeriodic :: ItemFull -> Maybe Int-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-strengthAddMaxHP =-  let p (AddMaxHP k) = [k]-      p _ = []-  in strengthAspectMaybe p--strengthAddMaxCalm :: ItemFull -> Maybe Int-strengthAddMaxCalm =-  let p (AddMaxCalm k) = [k]-      p _ = []-  in strengthAspectMaybe p--strengthAddSpeed :: ItemFull -> Maybe Int-strengthAddSpeed =-  let p (AddSpeed k) = [k]-      p _ = []-  in strengthAspectMaybe p--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) = [EM.findWithDefault 0 ab a]-      p _ = []-  in strengthAspectMaybe p--strengthAddHurtMelee :: ItemFull -> Maybe Int-strengthAddHurtMelee =-  let p (AddHurtMelee k) = [k]-      p _ = []-  in strengthAspectMaybe p--strengthAddHurtRanged :: ItemFull -> Maybe Int-strengthAddHurtRanged =-  let p (AddHurtRanged k) = [k]-      p _ = []-  in strengthAspectMaybe p--strengthAddArmorMelee :: ItemFull -> Maybe Int-strengthAddArmorMelee =-  let p (AddArmorMelee k) = [k]-      p _ = []-  in strengthAspectMaybe p--strengthAddArmorRanged :: ItemFull -> Maybe Int-strengthAddArmorRanged =-  let p (AddArmorRanged k) = [k]-      p _ = []-  in strengthAspectMaybe p--strengthAddSight :: ItemFull -> Maybe Int-strengthAddSight =-  let p (AddSight k) = [k]-      p _ = []-  in strengthAspectMaybe p--strengthAddSmell :: ItemFull -> Maybe Int-strengthAddSmell =-  let p (AddSmell k) = [k]-      p _ = []-  in strengthAspectMaybe p--strengthAddLight :: ItemFull -> Maybe Int-strengthAddLight =-  let p (AddLight k) = [k]-      p _ = []-  in strengthAspectMaybe p--strengthEqpSlot :: Item -> Maybe (EqpSlot, Text)+strengthEqpSlot :: ItemFull -> Maybe EqpSlot strengthEqpSlot item =-  let p (EqpSlot eqpSlot t) = [(eqpSlot, t)]+  let p (EqpSlot eqpSlot) = [eqpSlot]       p _ = []-  in case strengthFeature p item of+  in case strengthEffect p item of     [] -> Nothing     [x] -> Just x     xs -> assert `failure` (xs, item)@@ -179,7 +66,7 @@ strengthToThrow item =   let p (ToThrow tmod) = [tmod]       p _ = []-  in case strengthFeature p item of+  in case concatMap p (jfeature item) of     [] -> ThrowMod 100 100     [x] -> x     xs -> assert `failure` (xs, item)@@ -188,7 +75,7 @@ computeTrajectory weight throwVelocity throwLinger path =   let speed = speedFromWeight weight throwVelocity       trange = rangeFromSpeedAndLinger speed throwLinger-      btrajectory = take trange $ pathToTrajectory path+      btrajectory = pathToTrajectory $ take trange path   in (btrajectory, (speed, trange))  itemTrajectory :: Item -> [Point] -> ([Vector], (Speed, Int))@@ -199,69 +86,97 @@ totalRange :: Item -> Int totalRange item = snd $ snd $ itemTrajectory item [] --- TODO: when all below are aspects, define with--- (EqpSlotAddMaxHP, AddMaxHP k) -> [k]-strengthFromEqpSlot :: EqpSlot -> ItemFull -> Maybe Int-strengthFromEqpSlot eqpSlot =+prEqpSlot :: EqpSlot -> AspectRecord -> Int+prEqpSlot eqpSlot ar@AspectRecord{..} =   case eqpSlot of-    EqpSlotPeriodic -> strengthPeriodic-    EqpSlotTimeout -> strengthTimeout-    EqpSlotAddMaxHP -> strengthAddMaxHP-    EqpSlotAddMaxCalm -> strengthAddMaxCalm-    EqpSlotAddSpeed -> strengthAddSpeed-    EqpSlotAddSkills ab -> strengthAddSkills ab-    EqpSlotAddHurtMelee -> strengthAddHurtMelee-    EqpSlotAddHurtRanged -> strengthAddHurtRanged-    EqpSlotAddArmorMelee -> strengthAddArmorMelee-    EqpSlotAddArmorRanged -> strengthAddArmorRanged-    EqpSlotAddSight -> strengthAddSight-    EqpSlotAddSmell -> strengthAddSmell-    EqpSlotAddLight -> strengthAddLight-    EqpSlotWeapon -> strengthMelee--strengthMelee :: ItemFull -> Maybe Int-strengthMelee itemFull =-  let p (Hurt d) = [Dice.meanDice d]-      p (Burn d) = [Dice.meanDice d]-      p _ = []-      psum = sum (strengthEffect p itemFull)-  in if psum == 0 then Nothing else Just psum+    EqpSlotMiscBonus ->+      aTimeout  -- usually better items have longer timeout+      + aMaxCalm + aSmell+      + aNocto  -- powerful, but hard to boost over aSight+    EqpSlotAddHurtMelee -> aHurtMelee+    EqpSlotAddArmorMelee -> aArmorMelee+    EqpSlotAddArmorRanged -> aArmorRanged+    EqpSlotAddMaxHP -> aMaxHP+    EqpSlotAddSpeed -> aSpeed+    EqpSlotAddSight -> aSight+    EqpSlotLightSource -> aShine+    EqpSlotWeapon -> assert `failure` ar+    EqpSlotMiscAbility ->+      EM.findWithDefault 0 Ability.AbWait aSkills+      + EM.findWithDefault 0 Ability.AbMoveItem aSkills+    EqpSlotAbMove -> EM.findWithDefault 0 Ability.AbMove aSkills+    EqpSlotAbMelee -> EM.findWithDefault 0 Ability.AbMelee aSkills+    EqpSlotAbDisplace -> EM.findWithDefault 0 Ability.AbDisplace aSkills+    EqpSlotAbAlter -> EM.findWithDefault 0 Ability.AbAlter aSkills+    EqpSlotAbProject -> EM.findWithDefault 0 Ability.AbProject aSkills+    EqpSlotAbApply -> EM.findWithDefault 0 Ability.AbApply aSkills+    EqpSlotAddMaxCalm -> aMaxCalm+    EqpSlotAddSmell -> aSmell+    EqpSlotAddNocto -> aNocto+    EqpSlotAddAggression -> aAggression+    EqpSlotAbWait -> EM.findWithDefault 0 Ability.AbWait aSkills+    EqpSlotAbMoveItem -> EM.findWithDefault 0 Ability.AbMoveItem aSkills -strongestSlotNoFilter :: EqpSlot -> [(ItemId, ItemFull)]-                      -> [(Int, (ItemId, ItemFull))]-strongestSlotNoFilter eqpSlot is =-  let f = strengthFromEqpSlot eqpSlot-      g (iid, itemFull) = (\v -> (v, (iid, itemFull))) <$> f itemFull-  in sortBy (flip $ Ord.comparing fst) $ mapMaybe g is+hasCharge :: Time -> ItemFull -> Bool+hasCharge localTime itemFull@ItemFull{..} =+  let timeout = aTimeout $ aspectRecordFull itemFull+      timeoutTurns = timeDeltaScale (Delta timeTurn) timeout+      charging startT = timeShift startT timeoutTurns > localTime+      it1 = filter charging itemTimer+  in length it1 < itemK -strongestSlot :: EqpSlot -> [(ItemId, ItemFull)]-              -> [(Int, (ItemId, ItemFull))]-strongestSlot eqpSlot is =-  let f (_, itemFull) = case strengthEqpSlot $ itemBase itemFull of-        Just (eqpSlot2, _) | eqpSlot2 == eqpSlot -> True-        _ -> False-      slotIs = filter f is-  in strongestSlotNoFilter eqpSlot slotIs+damageUsefulness :: Item -> Int+damageUsefulness item = min 1000 (10 * Dice.meanDice (jdamage item)) -sumSlotNoFilter :: EqpSlot -> [ItemFull] -> Int-sumSlotNoFilter eqpSlot is =-  let f = strengthFromEqpSlot eqpSlot-      g itemFull = (* itemK itemFull) <$> f itemFull-  in sum $ mapMaybe g is+strongestMelee :: Maybe DiscoveryBenefit -> Time -> [(ItemId, ItemFull)]+               -> [(Int, (ItemId, ItemFull))]+strongestMelee _ _ [] = []+strongestMelee mdiscoBenefit localTime is =+  -- For simplicity we assume, if weapon not recharged, all important effects,+  -- good and bad, are disabled and only raw damage remains.+  let f (iid, itemFull) =+        let rawDmg = (damageUsefulness $ itemBase itemFull, (iid, itemFull))+        in case mdiscoBenefit of+          Just discoBenefit | hasCharge localTime itemFull ->+            -- For fighting, as opposed to equipping, we value weapon+            -- only for its raw damage and harming effects.+            case EM.lookup iid discoBenefit of+              Just Benefit{benMelee} -> (- benMelee, (iid, itemFull))+              Nothing -> rawDmg+          _  -> rawDmg+  -- We can't filter out weapons that are not harmful to victim+  -- (@benMelee >= 0), because actors use them if nothing else available,+  -- e.g., geysers, bees. This is intended and fun.+  in sortBy (flip $ Ord.comparing fst) $ map f is -sumSkills :: [ItemFull] -> Ability.Skills-sumSkills is =-  let g itemFull = Ability.scaleSkills (itemK itemFull)-                   <$> strengthAllAddSkills itemFull-  in foldr Ability.addSkills Ability.zeroSkills $ mapMaybe g is+-- This ignores items that don't go into equipment, as determined in @inEqp@.+-- They are removed from equipment elsewhere via @harmful@.+strongestSlot :: DiscoveryBenefit -> EqpSlot -> [(ItemId, ItemFull)]+              -> [(Int, (ItemId, ItemFull))]+strongestSlot discoBenefit eqpSlot is =+  let f (iid, itemFull) =+        let rawDmg = damageUsefulness $ itemBase itemFull+            (bInEqp, bPickup) = case EM.lookup iid discoBenefit of+               Just Benefit{benInEqp, benPickup} -> (benInEqp, benPickup)+               Nothing -> (goesIntoEqp $ itemBase itemFull, rawDmg)+        in if not bInEqp+           then Nothing+           else Just $+             let ben = if eqpSlot == EqpSlotWeapon+                       -- For equipping/unequipping a weapon we take into+                       -- account not only melee power, but also aspects, etc.+                       then bPickup+                       else prEqpSlot eqpSlot $ aspectRecordFull itemFull+             in (ben, (iid, itemFull))+  in sortBy (flip $ Ord.comparing fst) $ mapMaybe f is -unknownAspect :: (Aspect Dice.Dice -> [Dice.Dice]) -> ItemFull -> Bool+unknownAspect :: (Aspect -> [Dice.Dice]) -> ItemFull -> Bool unknownAspect f itemFull =   case itemDisco itemFull of-    Just ItemDisco{itemAE=Nothing, itemKind=ItemKind{iaspects}} ->+    Just ItemDisco{itemAspect=Nothing, itemKind=ItemKind{iaspects}} ->       let unknown x = Dice.minDice x /= Dice.maxDice x       in or $ concatMap (map unknown . f) iaspects-    _ -> False+    _ -> False  -- we don't know if it affect the aspect, so we assume 0  unknownMelee :: [ItemFull] -> Bool unknownMelee =@@ -270,8 +185,8 @@       f itemFull b = b || unknownAspect p itemFull   in foldr f False -allRecharging :: [Effect] -> [Effect]-allRecharging effs =+filterRecharging :: [Effect] -> [Effect]+filterRecharging effs =   let getRechargingEffect :: Effect -> Maybe Effect       getRechargingEffect e@Recharging{} = Just e       getRechargingEffect _ = Nothing

+ Game/LambdaHack/Common/JSFile.hs view

@@ -0,0 +1,85 @@+-- | Saving/loading with serialization and compression.+module Game.LambdaHack.Common.JSFile+  ( encodeEOF, strictDecodeEOF+  , tryCreateDir, doesFileExist, tryWriteFile, readFile, renameFile+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Data.Binary+import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.Text as T+import Data.Text.Encoding (decodeLatin1)+import GHCJS.DOM (currentWindow)+import GHCJS.DOM.Storage (getItem, removeItem, setItem)+import GHCJS.DOM.Types (runDOM)+import GHCJS.DOM.Window (getLocalStorage)++-- | Serialize and save data with an EOF marker. In JS, compression+-- is probably performed by the browser and we don't have access+-- to the zlib library anyway, so we don't compress here.+-- The @OK@ is used as an EOF marker to ensure any apparent problems with+-- corrupted files are reported to the user ASAP.+encodeEOF :: Binary a => FilePath -> a -> IO ()+encodeEOF path a = flip runDOM undefined $ do+  Just win <- currentWindow+  storage <- getLocalStorage win+  setItem storage path $ decodeLatin1 $ LBS.toStrict+                       $ encode (a, "OK" :: String)++-- | Read and deserialize data with an EOF marker.+-- The @OK@ EOF marker ensures any easily detectable file corruption+-- is discovered and reported before the function returns.+strictDecodeEOF :: Binary a => FilePath -> IO a+strictDecodeEOF path = flip runDOM undefined $ do+  Just win <- currentWindow+  storage <- getLocalStorage win+  Just item <- getItem storage path+  let (a, n) = decode $ LBS.pack $ T.unpack item+  if n == ("OK" :: String)+  then return $! a+  else fail $ "Fatal error: corrupted file " ++ path++-- | Try to create a directory; not needed with local storage in JS.+tryCreateDir :: FilePath -> IO ()+tryCreateDir _dir = return ()++doesFileExist :: FilePath -> IO Bool+doesFileExist path = flip runDOM undefined $ do+  Just win <- currentWindow+  storage <- getLocalStorage win+  mitem <- getItem storage path+  let fileExists = isJust (mitem :: Maybe String)+  return $! fileExists++-- | Try to write a file, given content, if the file not already there.+tryWriteFile :: FilePath -> String -> IO ()+tryWriteFile path content = flip runDOM undefined $ do+  Just win <- currentWindow+  storage <- getLocalStorage win+  mitem <- getItem storage path+  let fileExists = isJust (mitem :: Maybe String)+  unless fileExists $+    setItem storage path content++readFile :: FilePath -> IO String+readFile path = flip runDOM undefined $ do+  Just win <- currentWindow+  storage <- getLocalStorage win+  mitem <- getItem storage path+  case mitem of+    Nothing -> assert `failure` "Fatal error: no file " ++ path+    Just item -> return item++renameFile :: FilePath -> FilePath -> IO ()+renameFile path path2 = flip runDOM undefined $ do+  Just win <- currentWindow+  storage <- getLocalStorage win+  mitem <- getItem storage path+  case mitem :: Maybe String of+    Nothing -> assert `failure` "Fatal error: no file " ++ path+    Just item -> do+      setItem storage path2 item  -- overwrites+      removeItem storage path

Game/LambdaHack/Common/Kind.hs view

@@ -1,21 +1,20 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, TypeFamilies #-} -- | General content types and operations. module Game.LambdaHack.Common.Kind-  ( Id, Speedup, Ops(..), COps(..), createOps, stdRuleset+  ( Id, Ops(..), COps(..), createOps, stdRuleset   ) where -import Control.Exception.Assert.Sugar-import Data.Binary-import qualified Data.EnumMap.Strict as EM-import qualified Data.Ix as Ix-import Data.List+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import qualified Data.Map.Strict as M import qualified Data.Text as T+import qualified Data.Vector as V  import Game.LambdaHack.Common.ContentDef import Game.LambdaHack.Common.Frequency+import Game.LambdaHack.Common.KindOps import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Random import Game.LambdaHack.Content.CaveKind import Game.LambdaHack.Content.ItemKind@@ -24,110 +23,87 @@ import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind --- | Content identifiers for the content type @c@.-newtype Id c = Id Word8-  deriving (Show, Eq, Ord, Ix.Ix, Enum, Bounded, Binary)---- | Type family for auxiliary data structures for speeding up--- content operations.-type family Speedup a---- | Content operations for the content of type @a@.-data Ops a = Ops-  { okind         :: Id a -> a          -- ^ the content element at given id-  , ouniqGroup    :: GroupName a -> Id a  -- ^ the id of the unique member of-                                          --   a singleton content group-  , opick         :: GroupName a -> (a -> Bool) -> Rnd (Maybe (Id a))-                                    -- ^ pick a random id belonging to a group-                                    --   and satisfying a predicate-  , ofoldrWithKey :: forall b. (Id a -> a -> b -> b) -> b -> b-                                    -- ^ fold over all content elements of @a@-  , ofoldrGroup   :: forall b.-                     GroupName a -> (Int -> Id a -> a -> b -> b) -> b -> b-                                    -- ^ fold over the given group only-  , obounds       :: !(Id a, Id a)  -- ^ bounds of identifiers of content @a@-  , ospeedup      :: !(Maybe (Speedup a))  -- ^ auxiliary speedup components-  }-+-- Not specialized, because no speedup, but huge JS code bloat. -- | Create content operations for type @a@ from definition of content -- of type @a@. createOps :: forall a. Show a => ContentDef a -> Ops a createOps ContentDef{getName, getFreq, content, validateSingle, validateAll} =-  assert (length content <= fromEnum (maxBound :: Id a)) $-  let kindMap :: EM.EnumMap (Id a) a-      !kindMap = EM.fromDistinctAscList $ zip [Id 0..] content-      kindFreq :: M.Map (GroupName a) [(Int, (Id a, a))]+  assert (V.length content <= fromEnum (maxBound :: Id a)) $+  let kindFreq :: M.Map (GroupName a) [(Int, (Id a, a))]       kindFreq =         let tuples = [ (cgroup, (n, (i, k)))-                     | (i, k) <- EM.assocs kindMap+                     | (i, k) <- zip [Id 0..] $ V.toList content                      , (cgroup, n) <- getFreq k                      , n > 0 ]             f m (cgroup, nik) = M.insertWith (++) cgroup [nik] m         in foldl' f M.empty tuples-      okind i = let assFail = assert `failure` "no kind" `twith` (i, kindMap)-                in EM.findWithDefault assFail i kindMap       correct a = not (T.null (getName a)) && all ((> 0) . snd) (getFreq a)       singleOffenders = [ (offences, a)-                        | a <- content+                        | a <- V.toList content                         , let offences = validateSingle a                         , not (null offences) ]-      allOffences = validateAll content-  in assert (allB correct content) $+      allOffences = validateAll $ V.toList content+  in assert (allB correct $ V.toList content) $      assert (null singleOffenders `blame` "some content items not valid"                                   `twith` singleOffenders) $      assert (null allOffences `blame` "the content set not valid"-                              `twith` (allOffences, content))+                              `twith` allOffences)      -- By this point 'content' can be GCd.      Ops-       { okind-       , ouniqGroup = \cgroup ->+       { okind = \ !i -> content V.! fromEnum i+       , ouniqGroup = \ !cgroup ->            let freq = let assFail = assert `failure` "no unique group"                                            `twith` (cgroup, kindFreq)                       in M.findWithDefault assFail cgroup kindFreq            in case freq of              [(n, (i, _))] | n > 0 -> i              l -> assert `failure` "not unique" `twith` (l, cgroup, kindFreq)-       , opick = \cgroup p ->+       , opick = \ !cgroup !p ->            case M.lookup cgroup kindFreq of              Just freqRaw ->-               let freq = toFreq ("opick ('" <> tshow cgroup <> "')") freqRaw+               let freq = toFreq ("opick ('" <> tshow cgroup <> "')")+                          $ filter (p . snd . snd) freqRaw                in if nullFreq freq                   then return Nothing-                  else fmap Just $ frequency $ do+                  else fmap (Just . fst) $ frequency freq+                    {- with monadic notation; may produce empty freq:                     (i, k) <- freq                     breturn (p k) i+                    -}                     {- with MonadComprehensions:                     frequency [ i | (i, k) <- kindFreq M.! cgroup, p k ]                     -}              _ -> return Nothing-       , ofoldrWithKey = \f z -> foldr (uncurry f) z $ EM.assocs kindMap-       , ofoldrGroup = \cgroup f z ->+       , ofoldrWithKey = \f z ->+          V.ifoldr (\i c a -> f (toEnum i) c a) z content+       , ofoldlWithKey' = \f z ->+          V.ifoldl' (\a i c -> f a (toEnum i) c) z content+       , ofoldlGroup' = \cgroup f z ->            case M.lookup cgroup kindFreq of-             Just freq -> foldr (\(p, (i, a)) -> f p i a) z freq+             Just freq -> foldl' (\acc (p, (i, a)) -> f acc p i a) z freq              _ -> assert `failure` "no group '" <> tshow cgroup                                    <> "' among content that has groups"                                    <+> tshow (M.keys kindFreq)-       , obounds = ( fst $ EM.findMin kindMap-                   , fst $ EM.findMax kindMap )-       , ospeedup = Nothing  -- define elsewhere+       , olength = V.length content        }  -- | Operations for all content types, gathered together. data COps = COps-  { cocave  :: !(Ops CaveKind)     -- server only-  , coitem  :: !(Ops ItemKind)-  , comode  :: !(Ops ModeKind)     -- server only-  , coplace :: !(Ops PlaceKind)    -- server only, so far-  , corule  :: !(Ops RuleKind)-  , cotile  :: !(Ops TileKind)+  { cocave        :: !(Ops CaveKind)     -- server only+  , coitem        :: !(Ops ItemKind)+  , comode        :: !(Ops ModeKind)     -- server only+  , coplace       :: !(Ops PlaceKind)    -- server only, so far+  , corule        :: !(Ops RuleKind)+  , cotile        :: !(Ops TileKind)+  , coTileSpeedup :: !TileSpeedup   } --- | The standard ruleset used for level operations.-stdRuleset :: Ops RuleKind -> RuleKind-stdRuleset Ops{ouniqGroup, okind} = okind $ ouniqGroup "standard"- instance Show COps where   show _ = "game content"  instance Eq COps where   (==) _ _ = True++-- | The standard ruleset used for level operations.+stdRuleset :: Ops RuleKind -> RuleKind+stdRuleset Ops{ouniqGroup, okind} = okind $ ouniqGroup "standard"

+ Game/LambdaHack/Common/KindOps.hs view

@@ -0,0 +1,37 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes #-}+-- | General content types and operations.+module Game.LambdaHack.Common.KindOps+  ( Id(Id), Ops(..)+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Data.Binary++import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Random++-- | Content identifiers for the content type @c@.+newtype Id c = Id Word16+  deriving (Show, Eq, Ord, Enum, Bounded, Binary)++-- | Content operations for the content of type @a@.+data Ops a = Ops+  { okind         :: !(Id a -> a)  -- ^ content element at given id+  , ouniqGroup    :: !(GroupName a -> Id a)+                                   -- ^ the id of the unique member of+                                   --   a singleton content group+  , opick         :: !(GroupName a -> (a -> Bool) -> Rnd (Maybe (Id a)))+                                   -- ^ pick a random id belonging to a group+                                   --   and satisfying a predicate+  , ofoldrWithKey :: !(forall b. (Id a -> a -> b -> b) -> b -> b)+                                   -- ^ fold over all content elements of @a@+  , ofoldlWithKey' :: !(forall b. (b -> Id a -> a -> b) -> b -> b)+                                   -- ^ fold strictly over all content @a@+  , ofoldlGroup'  :: !(forall b.+                     GroupName a -> (b -> Int -> Id a -> a -> b) -> b -> b)+                                   -- ^ fold over the given group only+  , olength       :: !Int          -- ^ size of content @a@+  }

− Game/LambdaHack/Common/LQueue.hs

@@ -1,59 +0,0 @@--- | Queues implemented with two stacks to ensure fast writes.-module Game.LambdaHack.Common.LQueue-  ( LQueue-  , newLQueue, nullLQueue, lengthLQueue, tryReadLQueue, writeLQueue-  , trimLQueue, dropStartLQueue, lastLQueue, toListLQueue-  ) where--import Data.Maybe---- | Queues implemented with two stacks.-type LQueue a = ([a], [a])  -- (read_end, write_end)---- | Create a new empty mutable queue.-newLQueue :: LQueue a-newLQueue = ([], [])---- | Check if the queue is empty.-nullLQueue :: LQueue a -> Bool-nullLQueue (rs, ws) = null rs && null ws---- | The length of the queue.-lengthLQueue :: LQueue a -> Int-lengthLQueue (rs, ws) = length rs + length ws---- | Try reading a queue. Return @Nothing@ if empty.-tryReadLQueue :: LQueue a -> Maybe (a, LQueue a)-tryReadLQueue (r : rs, ws) = Just (r, (rs, ws))-tryReadLQueue ([], []) = Nothing-tryReadLQueue ([], ws) = tryReadLQueue (reverse ws, [])---- | Write to the queue. Faster than reading.-writeLQueue :: LQueue a -> a -> LQueue a-writeLQueue (rs, ws) w = (rs, w : ws)---- | Remove all but the last written non-@Nothing@ element of the queue.-trimLQueue :: LQueue (Maybe a) -> LQueue (Maybe a)-trimLQueue (rs, ws) =-  let trim (_, w:_) = ([w], [])-      trim ([], []) = ([], [])-      trim (rsj, []) = ([last rsj], [])-  in trim (filter isJust rs, filter isJust ws)---- | Remove frames up to and including the first segment of @Nothing@ frames.--- | If the resulting queue is empty, apply trimLQueue instead.-dropStartLQueue :: LQueue (Maybe a) -> LQueue (Maybe a)-dropStartLQueue (rs, ws) =-  let dq = (dropWhile isNothing $ dropWhile isJust $ rs ++ reverse ws, [])-  in if nullLQueue dq then trimLQueue (rs, ws) else dq---- | Dump all but the last written non-@Nothing@ element of the queue, if any.-lastLQueue :: LQueue (Maybe a) -> Maybe a-lastLQueue (rs, ws) =-  let lst (_, w:_) = Just w-      lst ([], []) = Nothing-      lst (rsj, []) = Just $ last rsj-  in lst (catMaybes rs, catMaybes ws)--toListLQueue :: LQueue a -> [a]-toListLQueue (rs, ws) = rs ++ reverse ws

Game/LambdaHack/Common/Level.hs view

@@ -2,74 +2,98 @@ -- as the game progresses. module Game.LambdaHack.Common.Level   ( -- * Dungeon-    LevelId, AbsDepth, Dungeon, ascendInBranch+    LevelId, AbsDepth, Dungeon+  , ascendInBranch, whereTo     -- * The @Level@ type and its components-  , Level(..), ActorPrio, ItemFloor, TileMap, SmellMap+  , Level(..), ItemFloor, ActorMap, TileMap, SmellMap     -- * Level query-  , at, checkAccess, checkDoorAccess-  , accessible, accessibleUnknown, accessibleDir-  , knownLsecret, isSecretPos, hideTile-  , findPos, findPosTry, mapLevelActors_, mapDungeonActors_- ) where+  , at, findPoint, findPos, findPosTry, findPosTry2+  ) where -import Control.Exception.Assert.Sugar+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Data.Binary-import qualified Data.Bits as Bits import qualified Data.EnumMap.Strict as EM-import Data.Maybe-import Data.Text (Text)  import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind+import qualified Game.LambdaHack.Common.KindOps as KindOps import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Tile-import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ItemKind (ItemKind)-import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind (TileKind)  -- | The complete dungeon is a map from level names to levels. type Dungeon = EM.EnumMap LevelId Level  -- | Levels in the current branch, @k@ levels shallower than the current.-ascendInBranch :: Dungeon -> Int -> LevelId -> [LevelId]-ascendInBranch dungeon k lid =+ascendInBranch :: Dungeon -> Bool -> LevelId -> [LevelId]+ascendInBranch dungeon up lid =   -- Currently there is just one branch, so the computation is simple.   let (minD, maxD) =         case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of           (Just ((s, _), _), Just ((e, _), _)) -> (s, e)           _ -> assert `failure` "null dungeon" `twith` dungeon-      ln = max minD $ min maxD $ toEnum $ fromEnum lid + k+      ln = max minD $ min maxD $ toEnum $ fromEnum lid + if up then 1 else -1   in case EM.lookup ln dungeon of     Just _ | ln /= lid -> [ln]     _ | ln == lid -> []-    _ -> ascendInBranch dungeon k ln  -- jump over gaps+    _ -> ascendInBranch dungeon up ln  -- jump over gaps --- | Actor time priority queue.-type ActorPrio = EM.EnumMap Time [ActorId]+-- | Compute the level identifier and stair position on the new level,+-- after a level change.+--+-- We assume there is never a staircase up and down at the same position.+whereTo :: LevelId    -- ^ level of the stairs+        -> Point      -- ^ position of the stairs+        -> Maybe Bool -- ^ optional forced direction+        -> Dungeon    -- ^ current game dungeon+        -> (LevelId, Point)+                      -- ^ destination level and the pos of its receiving stairs+whereTo lid pos mup dungeon =+  let lvl = dungeon EM.! lid+      (up, i) = case elemIndex pos $ fst $ lstair lvl of+        Just ifst -> (True, ifst)+        Nothing -> case elemIndex pos $ snd $ lstair lvl of+          Just isnd -> (False, isnd)+          Nothing -> case mup of+            Just forcedUp -> (forcedUp, 0)  -- for ascending via, e.g., spells+            Nothing -> assert `failure` "no stairs at" `twith` (lid, pos)+      !_A = assert (maybe True (== up) mup) ()+  in case ascendInBranch dungeon up lid of+    [] | isJust mup -> (lid, pos)  -- spell fizzles+    [] -> assert `failure` "no dungeon level to go to" `twith` (lid, pos)+    ln : _ -> let lvlDest = dungeon EM.! ln+                  stairsDest = (if up then snd else fst) (lstair lvlDest)+              in if length stairsDest < i + 1+                 then assert `failure` "no stairs at index" `twith` (lid, pos)+                 else (ln, stairsDest !! i)  -- | Items located on map tiles. type ItemFloor = EM.EnumMap Point ItemBag +-- | Items located on map tiles.+type ActorMap = EM.EnumMap Point [ActorId]+ -- | Tile kinds on the map.-type TileMap = PointArray.Array (Kind.Id TileKind)+type TileMap = PointArray.GArray Word16 (Kind.Id TileKind)  -- | Current smell on map tiles.-type SmellMap = EM.EnumMap Point SmellTime+type SmellMap = EM.EnumMap Point Time  -- | A view on single, inhabited dungeon level. "Remembered" fields -- carry a subset of the info in the client copies of levels. data Level = Level   { ldepth      :: !AbsDepth   -- ^ absolute depth of the level-  , lprio       :: !ActorPrio  -- ^ remembered actor times on the level   , lfloor      :: !ItemFloor  -- ^ remembered items lying on the floor   , lembed      :: !ItemFloor  -- ^ items embedded in the tile+  , lactor      :: !ActorMap   -- ^ seen actors at positions on the level   , ltile       :: !TileMap    -- ^ remembered level map   , lxsize      :: !X          -- ^ width of the level   , lysize      :: !Y          -- ^ height of the level@@ -79,14 +103,15 @@                                -- ^ positions of (up, down) stairs   , lseen       :: !Int        -- ^ currently remembered clear tiles   , lclear      :: !Int        -- ^ total number of initially clear tiles-  , ltime       :: !Time       -- ^ date of the last activity on the level+  , ltime       :: !Time       -- ^ local time on the level (possibly frozen)   , lactorCoeff :: !Int        -- ^ the lower, the more monsters spawn-  , lactorFreq  :: !(Freqs ItemKind)  -- ^ frequency of spawned actors; [] for clients+  , lactorFreq  :: !(Freqs ItemKind)+                               -- ^ frequency of spawned actors; [] for clients   , litemNum    :: !Int        -- ^ number of initial items, 0 for clients-  , litemFreq   :: !(Freqs ItemKind)  -- ^ frequency of initial items; [] for clients-  , lsecret     :: !Int        -- ^ secret tile seed-  , lhidden     :: !Int        -- ^ secret tile density+  , litemFreq   :: !(Freqs ItemKind)+                               -- ^ frequency of initial items; [] for clients   , lescape     :: ![Point]    -- ^ positions of IK.Escape tiles+  , lnight      :: !Bool   }   deriving (Show, Eq) @@ -95,129 +120,85 @@   assert (EM.null (EM.filter EM.null m)           `blame` "null floors found" `twith` m) m +assertSparseActors :: ActorMap -> ActorMap+assertSparseActors m =+  assert (EM.null (EM.filter null m)+          `blame` "null actor lists found" `twith` m) m+ -- | Query for tile kinds on the map. at :: Level -> Point -> Kind.Id TileKind {-# INLINE at #-} at Level{ltile} p = ltile PointArray.! p -checkAccess :: Kind.COps -> Level -> Maybe (Point -> Point -> Bool)-checkAccess Kind.COps{corule} _ =-  case raccessible $ Kind.stdRuleset corule of-    Nothing -> Nothing-    Just ch -> Just $ \spos tpos -> ch spos tpos--checkDoorAccess :: Kind.COps -> Level -> Maybe (Point -> Point -> Bool)-checkDoorAccess Kind.COps{corule, cotile} lvl =-  case raccessibleDoor $ Kind.stdRuleset corule of-    Nothing -> Nothing-    Just chDoor ->-      Just $ \spos tpos ->-        let st = lvl `at` spos-            tt = lvl `at` tpos-        in not (Tile.isDoor cotile st || Tile.isDoor cotile tt)-           || chDoor spos tpos---- | Check whether one position is accessible from another,--- using the formula from the standard ruleset.--- Precondition: the two positions are next to each other.-accessible :: Kind.COps -> Level -> Point -> Point -> Bool-accessible cops@Kind.COps{cotile} lvl =-  let checkWalkability =-        Just $ \_ tpos -> Tile.isWalkable cotile $ lvl `at` tpos-      conditions = catMaybes [ checkWalkability-                             , checkAccess cops lvl-                             , checkDoorAccess cops lvl ]-  in \spos tpos -> all (\f -> f spos tpos) conditions---- | Check whether one position is accessible from another,--- using the formula from the standard ruleset,--- but additionally treating unknown tiles as walkable.--- Precondition: the two positions are next to each other.-accessibleUnknown :: Kind.COps -> Level -> Point -> Point -> Bool-accessibleUnknown cops@Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} lvl =-  let unknownId = ouniqGroup "unknown space"-      checkWalkability =-        Just $ \_ tpos -> let t = lvl `at` tpos-                          in Tile.isWalkable cotile t || t == unknownId-      conditions = catMaybes [ checkWalkability-                             , checkAccess cops lvl-                             , checkDoorAccess cops lvl ]-  in \spos tpos -> all (\f -> f spos tpos) conditions---- | Check whether actors can move from a position along a unit vector,--- using the formula from the standard ruleset.-accessibleDir :: Kind.COps -> Level -> Point -> Vector -> Bool-accessibleDir cops lvl spos dir = accessible cops lvl spos $ spos `shift` dir--knownLsecret :: Level -> Bool-knownLsecret lvl = lsecret lvl /= 0--isSecretPos :: Level -> Point -> Bool-isSecretPos lvl (Point x y) =-  lhidden lvl /= 0-  && (lsecret lvl `Bits.rotateR` x `Bits.xor` y + x) `mod` lhidden lvl == 0--hideTile :: Kind.COps -> Level -> Point -> Kind.Id TileKind-hideTile Kind.COps{cotile} lvl p =-  let t = lvl `at` p-      ht = Tile.hideAs cotile t  -- TODO; tabulate with Speedup?-  in if isSecretPos lvl p then ht else t+-- | Find a random position on the map satisfying a predicate.+findPoint :: X -> Y -> (Point -> Maybe Point) -> Rnd Point+findPoint x y f =+  let search = do+        pxy <- randomR (0, (x - 1) * (y - 1))+        let pos = PointArray.punindex x pxy+        case f pos of+          Just p -> return p+          Nothing -> search+  in search  -- | Find a random position on the map satisfying a predicate. findPos :: TileMap -> (Point -> Kind.Id TileKind -> Bool) -> Rnd Point findPos ltile p =   let (x, y) = PointArray.sizeA ltile       search = do-        px <- randomR (0, x - 1)-        py <- randomR (0, y - 1)-        let pos = Point{..}-            tile = ltile PointArray.! pos+        pxy <- randomR (0, (x - 1) * (y - 1))+        let tile = KindOps.Id $ ltile `PointArray.accessI` pxy+            pos = PointArray.punindex x pxy         if p pos tile-          then return $! pos-          else search+        then return $! pos+        else search   in search  -- | Try to find a random position on the map satisfying--- the conjunction of the list of predicates.+-- conjunction of the mandatory and an optional predicate. -- If the permitted number of attempts is not enough,--- try again the same number of times without the first predicate,--- then without the first two, etc., until only one predicate remains,--- at which point try as many times, as needed.+-- try again the same number of times without the next optional predicate,+-- and fall back to trying as many times, as needed, with only the mandatory+-- predicate. findPosTry :: Int                                  -- ^ the number of tries            -> TileMap                              -- ^ look up in this map            -> (Point -> Kind.Id TileKind -> Bool)  -- ^ mandatory predicate            -> [Point -> Kind.Id TileKind -> Bool]  -- ^ optional predicates            -> Rnd Point-findPosTry _        ltile m []         = findPos ltile m-findPosTry numTries ltile m l@(_ : tl) = assert (numTries > 0) $-  let (x, y) = PointArray.sizeA ltile-      search 0 = findPosTry numTries ltile m tl-      search k = do-        px <- randomR (0, x - 1)-        py <- randomR (0, y - 1)-        let pos = Point{..}-            tile = ltile PointArray.! pos-        if m pos tile && all (\p -> p pos tile) l-          then return $! pos-          else search (k - 1)-  in search numTries--mapLevelActors_ :: Monad m => (ActorId -> m a) -> Level -> m ()-mapLevelActors_ f Level{lprio} = do-  let as = concat $ EM.elems lprio-  mapM_ f as+{-# INLINE findPosTry #-}+findPosTry numTries ltile m = findPosTry2 numTries ltile m [] undefined -mapDungeonActors_ :: Monad m => (ActorId -> m a) -> Dungeon -> m ()-mapDungeonActors_ f dungeon = do-  let ls = EM.elems dungeon-  mapM_ (mapLevelActors_ f) ls+findPosTry2 :: Int                                  -- ^ the number of tries+            -> TileMap                              -- ^ look up in this map+            -> (Point -> Kind.Id TileKind -> Bool)  -- ^ mandatory predicate+            -> [Point -> Kind.Id TileKind -> Bool]  -- ^ optional predicates+            -> (Point -> Kind.Id TileKind -> Bool)  -- ^ good to have predicate+            -> [Point -> Kind.Id TileKind -> Bool]  -- ^ worst case predicates+            -> Rnd Point+findPosTry2 numTries ltile m0 l g r = assert (numTries > 0) $+  let (x, y) = PointArray.sizeA ltile+      accomodate fallback _ [] = fallback  -- fallback needs to be non-strict+      accomodate fallback m (hd : tl) =+        let search 0 = accomodate fallback m tl+            search !k = do+              pxy <- randomR (0, (x - 1) * (y - 1))+              let tile = KindOps.Id $ ltile `PointArray.accessI` pxy+                  pos = PointArray.punindex x pxy+              if m pos tile && hd pos tile+              then return $! pos+              else search (k - 1)+        in search numTries+  in accomodate (accomodate (findPos ltile m0) m0 r)+                -- @pos@ or @tile@ not always needed, so not strict+                (\pos tile -> m0 pos tile && g pos tile)+                l  instance Binary Level where   put Level{..} = do     put ldepth-    put lprio     put (assertSparseItems lfloor)     put (assertSparseItems lembed)+    put (assertSparseActors lactor)     put ltile     put lxsize     put lysize@@ -231,14 +212,13 @@     put lactorFreq     put litemNum     put litemFreq-    put lsecret-    put lhidden     put lescape+    put lnight   get = do     ldepth <- get-    lprio <- get     lfloor <- get     lembed <- get+    lactor <- get     ltile <- get     lxsize <- get     lysize <- get@@ -252,7 +232,6 @@     lactorFreq <- get     litemNum <- get     litemFreq <- get-    lsecret <- get-    lhidden <- get     lescape <- get+    lnight <- get     return $! Level{..}

Game/LambdaHack/Common/Misc.hs view

@@ -1,5 +1,7 @@ {-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-orphans #-}+#endif -- | Hacks that haven't found their home yet. module Game.LambdaHack.Common.Misc   ( -- * Game object identifiers@@ -7,51 +9,54 @@     -- * Item containers   , Container(..), CStore(..), ItemDialogMode(..)     -- * Assorted-  , normalLevelBound, divUp, GroupName, toGroupName, Freqs, breturn-  , serverSaveName, Rarity, validateRarity, Tactic(..)-    -- * Backward compatibility-  , isRight+  , makePhrase, makeSentence+  , normalLevelBound, GroupName, toGroupName, Freqs, breturn+  , Rarity, validateRarity+  , Tactic(..), describeTactic, appDataDir+  , xM, minusM, minusM1, oneM   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Control.DeepSeq-import Control.Monad import Data.Binary+import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES+import qualified Data.Fixed as Fixed import Data.Function-import Data.Functor import Data.Hashable import qualified Data.HashMap.Strict as HM+import Data.Int (Int64) import Data.Key-import Data.List import Data.Ord import Data.String (IsString (..))-import Data.Text (Text) import qualified Data.Text as T-import Data.Traversable (traverse)+import qualified Data.Time as Time import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU+import System.Directory (getAppUserDataDirectory)+import System.Environment (getProgName)  import Game.LambdaHack.Common.Point -serverSaveName :: String-serverSaveName = "server.sav"+-- | Re-exported English phrase creation functions, applied to default+-- irregular word sets.+makePhrase, makeSentence :: [MU.Part] -> Text+makePhrase = MU.makePhrase MU.defIrregular+makeSentence = MU.makeSentence MU.defIrregular --- | Level bounds. TODO: query terminal size instead and scroll view.+-- | Level bounds. normalLevelBound :: (Int, Int) normalLevelBound = (79, 20) -infixl 7 `divUp`--- | Integer division, rounding up.-divUp :: Integral a => a -> a -> a-{-# INLINE divUp #-}-divUp n k = (n + k - 1) `div` k- -- If ever needed, we can use a symbol table here, since content -- is never serialized. But we'd need to cover the few cases -- (e.g., @litemFreq@) where @GroupName@ goes into savegame. newtype GroupName a = GroupName Text-  deriving (Eq, Ord, Read, Hashable, Binary, Generic)+  deriving (Read, Eq, Ord, Hashable, Binary, Generic)  instance IsString (GroupName a) where   fromString = GroupName . T.pack@@ -62,6 +67,7 @@ instance NFData (GroupName a)  toGroupName :: Text -> GroupName a+{-# INLINE toGroupName #-} toGroupName = GroupName  -- | For each group that the kind belongs to, denoted by a @GroupName@@@ -113,14 +119,16 @@  instance NFData CStore -data ItemDialogMode = MStore CStore | MOwned | MStats+data ItemDialogMode = MStore CStore | MOwned | MStats | MLoreItem | MLoreOrgan   deriving (Show, Read, Eq, Ord, Generic)  instance NFData ItemDialogMode +instance Binary ItemDialogMode+ -- | A unique identifier of a faction in a game. newtype FactionId = FactionId Int-  deriving (Show, Eq, Ord, Enum, Binary)+  deriving (Show, Eq, Ord, Enum, Hashable, Binary)  -- | Abstract level identifiers. newtype LevelId = LevelId Int@@ -137,12 +145,6 @@ newtype ActorId = ActorId Int   deriving (Show, Eq, Ord, Enum, Binary) --- TODO: there is already too many; express this somehow via skills;--- also, we risk micromanagement; perhaps only have as many tactics--- as needed for realistic AI behaviour in our game modes;--- perhaps even expose only some of them to UI; perhaps define tactics--- in rules content or in game mode defs; perhaps have skills corresponding--- to exploration. following, etc. -- | Tactic of non-leader actors. Apart of determining AI operation, -- each tactic implies a skill modifier, that is added to the non-leader skills -- defined in 'fskillsOther' field of 'Player'.@@ -158,64 +160,76 @@               --   to sight radius and fallback temporarily to @TRoam@               --   when enemy is seen by the faction and is within               --   the actor's sight radius-              --   TODO (currently the same as TExplore; should it chase-              --   targets too (TRoam) and only switch to TPatrol when none?)   deriving (Eq, Ord, Enum, Bounded, Generic)  instance Show Tactic where-  show TExplore = "explore unknown, chase targets"-  show TFollow = "follow leader's target or position"-  show TFollowNoItems = "follow leader's target or position, ignore items"-  show TMeleeAndRanged = "only melee and perform ranged combat"-  show TMeleeAdjacent = "only melee"-  show TBlock = "only block and wait"-  show TRoam = "roam freely, chase targets"-  show TPatrol = "find and patrol an area (TODO)"+  show TExplore        = "explore"+  show TFollow         = "follow freely"+  show TFollowNoItems  = "follow only"+  show TMeleeAndRanged = "fight only"+  show TMeleeAdjacent  = "melee only"+  show TBlock          = "block only"+  show TRoam           = "roam freely"+  show TPatrol         = "patrol area" +describeTactic :: Tactic -> Text+describeTactic TExplore = "investigate unknown positions, chase targets"+describeTactic TFollow = "follow leader's target or position, grab items"+describeTactic TFollowNoItems =+  "follow leader's target or position, ignore items"+describeTactic TMeleeAndRanged =+  "engage in both melee and ranged combat, don't move"+describeTactic TMeleeAdjacent = "engage exclusively in melee, don't move"+describeTactic TBlock = "block and wait, don't move"+describeTactic TRoam = "move freely, chase targets"+describeTactic TPatrol = "find and patrol an area (WIP)"+ instance Binary Tactic  instance Hashable Tactic --- TODO: remove me when we no longer suppoert GHC 7.6.*-isRight :: Either a b -> Bool-isRight e = case e of-  Right{} -> True-  Left{} -> False- -- Data.Binary  instance (Enum k, Binary k, Binary e) => Binary (EM.EnumMap k e) where-  {-# INLINEABLE put #-}   put m = put (EM.size m) >> mapM_ put (EM.toAscList m)-  {-# INLINEABLE get #-}-  get = liftM EM.fromDistinctAscList get+  get = EM.fromDistinctAscList <$> get  instance (Enum k, Binary k) => Binary (ES.EnumSet k) where-  {-# INLINEABLE put #-}   put m = put (ES.size m) >> mapM_ put (ES.toAscList m)-  {-# INLINEABLE get #-}-  get = liftM ES.fromDistinctAscList get+  get = ES.fromDistinctAscList <$> get -instance (Binary k, Binary v, Eq k, Hashable k) => Binary (HM.HashMap k v) where-  {-# INLINEABLE put #-}-  put ir = put $ HM.toList ir-  {-# INLINEABLE get #-}+#if !MIN_VERSION_binary(0,8,0)+instance Binary (Fixed.Fixed a) where+  put (Fixed.MkFixed a) = put a+  get = Fixed.MkFixed `liftM` get+#endif++instance Binary Time.NominalDiffTime where+  get = fmap realToFrac (get :: Get Fixed.Pico)+  put = (put :: Fixed.Pico -> Put) . realToFrac++instance (Hashable k, Eq k, Binary k, Binary v) => Binary (HM.HashMap k v) where   get = fmap HM.fromList get+  put = put . HM.toList  -- Data.Key  type instance Key (EM.EnumMap k) = k  instance Zip (EM.EnumMap k) where+  {-# INLINE zipWith #-}   zipWith = EM.intersectionWith  instance Enum k => ZipWithKey (EM.EnumMap k) where+  {-# INLINE zipWithKey #-}   zipWithKey = EM.intersectionWithKey  instance Enum k => Keyed (EM.EnumMap k) where+  {-# INLINE mapWithKey #-}   mapWithKey = EM.mapWithKey  instance Enum k => FoldableWithKey (EM.EnumMap k) where+  {-# INLINE foldrWithKey #-}   foldrWithKey = EM.foldrWithKey  instance Enum k => TraversableWithKey (EM.EnumMap k) where@@ -223,18 +237,20 @@                       . traverse (\(k, v) -> (,) k <$> f k v) . EM.toAscList  instance Enum k => Indexable (EM.EnumMap k) where+  {-# INLINE index #-}   index = (EM.!)  instance Enum k => Lookup (EM.EnumMap k) where+  {-# INLINE lookup #-}   lookup = EM.lookup  instance Enum k => Adjustable (EM.EnumMap k) where+  {-# INLINE adjust #-}   adjust = EM.adjust  -- Data.Hashable  instance (Enum k, Hashable k, Hashable e) => Hashable (EM.EnumMap k e) where-  {-# INLINEABLE hashWithSalt #-}   hashWithSalt s x = hashWithSalt s (EM.toAscList x)  -- Control.DeepSeq@@ -244,3 +260,19 @@ instance NFData MU.Person  instance NFData MU.Polarity++-- | Personal data directory for the game. Depends on the OS and the game,+-- e.g., for LambdaHack under Linux it's @~\/.LambdaHack\/@.+appDataDir :: IO FilePath+appDataDir = do+  progName <- getProgName+  let name = takeWhile Char.isAlphaNum progName+  getAppUserDataDirectory name++xM :: Int -> Int64+xM k = fromIntegral k * 1000000++minusM, minusM1, oneM :: Int64+minusM = xM (-1)+minusM1 = xM (-1) - 1+oneM = xM 1

Game/LambdaHack/Common/MonadStateRead.hs view

@@ -1,27 +1,36 @@+{-# LANGUAGE TupleSections #-} -- | Game action monads and basic building blocks for human and computer--- player actions. Has no access to the the main action type.+-- player actions. Has no access to the main action type. module Game.LambdaHack.Common.MonadStateRead   ( MonadStateRead(..)-  , getLevel, nUI, posOfAid, factionCanEscape-  , getGameMode, getEntryArena+  , getState, getLevel, nUI+  , getGameMode, isNoConfirmsGame, getEntryArena, pickWeaponM   ) where -import Control.Exception.Assert.Sugar+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import qualified Data.EnumMap.Strict as EM +import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Request import Game.LambdaHack.Common.State import Game.LambdaHack.Content.ModeKind -class (Monad m, Functor m) => MonadStateRead m where-  getState  :: m State+class (Monad m, Functor m, Applicative m) => MonadStateRead m where   getsState :: (State -> a) -> m a +getState :: MonadStateRead m => m State+getState = getsState id+ getLevel :: MonadStateRead m => LevelId -> m Level getLevel lid = getsState $ (EM.! lid) . sdungeon @@ -30,24 +39,17 @@   factionD <- getsState sfactionD   return $! length $ filter (fhasUI . gplayer) $ EM.elems factionD -posOfAid :: MonadStateRead m => ActorId -> m (LevelId, Point)-posOfAid aid = do-  b <- getsState $ getActorBody aid-  return (blid b, bpos b)--factionCanEscape :: MonadStateRead m => FactionId -> m Bool-factionCanEscape fid = do-  fact <- getsState $ (EM.! fid) . sfactionD-  dungeon <- getsState sdungeon-  let escape = any (not . null . lescape) $ EM.elems dungeon-  return $! escape && fcanEscape (gplayer fact)- getGameMode :: MonadStateRead m => m ModeKind getGameMode = do   Kind.COps{comode=Kind.Ops{okind}} <- getsState scops   t <- getsState sgameModeId   return $! okind t +isNoConfirmsGame :: MonadStateRead m => m Bool+isNoConfirmsGame = do+  gameMode <- getGameMode+  return $! maybe False (> 0) $ lookup "no confirms" $ mfreq gameMode+ getEntryArena :: MonadStateRead m => Faction -> m LevelId getEntryArena fact = do   dungeon <- getsState sdungeon@@ -55,4 +57,24 @@         case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of           (Just ((s, _), _), Just ((e, _), _)) -> (s, e)           _ -> assert `failure` "empty dungeon" `twith` dungeon-  return $! max minD $ min maxD $ toEnum $ fentryLevel $ gplayer fact+      f [] = 0+      f ((ln, _, _) : _) = ln+  return $! max minD $ min maxD $ toEnum $ f $ ginitial fact++pickWeaponM :: MonadStateRead m+            => Maybe DiscoveryBenefit+            -> [(ItemId, ItemFull)] -> Ability.Skills -> ActorAspect -> ActorId+            -> m [(Int, (ItemId, ItemFull))]+pickWeaponM mdiscoBenefit allAssocs actorSk actorAspect source = do+  sb <- getsState $ getActorBody source+  localTime <- getsState $ getLocalTime (blid sb)+  let ar = actorAspect EM.! source+      calmE = calmEnough sb ar+      forced = bproj sb+      permitted = permittedPrecious calmE forced+      preferredPrecious = either (const False) id . permitted+      permAssocs = filter (preferredPrecious . snd) allAssocs+      strongest = strongestMelee mdiscoBenefit localTime permAssocs+  return $! if | forced -> map (1,) allAssocs+               | EM.findWithDefault 0 Ability.AbMelee actorSk <= 0 -> []+               | otherwise -> strongest

− Game/LambdaHack/Common/Msg.hs

@@ -1,275 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | Game messages displayed on top of the screen for the player to read.-module Game.LambdaHack.Common.Msg-  ( makePhrase, makeSentence-  , Msg, (<>), (<+>), tshow, toWidth, moreMsg, endMsg, yesnoMsg, truncateMsg-  , Report, emptyReport, nullReport, singletonReport, addMsg, prependMsg-  , splitReport, renderReport, findInReport, lastMsgOfReport-  , History, emptyHistory, lengthHistory-  , addReport, renderHistory, lastReportOfHistory-  , Overlay(overlay), emptyOverlay, truncateToOverlay, toOverlay-  , Slideshow(slideshow), splitOverlay, toSlideshow-  , encodeLine, encodeOverlay, ScreenLine, toScreenLine, splitText-  )-  where--import Control.Applicative-import Control.Exception.Assert.Sugar-import Data.Binary-import qualified Data.ByteString.Char8 as BS-import Data.Int (Int32)-import Data.List-import Data.Monoid-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import Data.Vector.Binary ()-import qualified Data.Vector.Generic as G-import qualified Data.Vector.Unboxed as U-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Common.Color-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Point-import qualified Game.LambdaHack.Common.RingBuffer as RB-import Game.LambdaHack.Common.Time--infixr 6 <+>  -- TODO: not needed when we require a very new minimorph-(<+>) :: Text -> Text -> Text-(<+>) = (MU.<+>)---- Show and pack the result of @show@.-tshow :: Show a => a -> Text-tshow x = T.pack $ show x--toWidth :: Int -> Text -> Text-toWidth n x = T.take n (T.justifyLeft n ' ' x)---- | Re-exported English phrase creation functions, applied to default--- irregular word sets.-makePhrase, makeSentence :: [MU.Part] -> Text-makePhrase = MU.makePhrase MU.defIrregular-makeSentence = MU.makeSentence MU.defIrregular---- | The type of a single message.-type Msg = Text---- | The \"press something to see more\" mark.-moreMsg :: Msg-moreMsg = "--more--  "---- | The \"end of screenfuls of text\" mark.-endMsg :: Msg-endMsg = "--end--  "---- | The confirmation request message.-yesnoMsg :: Msg-yesnoMsg = "[yn]"---- | Add a space at the message end, for display overlayed over the level map.--- Also trims (does not wrap!) too long lines. In case of newlines,--- displays only the first line, but marks the message as partial.-truncateMsg :: X -> Text -> Text-truncateMsg w xsRaw =-  let xs = case T.lines xsRaw of-        [] -> xsRaw-        [line] -> line-        line : _ -> T.justifyLeft (w + 1) ' ' line-      len = T.length xs-  in case compare w len of-       LT -> T.snoc (T.take (w - 1) xs) '$'-       EQ -> xs-       GT -> if T.null xs || T.last xs == ' '-             then xs-             else T.snoc xs ' '---- | The type of a set of messages to show at the screen at once.-newtype Report = Report [(BS.ByteString, Int)]-  deriving (Show, Binary)---- | Empty set of messages.-emptyReport :: Report-emptyReport = Report []---- | Test if the set of messages is empty.-nullReport :: Report -> Bool-nullReport (Report l) = null l---- | Construct a singleton set of messages.-singletonReport :: Msg -> Report-singletonReport = addMsg emptyReport---- TODO: Differentiate from msgAdd. Generally, invent more informative names.--- | Add message to the end of report.-addMsg :: Report -> Msg -> Report-addMsg r m | T.null m = r-addMsg (Report ((x, n) : xns)) y' | x == y =-  Report $ (y, n + 1) : xns- where y = encodeUtf8 y'-addMsg (Report xns) y = Report $ (encodeUtf8 y, 1) : xns--prependMsg :: Msg -> Report -> Report-prependMsg m r | T.null m = r-prependMsg y (Report xns) = Report $ xns ++ [(encodeUtf8 y, 1)]---- | Split a messages into chunks that fit in one line.--- We assume the width of the messages line is the same as of level map.-splitReport :: X -> Report -> Overlay-splitReport w r = toOverlay $ splitReportList w r--splitReportList :: X -> Report -> [Text]-splitReportList w r = splitText w $ renderReport r---- | Render a report as a (possibly very long) string.-renderReport :: Report  -> Text-renderReport (Report []) = T.empty-renderReport (Report (xn : xs)) =-  renderReport (Report xs) <+> renderRepetition xn--renderRepetition :: (BS.ByteString, Int) -> Text-renderRepetition (s, 1) = decodeUtf8 s-renderRepetition (s, n) = decodeUtf8 s <> "<x" <> tshow n <> ">"--findInReport :: (BS.ByteString -> Bool) -> Report -> Maybe BS.ByteString-findInReport f (Report xns) = find f $ map fst xns--lastMsgOfReport :: Report -> (BS.ByteString, Report)-lastMsgOfReport (Report rep) = case rep of-  [] -> assert `failure` rep-  (lmsg, 1) : repRest -> (lmsg, Report repRest)-  (lmsg, n) : repRest -> (lmsg, Report $ (lmsg, n - 1) : repRest)---- | Split a string into lines. Avoids ending the line with a character--- other than whitespace or punctuation. Space characters are removed--- from the start, but never from the end of lines. Newlines are respected.-splitText :: X -> Text -> [Text]-splitText w xs = concatMap (splitText' w . T.stripStart) $ T.lines xs--splitText' :: X -> Text -> [Text]-splitText' w xs-  | w >= T.length xs = [xs]  -- no problem, everything fits-  | otherwise =-      let (pre, post) = T.splitAt w xs-          (ppre, ppost) = T.break (== ' ') $ T.reverse pre-          testPost = T.stripEnd ppost-      in if T.null testPost-         then pre : splitText w post-         else T.reverse ppost : splitText w (T.reverse ppre <> post)---- | The history of reports. This is a ring buffer of the given length-newtype History = History (RB.RingBuffer (Time, Report))-  deriving (Show, Binary)---- | Empty history of reports of the given maximal length.-emptyHistory :: Int -> History-emptyHistory size = History $ RB.empty size (timeZero, Report [])---- | Add a report to history, handling repetitions.-addReport :: History -> Time -> Report -> History-addReport h _ (Report []) = h-addReport !(History rb) !time !rep@(Report m) =-  case RB.uncons rb of-    Nothing -> History $ RB.cons (time, rep) rb-    Just ((oldTime, Report h), hRest) ->-      case (reverse m, h) of-        ((s1, n1) : rs, (s2, n2) : hhs) | s1 == s2 ->-          let hist = RB.cons (oldTime, Report ((s2, n1 + n2) : hhs)) hRest-          in History $ if null rs-                       then hist-                       else RB.cons (time, Report (reverse rs)) hist-        _ -> History $ RB.cons (time, rep) rb--lengthHistory :: History -> Int-lengthHistory (History rs) = RB.rbLength rs---- | Render history as many lines of text, wrapping if necessary.-renderHistory :: History -> Overlay-renderHistory (History rb) =-  let l = RB.toList rb-      (x, y) = normalLevelBound-      screenLength = y + 2-      reportLines = concatMap (splitReportForHistory (x + 1)) l-      padding = screenLength - length reportLines `mod` screenLength-  in toOverlay $ replicate padding "" ++ reportLines--splitReportForHistory :: X -> (Time, Report) -> [Text]-splitReportForHistory w (time, r) =-  -- TODO: display time fractions with granularity enough to differ-  -- from previous and next report, if possible-  let turns = time `timeFitUp` timeTurn-      ts = splitText (w - 1) $ tshow turns <> ":" <+> renderReport r-  in case ts of-    [] -> []-    hd : tl -> hd : map (T.cons ' ') tl--lastReportOfHistory :: History -> Maybe Report-lastReportOfHistory (History rb) = snd . fst <$> RB.uncons rb--type ScreenLine = U.Vector Int32--toScreenLine :: Text -> ScreenLine-toScreenLine t = let f = AttrChar defAttr-                 in encodeLine $ map f $ T.unpack t--encodeLine :: [AttrChar] -> ScreenLine-encodeLine l = G.fromList $ map (fromIntegral . fromEnum) l--encodeOverlay :: [[AttrChar]] -> Overlay-encodeOverlay = Overlay . map encodeLine---- | A series of screen lines that may or may not fit the width nor height--- of the screen. An overlay may be transformed by adding the first line--- and/or by splitting into a slideshow of smaller overlays.-newtype Overlay = Overlay {overlay :: [ScreenLine]}-  deriving (Show, Eq, Binary)--emptyOverlay :: Overlay-emptyOverlay = Overlay []--truncateToOverlay :: Text -> Overlay-truncateToOverlay msg = toOverlay [msg]--toOverlay :: [Text] -> Overlay-toOverlay = let lxsize = fst normalLevelBound + 1  -- TODO-            in Overlay . map (toScreenLine . truncateMsg lxsize)---- | Split an overlay into a slideshow in which each overlay,--- prefixed by @msg@ and postfixed by @moreMsg@ except for the last one,--- fits on the screen wrt height (but lines may be too wide).-splitOverlay :: Maybe Bool -> Y -> Overlay -> Overlay -> Slideshow-splitOverlay onBlank yspace (Overlay msg) (Overlay ls) =-  let len = length msg-      endB = [ toScreenLine-               $ endMsg <> "[press PGUP to see previous, ESC to cancel]"-             | onBlank == Just False ]-  in if len >= yspace-     then  -- no space left for @ls@-       Slideshow (onBlank, [Overlay $ take (yspace - 1) msg-                                      ++ [toScreenLine moreMsg]])-     else let splitO over =-                let (pre, post) = splitAt (yspace - 1) $ msg ++ over-                in if null (drop 1 post)  -- (don't call @length@ on @ls@)-                   then [Overlay $ msg ++ over ++ endB]  -- all fits on screen-                   else let rest = splitO post-                        in Overlay (pre ++ [toScreenLine moreMsg]) : rest-          in Slideshow (onBlank, splitO ls)---- | A few overlays, displayed one by one upon keypress.--- When displayed, they are trimmed, not wrapped--- and any lines below the lower screen edge are not visible.--- If the first pair element is not @Nothing@, the overlay is displayed--- over a blank screen, including the bottom lines. The boolean flag--- then indicates whether to start at the topmost screenful or bottommost.-newtype Slideshow = Slideshow {slideshow :: (Maybe Bool, [Overlay])}-  deriving (Show, Eq)--instance Monoid Slideshow where-  mempty = Slideshow (Nothing, [])-  mappend (Slideshow (b1, l1)) (Slideshow (_, l2)) = Slideshow (b1, l1 ++ l2)---- | Declare the list of raw overlays to be fit for display on the screen.--- In particular, current @Report@ is eiter empty or unimportant--- or contained in the overlays and if any vertical or horizontal--- trimming of the overlays happens, this is intended.-toSlideshow :: Maybe Bool -> [[Text]] -> Slideshow-toSlideshow onBlank l = Slideshow (onBlank, map toOverlay l)

Game/LambdaHack/Common/Perception.hs view

@@ -17,12 +17,20 @@ -- the tile, so the player can flee or block. Invisible actors in open -- space can be hit. module Game.LambdaHack.Common.Perception-  ( Perception(Perception), PerceptionVisible(PerceptionVisible)-  , totalVisible, smellVisible-  , nullPer, addPer, diffPer-  , FactionPers, Pers+  ( -- * Public perception+    PerVisible(..)+  , PerSmelled(..)+  , Perception(..)+  , PerLid+  , PerFid+  , totalVisible, totalSmelled+  , emptyPer, nullPer, addPer, diffPer   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES@@ -32,53 +40,62 @@ import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Point -newtype PerceptionVisible = PerceptionVisible-    {pvisible :: ES.EnumSet Point}+-- * Public perception++-- | Visible positions.+newtype PerVisible = PerVisible {pvisible :: ES.EnumSet Point}   deriving (Show, Eq, Binary) --- TOOD: if really needed, optimize by representing as a set of intervals--- or a set of bitmaps, like the internal representation of IntSet.+-- | Smelled positions.+newtype PerSmelled = PerSmelled {psmelled :: ES.EnumSet Point}+  deriving (Show, Eq, Binary)+ -- | The type representing the perception of a faction on a level. data Perception = Perception-  { ptotal :: !PerceptionVisible  -- ^ sum over all actors-  , psmell :: !PerceptionVisible  -- ^ sum over actors that can smell+  { psight :: !PerVisible+  , psmell :: !PerSmelled   }   deriving (Show, Eq, Generic)  instance Binary Perception  -- | Perception of a single faction, indexed by level identifier.-type FactionPers = EM.EnumMap LevelId Perception+type PerLid = EM.EnumMap LevelId Perception  -- | Perception indexed by faction identifier.--- This can't be added to @FactionDict@, because clients can't see it.-type Pers = EM.EnumMap FactionId FactionPers+-- This can't be added to @FactionDict@, because clients can't see it+-- for other factions.+type PerFid = EM.EnumMap FactionId PerLid  -- | The set of tiles visible by at least one hero. totalVisible :: Perception -> ES.EnumSet Point-totalVisible = pvisible . ptotal+totalVisible = pvisible . psight --- | The set of tiles smelled by at least one hero.-smellVisible :: Perception -> ES.EnumSet Point-smellVisible = pvisible . psmell+-- | The set of tiles smelt by at least one hero.+totalSmelled :: Perception -> ES.EnumSet Point+totalSmelled = psmelled . psmell +emptyPer :: Perception+emptyPer = Perception { psight = PerVisible ES.empty+                      , psmell = PerSmelled ES.empty }+ nullPer :: Perception -> Bool-nullPer per = ES.null (totalVisible per) && ES.null (smellVisible per)+nullPer per = per == emptyPer  addPer :: Perception -> Perception -> Perception addPer per1 per2 =   Perception-    { ptotal = PerceptionVisible+    { psight = PerVisible                $ totalVisible per1 `ES.union` totalVisible per2-    , psmell = PerceptionVisible-               $ smellVisible per1 `ES.union` smellVisible per2+    , psmell = PerSmelled+               $ totalSmelled per1 `ES.union` totalSmelled per2     }  diffPer :: Perception -> Perception -> Perception diffPer per1 per2 =   Perception-    { ptotal = PerceptionVisible+    { psight = PerVisible                $ totalVisible per1 ES.\\ totalVisible per2-    , psmell = PerceptionVisible-               $ smellVisible per1 ES.\\ smellVisible per2+    , psmell = PerSmelled+               $ totalSmelled per1 ES.\\ totalSmelled per2     }

Game/LambdaHack/Common/Point.hs view

@@ -3,10 +3,14 @@ module Game.LambdaHack.Common.Point   ( X, Y, Point(..), maxLevelDimExponent   , chessDist, euclidDistSq, adjacent, inside, bla, fromTo+  , originPoint   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Control.DeepSeq-import Control.Exception.Assert.Sugar import Data.Binary import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.)) import Data.Int (Int32)@@ -25,7 +29,7 @@   { px :: !X   , py :: !Y   }-  deriving (Read, Eq, Ord, Generic)+  deriving (Eq, Ord, Generic)  instance Show Point where   show (Point x y) = show (x, y)@@ -40,9 +44,20 @@ -- because it is not contiguous --- we don't know the horizontal -- width of the levels nor of the screen. -- The conversion is implemented mainly for @EnumMap@ and @EnumSet@.+-- Note that the conversion is not monotonic wrt the natural @Ord@ instance,+-- because we want adjacent points in line to have adjacent enumerations,+-- because some of the screen layout and most of processing is line-by-line.+-- Consequently, one can use EM.fromAscList on @(1, 8)..(10, 8)@, but not on+-- @(1, 7)..(10, 9)@. instance Enum Point where-  fromEnum = fromEnumPoint-  toEnum = toEnumPoint+  fromEnum (Point x y) =+#ifdef WITH_EXPENSIVE_ASSERTIONS+    assert (x >= 0 && y >= 0 && x <= maxLevelDim && y <= maxLevelDim+            `blame` "invalid point coordinates"+            `twith` (x, y))+#endif+    (x + unsafeShiftL y maxLevelDimExponent)+  toEnum n = Point (n .&. maxLevelDim) (unsafeShiftR n maxLevelDimExponent)  -- | The maximum number of bits for level X and Y dimension (16). -- The value is chosen to support architectures with 32-bit Ints.@@ -56,30 +71,14 @@ {-# INLINE maxLevelDim #-} maxLevelDim = 2 ^ maxLevelDimExponent - 1 -fromEnumPoint :: Point -> Int-{-# INLINE fromEnumPoint #-}-fromEnumPoint (Point x y) =-  assert (x >= 0 && y >= 0 && x <= maxLevelDim && y <= maxLevelDim-          `blame` "invalid point coordinates"-          `twith` (x, y))-  $ x + unsafeShiftL y maxLevelDimExponent--toEnumPoint :: Int -> Point-{-# INLINE toEnumPoint #-}-toEnumPoint n =-  Point (n .&. maxLevelDim) (unsafeShiftR n maxLevelDimExponent)- -- | The distance between two points in the chessboard metric. chessDist :: Point -> Point -> Int-{-# INLINE chessDist #-} chessDist (Point x0 y0) (Point x1 y1) = max (abs (x1 - x0)) (abs (y1 - y0))  -- | Squared euclidean distance between two points. euclidDistSq :: Point -> Point -> Int-{-# INLINE euclidDistSq #-} euclidDistSq (Point x0 y0) (Point x1 y1) =-  let square n = n ^ (2 :: Int)-  in square (x1 - x0) + square (y1 - y0)+  (x1 - x0) ^ (2 :: Int) + (y1 - y0) ^ (2 :: Int)  -- | Checks whether two points are adjacent on the map -- (horizontally, vertically or diagonally).@@ -89,7 +88,6 @@  -- | Checks that a point belongs to an area. inside :: Point -> (X, Y, X, Y) -> Bool-{-# INLINE inside #-} inside (Point x y) (x0, y0, x1, y1) = x1 >= x && x >= x0 && y1 >= y && y >= y0  -- | Bresenham's line algorithm generalized to arbitrary starting @eps@@@ -140,3 +138,6 @@        | otherwise = assert `failure` "diagonal fromTo"                             `twith` ((x0, y0), (x1, y1))  in result++originPoint :: Point+originPoint = Point 0 0

Game/LambdaHack/Common/PointArray.hs view

@@ -1,15 +1,19 @@-{-# LANGUAGE CPP #-} -- | Arrays, based on Data.Vector.Unboxed, indexed by @Point@. module Game.LambdaHack.Common.PointArray-  ( Array-  , (!), (//), replicateA, replicateMA, generateA, generateMA, sizeA-  , foldlA, ifoldlA, mapA, imapA, mapWithKeyMA-  , safeSetA, unsafeSetA, unsafeUpdateA+  ( GArray(..), Array, pindex, punindex+  , (!), accessI, (//)+  , replicateA, replicateMA, generateA, generateMA, unfoldrNA, sizeA+  , foldrA, foldrA', foldlA', ifoldrA, ifoldrA', ifoldlA', foldMA', ifoldMA'+  , mapA, imapA, imapMA_+  , safeSetA, unsafeSetA, unsafeUpdateA, unsafeWriteA, unsafeWriteManyA   , minIndexA, minLastIndexA, minIndexesA, maxIndexA, maxLastIndexA, forceA+  , fromListA, toListA   ) where -import Control.Arrow ((***))-import Control.Monad+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Control.Monad.ST.Strict import Data.Binary import Data.Vector.Binary ()@@ -24,26 +28,26 @@  import Game.LambdaHack.Common.Point --- TODO: for now, until there's support for GeneralizedNewtypeDeriving--- for Unboxed, there's a lot of @Word8@ in place of @c@ here--- and a contraint @Enum c@ instead of @Unbox c@.---- TODO: perhaps make them an instance of Data.Vector.Generic? -- | Arrays indexed by @Point@.-data Array c = Array+data GArray w c = Array   { axsize  :: !X   , aysize  :: !Y-  , avector :: !(U.Vector Word8)+  , avector :: !(U.Vector w)   }   deriving Eq -instance Show (Array c) where+instance Show (GArray w c) where   show a = "PointArray.Array with size " ++ show (sizeA a) +-- | Arrays of, effectively, @Word8@, indexed by @Point@.+type Array c = GArray Word8 c+ cnv :: (Enum a, Enum b) => a -> b {-# INLINE cnv #-} cnv = toEnum . fromEnum +-- Note that @Ord@ on @Int@ is not monotonic wrt @Ord@ on @Point@.+-- We need to keep it that way, because we want close xs to have close indexes. pindex :: X -> Point -> Int {-# INLINE pindex #-} pindex xsize (Point x y) = x + y * xsize@@ -57,84 +61,155 @@ -- since the extra few additions in @fromPoint@ may be less expensive than -- memory or register allocations needed for the extra @Int@ in @Point@. -- | Array lookup.-(!) :: Enum c => Array c -> Point -> c+(!) :: (U.Unbox w, Enum w, Enum c) => GArray w c -> Point -> c {-# INLINE (!) #-} (!) Array{..} p = cnv $ avector U.! pindex axsize p +accessI :: U.Unbox w => GArray w c -> Int -> w+{-# INLINE accessI #-}+accessI Array{..} p = avector `U.unsafeIndex` p+ -- | Construct an array updated with the association list.-(//) :: Enum c => Array c -> [(Point, c)] -> Array c+(//) :: (U.Unbox w, Enum w, Enum c) => GArray w c -> [(Point, c)] -> GArray w c {-# INLINE (//) #-} (//) Array{..} l = let v = avector U.// map (pindex axsize *** cnv) l                    in Array{avector = v, ..} -unsafeUpdateA :: Enum c => Array c -> [(Point, c)] -> Array c+unsafeUpdateA :: (U.Unbox w, Enum w, Enum c) => GArray w c -> [(Point, c)] -> () {-# INLINE unsafeUpdateA #-} unsafeUpdateA Array{..} l = runST $ do   vThawed <- U.unsafeThaw avector   mapM_ (\(p, c) -> VM.write vThawed (pindex axsize p) (cnv c)) l-  vFrozen <- U.unsafeFreeze vThawed-  return $! Array{avector = vFrozen, ..}+  void $ U.unsafeFreeze vThawed +unsafeWriteA :: (U.Unbox w, Enum w, Enum c) => GArray w c -> Point -> c -> ()+{-# INLINE unsafeWriteA #-}+unsafeWriteA Array{..} p c = runST $ do+  vThawed <- U.unsafeThaw avector+  VM.write vThawed (pindex axsize p) (cnv c)+  void $ U.unsafeFreeze vThawed++unsafeWriteManyA :: (U.Unbox w, Enum w, Enum c) => GArray w c -> [Point] -> c -> ()+{-# INLINE unsafeWriteManyA #-}+unsafeWriteManyA Array{..} l c = runST $ do+  vThawed <- U.unsafeThaw avector+  let d = cnv c+  mapM_ (\p -> VM.write vThawed (pindex axsize p) d) l+  void $ U.unsafeFreeze vThawed+ -- | Create an array from a replicated element.-replicateA :: Enum c => X -> Y -> c -> Array c+replicateA :: (U.Unbox w, Enum w, Enum c) => X -> Y -> c -> GArray w c {-# INLINE replicateA #-} replicateA axsize aysize c =   Array{avector = U.replicate (axsize * aysize) $ cnv c, ..}  -- | Create an array from a replicated monadic action.-replicateMA :: Enum c => Monad m => X -> Y -> m c -> m (Array c)+replicateMA :: (U.Unbox w, Enum w, Enum c, Monad m) => X -> Y -> m c -> m (GArray w c) {-# INLINE replicateMA #-} replicateMA axsize aysize m = do   v <- U.replicateM (axsize * aysize) $ liftM cnv m   return $! Array{avector = v, ..}  -- | Create an array from a function.-generateA :: Enum c => X -> Y -> (Point -> c) -> Array c+generateA :: (U.Unbox w, Enum w, Enum c) => X -> Y -> (Point -> c) -> GArray w c {-# INLINE generateA #-} generateA axsize aysize f =   let g n = cnv $ f $ punindex axsize n   in Array{avector = U.generate (axsize * aysize) g, ..}  -- | Create an array from a monadic function.-generateMA :: Enum c => Monad m => X -> Y -> (Point -> m c) -> m (Array c)+generateMA :: (U.Unbox w, Enum w, Enum c, Monad m) => X -> Y -> (Point -> m c) -> m (GArray w c) {-# INLINE generateMA #-} generateMA axsize aysize fm = do   let gm n = liftM cnv $ fm $ punindex axsize n   v <- U.generateM (axsize * aysize) gm   return $! Array{avector = v, ..} +unfoldrNA :: (U.Unbox w, Enum w, Enum c) => X -> Y -> (b -> (c, b)) -> b -> GArray w c+{-# INLINE unfoldrNA #-}+unfoldrNA axsize aysize fm b =+  let gm = Just . first cnv . fm+      v = U.unfoldrN (axsize * aysize) gm b+  in Array {avector = v, ..}+ -- | Content identifiers array size.-sizeA :: Array c -> (X, Y)+sizeA :: GArray w c -> (X, Y) {-# INLINE sizeA #-} sizeA Array{..} = (axsize, aysize) +-- | Fold right over an array.+foldrA :: (U.Unbox w, Enum w, Enum c) => (c -> a -> a) -> a -> GArray w c -> a+{-# INLINE foldrA #-}+foldrA f z0 Array{..} =+  U.foldr (\c a-> f (cnv c) a) z0 avector++-- | Fold right strictly over an array.+foldrA' :: (U.Unbox w, Enum w, Enum c) => (c -> a -> a) -> a -> GArray w c -> a+{-# INLINE foldrA' #-}+foldrA' f z0 Array{..} =+  U.foldr' (\c a-> f (cnv c) a) z0 avector+ -- | Fold left strictly over an array.-foldlA :: Enum c => (a -> c -> a) -> a -> Array c -> a-{-# INLINE foldlA #-}-foldlA f z0 Array{..} =+foldlA' :: (U.Unbox w, Enum w, Enum c) => (a -> c -> a) -> a -> GArray w c -> a+{-# INLINE foldlA' #-}+foldlA' f z0 Array{..} =   U.foldl' (\a c -> f a (cnv c)) z0 avector  -- | Fold left strictly over an array -- (function applied to each element and its index).-ifoldlA :: Enum c => (a -> Point -> c -> a) -> a -> Array c -> a-{-# INLINE ifoldlA #-}-ifoldlA f z0 Array{..} =+ifoldlA' :: (U.Unbox w, Enum w, Enum c)+         => (a -> Point -> c -> a) -> a -> GArray w c -> a+{-# INLINE ifoldlA' #-}+ifoldlA' f z0 Array{..} =   U.ifoldl' (\a n c -> f a (punindex axsize n) (cnv c)) z0 avector +-- | Fold right over an array+-- (function applied to each element and its index).+ifoldrA :: (U.Unbox w, Enum w, Enum c)+        => (Point -> c -> a -> a) -> a -> GArray w c -> a+{-# INLINE ifoldrA #-}+ifoldrA f z0 Array{..} =+  U.ifoldr (\n c a -> f (punindex axsize n) (cnv c) a) z0 avector++-- | Fold right strictly over an array+-- (function applied to each element and its index).+ifoldrA' :: (U.Unbox w, Enum w, Enum c)+         => (Point -> c -> a -> a) -> a -> GArray w c -> a+{-# INLINE ifoldrA' #-}+ifoldrA' f z0 Array{..} =+  U.ifoldr' (\n c a -> f (punindex axsize n) (cnv c) a) z0 avector++-- | Fold monadically strictly over an array.+foldMA' :: (Monad m, U.Unbox w, Enum w, Enum c)+        => (a -> c -> m a) -> a -> GArray w c -> m a+{-# INLINE foldMA' #-}+foldMA' f z0 Array{..} =+  U.foldM' (\a c -> f a (cnv c)) z0 avector++-- | Fold monadically strictly over an array+-- (function applied to each element and its index).+ifoldMA' :: (Monad m, U.Unbox w, Enum w, Enum c)+         => (a -> Point -> c -> m a) -> a -> GArray w c -> m a+{-# INLINE ifoldMA' #-}+ifoldMA' f z0 Array{..} =+  U.ifoldM' (\a n c -> f a (punindex axsize n) (cnv c)) z0 avector+ -- | Map over an array.-mapA :: (Enum c, Enum d) => (c -> d) -> Array c -> Array d+mapA :: (U.Unbox w1, Enum w1, U.Unbox w2, Enum w2, Enum c, Enum d)+     => (c -> d) -> GArray w1 c -> GArray w2 d {-# INLINE mapA #-} mapA f Array{..} = Array{avector = U.map (cnv . f . cnv) avector, ..}  -- | Map over an array (function applied to each element and its index).-imapA :: (Enum c, Enum d) => (Point -> c -> d) -> Array c -> Array d+imapA :: (U.Unbox w1, Enum w1, U.Unbox w2, Enum w2, Enum c, Enum d)+      => (Point -> c -> d) -> GArray w1 c -> GArray w2 d {-# INLINE imapA #-} imapA f Array{..} =   let v = U.imap (\n c -> cnv $ f (punindex axsize n) (cnv c)) avector   in Array{avector = v, ..}  -- | Set all elements to the given value, in place.-unsafeSetA :: Enum c => c -> Array c -> Array c+unsafeSetA :: (U.Unbox w, Enum w, Enum c) => c -> GArray w c -> GArray w c {-# INLINE unsafeSetA #-} unsafeSetA c Array{..} = runST $ do   vThawed <- U.unsafeThaw avector@@ -143,30 +218,28 @@   return $! Array{avector = vFrozen, ..}  -- | Set all elements to the given value, in place, if possible.-safeSetA :: Enum c => c -> Array c -> Array c+safeSetA :: (U.Unbox w, Enum w, Enum c) => c -> GArray w c -> GArray w c {-# INLINE safeSetA #-} safeSetA c Array{..} =   Array{avector = U.modify (\v -> VM.set v (cnv c)) avector, ..}  -- | Map monadically over an array (function applied to each element -- and its index) and ignore the results.-mapWithKeyMA :: Enum c => Monad m-              => (Point -> c -> m ()) -> Array c -> m ()-{-# INLINE mapWithKeyMA #-}-mapWithKeyMA f Array{..} =-  U.ifoldl' (\a n c -> a >> f (punindex axsize n) (cnv c))-            (return ())-            avector+imapMA_ :: (U.Unbox w, Enum w, Enum c, Monad m)+             => (Point -> c -> m ()) -> GArray w c -> m ()+{-# INLINE imapMA_ #-}+imapMA_ f Array{..} =+  U.imapM_ (\n c -> f (punindex axsize n) (cnv c)) avector  -- | Yield the point coordinates of a minimum element of the array. -- The array may not be empty.-minIndexA :: Enum c => Array c -> Point+minIndexA :: (U.Unbox w, Ord w) => GArray w c -> Point {-# INLINE minIndexA #-} minIndexA Array{..} = punindex axsize $ U.minIndex avector  -- | Yield the point coordinates of the last minimum element of the array. -- The array may not be empty.-minLastIndexA :: Enum c => Array c -> Point+minLastIndexA :: (U.Unbox w, Ord w) => GArray w c -> Point {-# INLINE minLastIndexA #-} minLastIndexA Array{..} =   punindex axsize@@ -177,25 +250,25 @@  -- | Yield the point coordinates of all the minimum elements of the array. -- The array may not be empty.-minIndexesA :: Enum c => Array c -> [Point]+minIndexesA :: (U.Unbox w, Enum w, Ord w) => GArray w c -> [Point] {-# INLINE minIndexesA #-} minIndexesA Array{..} =   map (punindex axsize)-  $ Bundle.foldl' imin [] . Bundle.indexed . G.stream+  $ Bundle.foldr imin [] . Bundle.indexed . G.stream   $ avector  where-  imin acc (i, x) = i `seq` if x == minE then i : acc else acc+  imin (i, x) acc = i `seq` if x == minE then i : acc else acc   minE = cnv $ U.minimum avector  -- | Yield the point coordinates of the first maximum element of the array. -- The array may not be empty.-maxIndexA :: Enum c => Array c -> Point+maxIndexA :: (U.Unbox w, Ord w) => GArray w c -> Point {-# INLINE maxIndexA #-} maxIndexA Array{..} = punindex axsize $ U.maxIndex avector  -- | Yield the point coordinates of the last maximum element of the array. -- The array may not be empty.-maxLastIndexA :: Enum c => Array c -> Point+maxLastIndexA :: (U.Unbox w, Ord w) => GArray w c -> Point {-# INLINE maxLastIndexA #-} maxLastIndexA Array{..} =   punindex axsize@@ -205,11 +278,20 @@   imax (i, x) (j, y) = i `seq` j `seq` if x <= y then (j, y) else (i, x)  -- | Force the array not to retain any extra memory.-forceA :: Enum c => Array c -> Array c+forceA :: U.Unbox w => GArray w c -> GArray w c {-# INLINE forceA #-} forceA Array{..} = Array{avector = U.force avector, ..} -instance Binary (Array c) where+fromListA :: (U.Unbox w, Enum w, Enum c) => X -> Y -> [c] -> GArray w c+{-# INLINE fromListA #-}+fromListA axsize aysize l =+  Array{avector = U.fromListN (axsize * aysize) $ map cnv l, ..}++toListA :: (U.Unbox w, Enum w, Enum c) => GArray w c -> [c]+{-# INLINE toListA #-}+toListA Array{..} = map cnv $ U.toList avector++instance (U.Unbox w, Binary w) => Binary (GArray w c) where   put Array{..} = do     put axsize     put aysize

+ Game/LambdaHack/Common/Prelude.hs view

@@ -0,0 +1,52 @@+-- | Client monad for interacting with a human through UI.+module Game.LambdaHack.Common.Prelude+  ( module Prelude.Compat++  , module Control.Monad.Compat+  , module Data.List.Compat+  , module Data.Maybe+  , module Data.Monoid.Compat++  , module Control.Exception.Assert.Sugar++  , Text, (<+>), tshow, divUp, (<$$>), partitionM++  , (***), (&&&), first, second+  ) where++import Prelude ()++import Prelude.Compat hiding (appendFile, readFile, writeFile)++import Control.Applicative+import Control.Arrow (first, second, (&&&), (***))+import Control.Monad.Compat+import Data.List.Compat+import Data.Maybe+import Data.Monoid.Compat++import Control.Exception.Assert.Sugar++import Data.Text (Text)++import qualified Data.Text as T (pack)+import NLP.Miniutter.English ((<+>))++-- | Show and pack the result.+tshow :: Show a => a -> Text+tshow x = T.pack $ show x++infixl 7 `divUp`+-- | Integer division, rounding up.+divUp :: Integral a => a -> a -> a+{-# INLINE divUp #-}+divUp n k = (n + k - 1) `div` k++infixl 4 <$$>+(<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)+h <$$> m = fmap h <$> m++partitionM :: Applicative m => (a -> m Bool) -> [a] -> m ([a], [a])+{-# INLINE partitionM #-}+partitionM p = foldr (\a ->+  liftA2 (\b -> (if b then first else second) (a :)) (p a)) (pure ([], []))

Game/LambdaHack/Common/Random.hs view

@@ -8,10 +8,15 @@   , Chance, chance     -- * Casting dice scaled with level   , castDice, chanceDice, castDiceXY+    -- * Specialized monadic folds+  , foldrM, foldlM'   ) where -import Control.Exception.Assert.Sugar-import qualified Control.Monad.State as St+import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Control.Monad.Trans.State.Strict as St import Data.Ratio import qualified System.Random as R @@ -25,10 +30,12 @@  -- | Get a random object within a range with a uniform distribution. randomR :: (R.Random a) => (a, a) -> Rnd a-randomR range = St.state $ R.randomR range+{-# INLINE randomR #-}+randomR = St.state . R.randomR  -- | Get a random object of a given type with a uniform distribution. random :: (R.Random a) => Rnd a+{-# INLINE random #-} random = St.state R.random  -- | Get any element of a list with equal probability.@@ -36,11 +43,12 @@ oneOf [] = assert `failure` "oneOf []" `twith` () oneOf xs = do   r <- randomR (0, length xs - 1)-  return (xs !! r)+  return $! xs !! r  -- | Gen an element according to a frequency distribution. frequency :: Show a => Frequency a -> Rnd a-frequency fr = St.state $ rollFreq fr+{-# INLINE frequency #-}+frequency = St.state . rollFreq  -- | Randomly choose an item according to the distribution. rollFreq :: Show a => Frequency a -> R.StdGen -> (a, R.StdGen)@@ -48,14 +56,14 @@   [] -> assert `failure` "choice from an empty frequency"                `twith` nameFrequency fr   [(n, x)] | n <= 0 -> assert `failure` "singleton void frequency"-                                 `twith` (nameFrequency fr, n, x)+                              `twith` (nameFrequency fr, n, x)   [(_, x)] -> (x, g)  -- speedup-  fs -> let sumf = sum (map fst fs)+  fs -> let sumf = foldl' (\ !acc (!n, _) -> acc + n) 0 fs             (r, ng) = R.randomR (1, sumf) g             frec :: Int -> [(Int, a)] -> a-            frec m [] = assert `failure` "impossible roll"-                               `twith` (nameFrequency fr, fs, m)-            frec m ((n, x) : _)  | m <= n = x+            frec !m [] = assert `failure` "impossible roll"+                                `twith` (nameFrequency fr, fs, m)+            frec m ((n, x) : _) | m <= n = x             frec m ((n, _) : xs) = frec (m - n) xs         in assert (sumf > 0 `blame` "frequency with nothing to pick"                             `twith` (nameFrequency fr, fs))@@ -97,3 +105,11 @@   x <- castDice ldepth totalDepth dx   y <- castDice ldepth totalDepth dy   return (x, y)++foldrM :: Foldable t => (a -> b -> Rnd b) -> b -> t a -> Rnd b+foldrM f z0 xs = let f' x (z, g) = St.runState (f x z) g+                 in St.state $ \g -> foldr f' (z0, g) xs++foldlM' :: Foldable t => (b -> a -> Rnd b) -> b -> t a -> Rnd b+foldlM' f z0 xs = let f' (z, g) x = St.runState (f z x) g+                  in St.state $ \g -> foldl' f' (z0, g) xs

Game/LambdaHack/Common/Request.hs view

@@ -1,75 +1,73 @@-{-# LANGUAGE DataKinds, ExistentialQuantification, GADTs, KindSignatures,-             StandaloneDeriving #-}+{-# LANGUAGE DataKinds, DeriveGeneric, GADTs, KindSignatures, StandaloneDeriving+             #-} -- | Abstract syntax of server commands. -- See -- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>. module Game.LambdaHack.Common.Request-  ( RequestAI(..), RequestUI(..), RequestTimed(..), RequestAnyAbility(..)-  , ReqFailure(..), impossibleReqFailure, showReqFailure, anyToUI-  , permittedPrecious, permittedProject, permittedApply+  ( RequestAI, ReqAI(..), RequestUI, ReqUI(..)+  , RequestTimed(..), RequestAnyAbility(..), ReqFailure(..)+  , impossibleReqFailure, showReqFailure, timedToUI+  , permittedPrecious, permittedProject, permittedProjectAI, permittedApply   ) where -import Data.Maybe-import Data.Text (Text)+import Prelude () -import Game.LambdaHack.Atomic+import Game.LambdaHack.Common.Prelude++import Data.Binary+import GHC.Generics (Generic)+ import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.ItemStrongest import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind-import qualified Game.LambdaHack.Content.TileKind as TK --- TODO: make remove second arg from ReqLeader; this requires a separate--- channel for Ping, probably, and then client sends as many commands--- as it wants at once--- | Cclient-server requests sent by AI clients.-data RequestAI =-    forall a. ReqAITimed !(RequestTimed a)-  | ReqAILeader !ActorId !(Maybe Target) !RequestAI-  | ReqAIPong+-- | Client-server requests sent by AI clients.+data ReqAI =+    ReqAITimed RequestAnyAbility+  | ReqAINop+  deriving Show -deriving instance Show RequestAI+type RequestAI = (ReqAI, Maybe ActorId)  -- | Client-server requests sent by UI clients.-data RequestUI =-    forall a. ReqUITimed !(RequestTimed a)-  | ReqUILeader !ActorId !(Maybe Target) !RequestUI-  | ReqUIGameRestart !ActorId !(GroupName ModeKind) !Int ![(Int, (Text, Text))]-  | ReqUIGameExit !ActorId+data ReqUI =+    ReqUINop+  | ReqUITimed RequestAnyAbility+  | ReqUIGameRestart !(GroupName ModeKind) !Challenge+  | ReqUIGameExit   | ReqUIGameSave   | ReqUITactic !Tactic   | ReqUIAutomate-  | ReqUIPong [CmdAtomic]+  deriving Show -deriving instance Show RequestUI+type RequestUI = (ReqUI, Maybe ActorId)  data RequestAnyAbility = forall a. RequestAnyAbility !(RequestTimed a)  deriving instance Show RequestAnyAbility -anyToUI :: RequestAnyAbility -> RequestUI-anyToUI (RequestAnyAbility cmd) = ReqUITimed cmd+timedToUI :: RequestTimed a -> ReqUI+timedToUI = ReqUITimed . RequestAnyAbility  -- | Client-server requests that take game time. Sent by both AI and UI clients. data RequestTimed :: Ability -> * where   ReqMove :: !Vector -> RequestTimed 'AbMove   ReqMelee :: !ActorId -> !ItemId -> !CStore -> RequestTimed 'AbMelee   ReqDisplace :: !ActorId -> RequestTimed 'AbDisplace-  ReqAlter :: !Point -> !(Maybe TK.Feature) -> RequestTimed 'AbAlter+  ReqAlter :: !Point -> RequestTimed 'AbAlter   ReqWait :: RequestTimed 'AbWait+  ReqWait10 :: RequestTimed 'AbWait   ReqMoveItems :: ![(ItemId, Int, CStore, CStore)] -> RequestTimed 'AbMoveItem   ReqProject :: !Point -> !Int -> !ItemId -> !CStore -> RequestTimed 'AbProject   ReqApply :: !ItemId -> !CStore -> RequestTimed 'AbApply-  ReqTrigger :: !(Maybe TK.Feature) -> RequestTimed 'AbTrigger  deriving instance Show (RequestTimed a) @@ -85,6 +83,7 @@   | DisplaceImmobile   | DisplaceSupported   | AlterUnskilled+  | AlterUnwalked   | AlterDistant   | AlterBlockActor   | AlterBlockItem@@ -95,6 +94,7 @@   | ApplyRead   | ApplyOutOfReach   | ApplyCharging+  | ApplyNoEffects   | ItemNothing   | ItemNotCalm   | NotCalmPrecious@@ -102,13 +102,14 @@   | ProjectAimOnself   | ProjectBlockTerrain   | ProjectBlockActor-  | ProjectNotRanged-  | ProjectFragile+  | ProjectLobable   | ProjectOutOfReach   | TriggerNothing   | NoChangeDunLeader-  | NoChangeLvlLeader+  deriving (Show, Eq, Generic) +instance Binary ReqFailure+ impossibleReqFailure :: ReqFailure -> Bool impossibleReqFailure reqFailure = case reqFailure of   MoveNothing -> True@@ -122,16 +123,18 @@   DisplaceImmobile -> False  -- unidentified skill items   DisplaceSupported -> True   AlterUnskilled -> False  -- unidentified skill items+  AlterUnwalked -> False   AlterDistant -> True   AlterBlockActor -> True  -- adjacent actor always visible   AlterBlockItem -> True  -- adjacent item always visible   AlterNothing -> True-  EqpOverfull -> False  -- REVERT ME on branches other than 0.5.0+  EqpOverfull -> True   EqpStackFull -> True   ApplyUnskilled -> False  -- unidentified skill items   ApplyRead -> False  -- unidentified skill items   ApplyOutOfReach -> True   ApplyCharging -> False  -- if aspects unknown, charging unknown+  ApplyNoEffects -> False  -- if effects unknown, can't prevent it   ItemNothing -> True   ItemNotCalm -> False  -- unidentified skill items   NotCalmPrecious -> False  -- unidentified skill items@@ -139,14 +142,12 @@   ProjectAimOnself -> True   ProjectBlockTerrain -> True  -- adjacent terrain always visible   ProjectBlockActor -> True  -- adjacent actor always visible-  ProjectNotRanged -> False  -- unidentified skill items-  ProjectFragile -> False  -- unidentified skill items+  ProjectLobable -> False  -- unidentified skill items   ProjectOutOfReach -> True   TriggerNothing -> True  -- terrain underneath always visibl   NoChangeDunLeader -> True-  NoChangeLvlLeader -> True -showReqFailure :: ReqFailure -> Msg+showReqFailure :: ReqFailure -> Text showReqFailure reqFailure = case reqFailure of   MoveNothing -> "wasting time on moving into obstacle"   MeleeSelf -> "trying to melee oneself"@@ -159,6 +160,7 @@   DisplaceImmobile -> "trying to displace an immobile foe"   DisplaceSupported -> "trying to displace a supported foe"   AlterUnskilled -> "unskilled actors cannot alter tiles"+  AlterUnwalked -> "unskilled actors cannot enter tiles"   AlterDistant -> "trying to alter a distant tile"   AlterBlockActor -> "blocked by an actor"   AlterBlockItem -> "jammed by an item"@@ -169,77 +171,85 @@   ApplyRead -> "activating this kind of items requires skill level 2"   ApplyOutOfReach -> "cannot apply an item out of reach"   ApplyCharging -> "cannot apply an item that is still charging"+  ApplyNoEffects -> "cannot apply an item that produces no effects"   ItemNothing -> "wasting time on void item manipulation"-  ItemNotCalm -> "you are too alarmed to sort through the shared stash"+  ItemNotCalm -> "you are too alarmed to use the shared stash"   NotCalmPrecious -> "you are too alarmed to handle such an exquisite item"   ProjectUnskilled -> "unskilled actors cannot aim"   ProjectAimOnself -> "cannot aim at oneself"   ProjectBlockTerrain -> "aiming obstructed by terrain"   ProjectBlockActor -> "aiming blocked by an actor"-  ProjectNotRanged -> "to fling a non-missile requires fling skill 2"-  ProjectFragile -> "to lob a fragile item requires fling skill 3"+  ProjectLobable -> "lobbing an item requires fling skill 3"   ProjectOutOfReach -> "cannot aim an item out of reach"   TriggerNothing -> "wasting time on triggering nothing"   NoChangeDunLeader -> "no manual level change for your team"-  NoChangeLvlLeader -> "no manual leader change for your team"  -- The item should not be applied nor thrown because it's too delicate -- to operate when not calm or becuse it's too precious to identify by use. permittedPrecious :: Bool -> Bool -> ItemFull -> Either ReqFailure Bool-permittedPrecious calm10 forced itemFull =+permittedPrecious calmE forced itemFull =   let isPrecious = IK.Precious `elem` jfeature (itemBase itemFull)-  in if not calm10 && not forced && isPrecious then Left NotCalmPrecious+  in if not calmE && not forced && isPrecious then Left NotCalmPrecious      else Right $ IK.Durable `elem` jfeature (itemBase itemFull)                   || case itemDisco itemFull of-                    Just ItemDisco{itemAE=Just _} -> True-                    _ -> not isPrecious+                       Just ItemDisco{itemAspect=Just _} -> True+                       _ -> not isPrecious -permittedProject :: [Char] -> Bool -> Int -> ItemFull -> Actor -> [ItemFull]+permittedPreciousAI :: Bool -> ItemFull -> Bool+permittedPreciousAI calmE itemFull =+  let isPrecious = IK.Precious `elem` jfeature (itemBase itemFull)+  in if not calmE && isPrecious then False+     else IK.Durable `elem` jfeature (itemBase itemFull)+          || case itemDisco itemFull of+               Just ItemDisco{itemAspect=Just _} -> True+               _ -> not isPrecious++permittedProject :: Bool -> Int -> Bool -> [Char] -> ItemFull                  -> Either ReqFailure Bool-permittedProject triggerSyms forced skill itemFull@ItemFull{itemBase}-                 b activeItems =-  let calm10 = calmEnough10 b activeItems-      mhurtRanged = strengthFromEqpSlot IK.EqpSlotAddHurtRanged itemFull-  in if not forced-        && skill < 1 then Left ProjectUnskilled-  else if not forced-          && isNothing mhurtRanged-          && skill < 2 then Left ProjectNotRanged-  else if not forced-          && IK.Fragile `elem` jfeature itemBase-          && skill < 3 then Left ProjectFragile-  else-    let legal = permittedPrecious calm10 forced itemFull-    in case legal of-      Left{} -> legal-      Right False -> legal-      Right True -> Right $-        let hasEffects = case itemDisco itemFull of-              Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects=[]}} -> False-              Just ItemDisco{ itemAE=Nothing-                            , itemKind=IK.ItemKind{IK.ieffects=[]} } -> False-              _ -> True-            permittedSlot =-              if ' ' `elem` triggerSyms-              then case strengthEqpSlot itemBase of-                Just (IK.EqpSlotAddLight, _) -> True-                Just _ -> False-                Nothing -> True-              else jsymbol itemBase `elem` triggerSyms-        in hasEffects && permittedSlot+permittedProject forced skill calmE triggerSyms itemFull@ItemFull{itemBase} =+ if | not forced && skill < 1 -> Left ProjectUnskilled+    | not forced+      && IK.Lobable `elem` jfeature itemBase+      && skill < 3 -> Left ProjectLobable+    | otherwise ->+      let legal = permittedPrecious calmE forced itemFull+      in case legal of+        Left{} -> legal+        Right False -> legal+        Right True -> Right $+          if | null triggerSyms -> True+             | ' ' `elem` triggerSyms ->+               case strengthEqpSlot itemFull of+                 Just IK.EqpSlotLightSource -> True+                 Just _ -> False+                 Nothing -> not (goesIntoEqp itemBase)+             | otherwise -> jsymbol itemBase `elem` triggerSyms -permittedApply :: [Char] -> Time -> Int -> ItemFull -> Actor -> [ItemFull]+-- Speedup.+permittedProjectAI :: Int -> Bool -> ItemFull -> Bool+permittedProjectAI skill calmE itemFull@ItemFull{itemBase} =+ if | skill < 1 -> False+    | IK.Lobable `elem` jfeature itemBase+      && skill < 3 -> False+    | otherwise -> permittedPreciousAI calmE itemFull++permittedApply :: Time -> Int -> Bool-> [Char] -> ItemFull                -> Either ReqFailure Bool-permittedApply triggerSyms localTime skill itemFull@ItemFull{itemBase}-               b activeItems =-  let calm10 = calmEnough10 b activeItems-  in if skill < 1 then Left ApplyUnskilled-  else if jsymbol itemBase == '?' && skill < 2 then Left ApplyRead-  -- We assume if the item has a timeout, all or most of interesting effects-  -- are under Recharging, so no point activating if not recharged.-  else if not $ hasCharge localTime itemFull-       then Left ApplyCharging-       else let legal = permittedPrecious calm10 False itemFull+permittedApply localTime skill calmE triggerSyms itemFull@ItemFull{..} =+  if | skill < 1 -> Left ApplyUnskilled+     | jsymbol itemBase == '?' && skill < 2 -> Left ApplyRead+     -- We assume if the item has a timeout, all or most of interesting+     -- effects are under Recharging, so no point activating if not recharged.+     -- Note that if client doesn't know the timeout, here we leak the fact+     -- that the item is still charging, but the client risks destruction+     -- if the item is, in fact, recharged and is not durable+     -- (very likely in case of jewellery), so it's OK (the message may be+     -- somewhat alarming though).+     | not $ hasCharge localTime itemFull -> Left ApplyCharging+     | otherwise -> case itemDisco of+       Just ItemDisco{itemKind} | null $ IK.ieffects itemKind ->+         Left ApplyNoEffects+       _ -> let legal = permittedPrecious calmE False itemFull             in case legal of               Left{} -> legal               Right False -> legal

Game/LambdaHack/Common/Response.hs view

@@ -2,23 +2,32 @@ -- See -- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>. module Game.LambdaHack.Common.Response-  ( ResponseAI(..), ResponseUI(..)+  ( Response(..), CliSerQueue, ChanServer(..)   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude++import Control.Concurrent+ import Game.LambdaHack.Atomic import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.Request --- | Abstract syntax of client commands that don't use the UI.-data ResponseAI =-    RespUpdAtomicAI !UpdAtomic+-- | Abstract syntax of client commands for both AI and UI clients.+data Response =+    RespUpdAtomic !UpdAtomic   | RespQueryAI !ActorId-  | RespPingAI-  deriving Show---- | Abstract syntax of client commands that use the UI.-data ResponseUI =-    RespUpdAtomicUI !UpdAtomic-  | RespSfxAtomicUI !SfxAtomic+  | RespSfxAtomic !SfxAtomic   | RespQueryUI-  | RespPingUI   deriving Show++type CliSerQueue = MVar++-- | Connection channel between the server and a single client.+data ChanServer = ChanServer+  { responseS  :: !(CliSerQueue Response)+  , requestAIS :: !(CliSerQueue RequestAI)+  , requestUIS :: !(Maybe (CliSerQueue RequestUI))+  }

Game/LambdaHack/Common/RingBuffer.hs view

@@ -1,17 +1,22 @@ {-# LANGUAGE DeriveGeneric #-} -- | Ring buffers. module Game.LambdaHack.Common.RingBuffer-  ( RingBuffer(rbLength)-  , empty, cons, uncons, toList+  ( RingBuffer+  , empty, cons, uncons, toList, length   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude hiding (length, uncons)+ import Data.Binary-import qualified Data.Vector as V-import Data.Vector.Binary ()+import qualified Data.Foldable as Foldable+import qualified Data.Sequence as Seq import GHC.Generics (Generic)  data RingBuffer a = RingBuffer-  { rbCarrier :: !(V.Vector a)+  { rbCarrier :: !(Seq.Seq a)+  , rbMaxSize :: !Int   , rbNext    :: !Int   , rbLength  :: !Int   }@@ -19,28 +24,32 @@  instance Binary a => Binary (RingBuffer a) +-- Only takes O(log n)). empty :: Int -> a -> RingBuffer a-empty size dummy = RingBuffer (V.replicate size dummy) 0 0+empty size dummy =+  let rbMaxSize = max 1 size+  in RingBuffer (Seq.replicate rbMaxSize dummy) rbMaxSize 0 0 +-- | Add element to the front of the buffer. cons :: a -> RingBuffer a -> RingBuffer a cons a RingBuffer{..} =-  let size = V.length rbCarrier-      incNext = (rbNext + 1) `mod` size-      incLength = min size $ rbLength + 1-  in RingBuffer (rbCarrier V.// [(rbNext, a)]) incNext incLength+  let incNext = (rbNext + 1) `mod` rbMaxSize+      incLength = min rbMaxSize $ rbLength + 1+  in RingBuffer (Seq.update rbNext a rbCarrier) rbMaxSize incNext incLength  uncons :: RingBuffer a -> Maybe (a, RingBuffer a) uncons RingBuffer{..} =-  let size = V.length rbCarrier-      decNext = (rbNext - 1) `mod` size+  let decNext = (rbNext - 1) `mod` rbMaxSize   in if rbLength == 0      then Nothing-     else Just ( rbCarrier V.! decNext-               , RingBuffer rbCarrier decNext (rbLength - 1) )+     else Just ( Seq.index rbCarrier decNext+               , RingBuffer rbCarrier rbMaxSize decNext (rbLength - 1) )  toList :: RingBuffer a -> [a] toList RingBuffer{..} =-  let l = V.toList rbCarrier-      size = V.length rbCarrier-      start = (rbNext + size - rbLength) `mod` size+  let l = Foldable.toList rbCarrier+      start = (rbNext + rbMaxSize - rbLength) `mod` rbMaxSize   in take rbLength $ drop start $ l ++ l++length :: RingBuffer a -> Int+length RingBuffer{rbLength} = rbLength

Game/LambdaHack/Common/Save.hs view

@@ -1,23 +1,35 @@ -- | Saving and restoring server game state. module Game.LambdaHack.Common.Save-  ( ChanSave, saveToChan, wrapInSaves, restoreGame, delayPrint+  ( ChanSave, saveToChan, wrapInSaves, restoreGame, saveNameCli, saveNameSer+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , loopSave+#endif   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude++-- Cabal+import qualified Paths_LambdaHack as Self (version)+ import Control.Concurrent import Control.Concurrent.Async import qualified Control.Exception as Ex hiding (handle)-import Control.Monad import Data.Binary import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T-import System.Directory+import Data.Version import System.FilePath-import System.IO+import System.IO (hFlush, stdout) import qualified System.Random as R  import Game.LambdaHack.Common.File-import Game.LambdaHack.Common.Msg+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Misc (FactionId, appDataDir)+import Game.LambdaHack.Content.RuleKind  type ChanSave a = MVar (Maybe a) @@ -27,17 +39,9 @@   void $ tryTakeMVar toSave   putMVar toSave $ Just s --- TODO: to have crash saves, send state to server save channel each turn--- and have another mvar, asking for a save with the last state;--- this mvar is permanently true on clients, but only set on server--- in finally and each time bkp save is requested; finally should also--- send save request to all clients (using the last state from the save--- channel for client connection data, etc.)--- All this is not needed if we bkp save each turn, but that's costly.- -- | Repeatedly save a simple serialized version of the current state.-loopSave :: Binary a => (a -> FilePath) -> ChanSave a -> IO ()-loopSave saveFile toSave =+loopSave :: Binary a => Kind.COps -> (a -> FilePath) -> ChanSave a -> IO ()+loopSave cops stateToFileName toSave =   loop  where   loop = do@@ -47,19 +51,22 @@       Just s -> do         dataDir <- appDataDir         tryCreateDir (dataDir </> "saves")-        encodeEOF (dataDir </> "saves" </> saveFile s) s+        let fileName = stateToFileName s+        encodeEOF (dataDir </> "saves" </> fileName) (vExevLib cops, s)         -- Wait until the save finished. During that time, the mvar         -- is continually updated to newest state values.         loop       Nothing -> return ()  -- exit -wrapInSaves :: Binary a => (a -> FilePath) -> (ChanSave a -> IO ()) -> IO ()-wrapInSaves saveFile exe = do+wrapInSaves :: Binary a+            => Kind.COps -> (a -> FilePath) -> (ChanSave a -> IO ()) -> IO ()+{-# INLINE wrapInSaves #-}+wrapInSaves cops stateToFileName exe = do   -- We don't merge this with the other calls to waitForChildren,   -- because, e.g., for server, we don't want to wait for clients to exit,   -- if the server crashes (but we wait for the save to finish).   toSave <- newEmptyMVar-  a <- async $ loopSave saveFile toSave+  a <- async $ loopSave cops stateToFileName toSave   link a   let fin = do         -- Wait until the last save (if any) starts@@ -79,16 +86,13 @@  -- | Restore a saved game, if it exists. Initialize directory structure -- and copy over data files, if needed.-restoreGame :: Binary a-            => String -> [(FilePath, FilePath)] -> (FilePath -> IO FilePath)-            -> IO (Maybe a)-restoreGame name copies pathsDataFile = do+restoreGame :: Binary a => Kind.COps -> FilePath -> IO (Maybe a)+restoreGame cops fileName = do   -- Create user data directory and copy files, if not already there.   dataDir <- appDataDir   tryCreateDir dataDir-  tryCopyDataFiles dataDir pathsDataFile copies-  let saveFile = dataDir </> "saves" </> name-  saveExists <- doesFileExist saveFile+  let path bkp = dataDir </> "saves" </> bkp <> fileName+  saveExists <- doesFileExist (path "")   -- If the savefile exists but we get IO or decoding errors,   -- we show them and start a new game. If the savefile was randomly   -- corrupted or made read-only, that should solve the problem.@@ -96,20 +100,50 @@   -- terminate the program with an exception.   res <- Ex.try $     if saveExists then do-      s <- strictDecodeEOF saveFile-      return $ Just s+      (vExevLib2, s) <- strictDecodeEOF (path "")+      if vExevLib2 == vExevLib cops+      then return $ Just s+      else do+        let msg = "Savefile" <+> T.pack (path "") <+> "from old version"+                  <+> showVersion2 vExevLib2+                  <+> "detected while trying to restore"+                  <+> showVersion2 (vExevLib cops)+                  <+> "game."+        fail $ T.unpack msg     else return Nothing   let handler :: Ex.SomeException -> IO (Maybe a)       handler e = do-        let msg = "Restore failed. The error message is:"+        let msg = "Restore failed. The old file moved aside. The error message is:"                   <+> (T.unwords . T.lines) (tshow e)         delayPrint msg+        renameFile (path "") (path "bkp.")         return Nothing   either handler return res +vExevLib :: Kind.COps -> (Version, Version)+vExevLib cops =+  let exeVersion = rexeVersion $ Kind.stdRuleset $ Kind.corule cops+      libVersion = Self.version+  in (exeVersion, libVersion)++showVersion2 :: (Version, Version) -> Text+showVersion2 (exeVersion, libVersion) = T.pack $+  showVersion exeVersion <> "-" <> showVersion libVersion+ delayPrint :: Text -> IO () delayPrint t = do   delay <- R.randomRIO (0, 1000000)   threadDelay delay  -- try not to interleave saves with other clients-  T.hPutStrLn stderr t-  hFlush stderr+  T.hPutStrLn stdout t+  hFlush stdout++saveNameCli :: FactionId -> String+saveNameCli side =+  let n = fromEnum side  -- we depend on the numbering hack to number saves+  in (if n > 0+      then "human_" ++ show n+      else "computer_" ++ show (-n))+     ++ ".sav"++saveNameSer :: String+saveNameSer = "server.sav"

Game/LambdaHack/Common/State.hs view

@@ -10,9 +10,12 @@   , updateFactionD, updateTime, updateCOps   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Data.Binary import qualified Data.EnumMap.Strict as EM-import Data.Text (Text)  import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.Faction@@ -25,7 +28,7 @@ import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.TileKind (TileKind)+import Game.LambdaHack.Content.TileKind (TileKind, unknownId)  -- | View on game state. "Remembered" fields carry a subset of the info -- in the client copies of the state. Clients never directly change@@ -36,29 +39,24 @@   , _sactorD     :: !ActorDict    -- ^ remembered actors in the dungeon   , _sitemD      :: !ItemDict     -- ^ remembered items in the dungeon   , _sfactionD   :: !FactionDict  -- ^ remembered sides still in game-  , _stime       :: !Time         -- ^ global game time+  , _stime       :: !Time         -- ^ global game time, for UI display only   , _scops       :: Kind.COps     -- ^ remembered content   , _shigh       :: !HighScore.ScoreDict  -- ^ high score table   , _sgameModeId :: !(Kind.Id ModeKind)  -- ^ current game mode   }   deriving (Show, Eq) --- TODO: add a flag 'fresh' and when saving levels, don't save--- and when loading regenerate this level. unknownLevel :: Kind.COps -> AbsDepth -> X -> Y-             -> Text -> ([Point], [Point]) -> Int-             -> Int -> Int -> [Point]+             -> Text -> ([Point], [Point]) -> Int -> [Point] -> Bool              -> Level unknownLevel Kind.COps{cotile=Kind.Ops{ouniqGroup}}-             ldepth lxsize lysize ldesc lstair lclear-             lsecret lhidden lescape =-  let unknownId = ouniqGroup "unknown space"-      outerId = ouniqGroup "basic outer fence"+             ldepth lxsize lysize ldesc lstair lclear lescape lnight =+  let outerId = ouniqGroup "basic outer fence"   in Level { ldepth-           , lprio = EM.empty            , lfloor = EM.empty            , lembed = EM.empty-           , ltile = unknownTileMap unknownId outerId lxsize lysize+           , lactor = EM.empty+           , ltile = unknownTileMap outerId lxsize lysize            , lxsize            , lysize            , lsmell = EM.empty@@ -71,13 +69,12 @@            , lactorFreq = []            , litemNum = 0            , litemFreq = []-           , lsecret-           , lhidden            , lescape+           , lnight            } -unknownTileMap :: Kind.Id TileKind -> Kind.Id TileKind -> Int -> Int -> TileMap-unknownTileMap unknownId outerId lxsize lysize =+unknownTileMap :: Kind.Id TileKind -> Int -> Int -> TileMap+unknownTileMap outerId lxsize lysize =   let unknownMap = PointArray.replicateA lxsize lysize unknownId       borders = [ Point x y                 | x <- [0, lxsize - 1], y <- [1..lysize - 2] ]@@ -99,8 +96,8 @@     }  -- | Initial empty state.-emptyState :: State-emptyState =+emptyState :: Kind.COps -> State+emptyState _scops =   State     { _sdungeon = EM.empty     , _stotalDepth = AbsDepth 0@@ -108,16 +105,11 @@     , _sitemD = EM.empty     , _sfactionD = EM.empty     , _stime = timeZero-    , _scops = undefined+    , _scops     , _shigh = HighScore.empty-    , _sgameModeId = toEnum 0  -- the initial value is unused+    , _sgameModeId = minBound  -- the initial value is unused     } --- TODO: make lstair secret until discovered; use this later on for--- goUp in targeting mode (land on stairs of on the same location up a level--- if this set of stsirs is unknown).--- TODO: RNG should be secret, too, but we also want it to be deterministic,--- to aid in bug replication -- | Local state created by removing secret information from global -- state components. localFromGlobal :: State -> State@@ -126,7 +118,7 @@     { _sdungeon =       EM.map (\Level{..} ->               unknownLevel _scops ldepth lxsize lysize ldesc lstair lclear-                           lsecret lhidden lescape)+                           lescape lnight)              _sdungeon     , ..     }@@ -205,5 +197,5 @@     _stime <- get     _shigh <- get     _sgameModeId <- get-    let _scops = undefined  -- overwritten by recreated cops+    let _scops = assert `failure` "overwritten by recreated cops" `twith` ()     return $! State{..}

Game/LambdaHack/Common/Thread.hs view

@@ -3,6 +3,10 @@   ( forkChild, waitForChildren   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Control.Concurrent.Async import Control.Concurrent.MVar

Game/LambdaHack/Common/Tile.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} -- | Operations concerning dungeon level tiles. -- -- Unlike for many other content types, there is no type @Tile@,@@ -14,61 +14,50 @@ -- -- Actors at normal speed (2 m/s) take one turn to move one tile (1 m by 1 m). module Game.LambdaHack.Common.Tile-  ( SmellTime-  , kindHasFeature, hasFeature-  , isClear, isLit, isWalkable-  , isPassable, isPassableNoSuspect, isDoor, isSuspect-  , isExplorable, lookSimilar, speedup-  , openTo, closeTo, embedItems, causeEffects, revealAs, hideAs-  , isOpenable, isClosable, isChangeable, isEscape, isStair, ascendTo+  ( kindHasFeature, hasFeature, isClear, isLit, isWalkable, isDoor, isChangable+  , isSuspect, isHideAs, consideredByAI, isExplorable+  , isOftenItem, isOftenActor, isNoItem, isNoActor, isEasyOpen+  , speedup, alterMinSkill, alterMinWalk+  , openTo, closeTo, embeddedItems, revealAs, obscureAs, hideAs, buildAs+  , isEasyOpenKind, isOpenable, isClosable #ifdef EXPOSE_INTERNAL     -- * Internal operations-  , TileSpeedup(..), Tab, createTab, accessTab+  , createTab, createTabWithKey, accessTab #endif   ) where -import Control.Applicative-import Control.Exception.Assert.Sugar-import qualified Data.Array.Unboxed as A-import Data.Maybe+import Prelude () +import Game.LambdaHack.Common.Prelude++import qualified Data.Vector.Unboxed as U+import Data.Word (Word8)+ 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 (ItemKind)-import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.TileKind (TileKind)+import Game.LambdaHack.Content.TileKind (TileKind, TileSpeedup (..),+                                         isUknownSpace) import qualified Game.LambdaHack.Content.TileKind as TK --- | The last time a hero left a smell in a given tile. To be used--- by monsters that hunt by smell.-type SmellTime = Time--type instance Kind.Speedup TileKind = TileSpeedup--data TileSpeedup = TileSpeedup-  { isClearTab             :: !Tab-  , isLitTab               :: !Tab-  , isWalkableTab          :: !Tab-  , isPassableTab          :: !Tab-  , isPassableNoSuspectTab :: !Tab-  , isDoorTab              :: !Tab-  , isSuspectTab           :: !Tab-  , isChangeableTab        :: !Tab-  }--newtype Tab = Tab (A.UArray (Kind.Id TileKind) Bool)+createTab :: U.Unbox a => Kind.Ops TileKind -> (TileKind -> a) -> TK.Tab a+createTab Kind.Ops{ofoldrWithKey, olength} prop =+  let f _ t acc = prop t : acc+  in TK.Tab $ U.fromListN (fromEnum olength) $ ofoldrWithKey f [] -createTab :: Kind.Ops TileKind -> (TileKind -> Bool) -> Tab-createTab Kind.Ops{ofoldrWithKey, obounds} p =-  let f _ k acc = p k : acc-      clearAssocs = ofoldrWithKey f []-  in Tab $ A.listArray obounds clearAssocs+createTabWithKey :: U.Unbox a+                 => Kind.Ops TileKind -> (Kind.Id TileKind -> TileKind -> a)+                 -> TK.Tab a+createTabWithKey Kind.Ops{ofoldrWithKey, olength} prop =+  let f k t acc = prop k t : acc+  in TK.Tab $ U.fromListN (fromEnum olength) $ ofoldrWithKey f [] -accessTab :: Tab -> Kind.Id TileKind -> Bool+-- Unsafe indexing is pretty safe here, because we guard the vector+-- with the newtype.+accessTab :: U.Unbox a => TK.Tab a -> Kind.Id TileKind -> a {-# INLINE accessTab #-}-accessTab (Tab tab) ki = tab A.! ki+accessTab (TK.Tab tab) ki = tab `U.unsafeIndex` fromEnum ki  -- | Whether a tile kind has the given feature. kindHasFeature :: TK.Feature -> TileKind -> Bool@@ -82,87 +71,88 @@  -- | Whether a tile does not block vision. -- Essential for efficiency of "FOV", hence tabulated.-isClear :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+isClear :: TileSpeedup -> Kind.Id TileKind -> Bool {-# INLINE isClear #-}-isClear Kind.Ops{ospeedup = Just TileSpeedup{isClearTab}} = accessTab isClearTab-isClear cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile+isClear TileSpeedup{isClearTab} = accessTab isClearTab --- | Whether a tile is lit on its own.+-- | Whether a tile has ambient light --- is lit on its own. -- Essential for efficiency of "Perception", hence tabulated.-isLit :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+isLit :: TileSpeedup -> Kind.Id TileKind -> Bool {-# INLINE isLit #-}-isLit Kind.Ops{ospeedup = Just TileSpeedup{isLitTab}} = accessTab isLitTab-isLit cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile+isLit TileSpeedup{isLitTab} = accessTab isLitTab  -- | Whether actors can walk into a tile. -- Essential for efficiency of pathfinding, hence tabulated.-isWalkable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+isWalkable :: TileSpeedup -> Kind.Id TileKind -> Bool {-# INLINE isWalkable #-}-isWalkable Kind.Ops{ospeedup = Just TileSpeedup{isWalkableTab}} =-  accessTab isWalkableTab-isWalkable cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile---- | Whether actors can walk into a tile, perhaps opening a door first,--- perhaps a hidden door.--- Essential for efficiency of pathfinding, hence tabulated.-isPassable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-{-# INLINE isPassable #-}-isPassable Kind.Ops{ospeedup = Just TileSpeedup{isPassableTab}} =-  accessTab isPassableTab-isPassable cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile---- | Whether actors can walk into a tile, perhaps opening a door first,--- perhaps a hidden door.--- Essential for efficiency of pathfinding, hence tabulated.-isPassableNoSuspect :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-{-# INLINE isPassableNoSuspect #-}-isPassableNoSuspect Kind.Ops{ospeedup =-                               Just TileSpeedup{isPassableNoSuspectTab}} =-  accessTab isPassableNoSuspectTab-isPassableNoSuspect cotile =-  assert `failure` "no speedup" `twith` Kind.obounds cotile+isWalkable TileSpeedup{isWalkableTab} = accessTab isWalkableTab  -- | Whether a tile is a door, open or closed. -- Essential for efficiency of pathfinding, hence tabulated.-isDoor :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+isDoor :: TileSpeedup -> Kind.Id TileKind -> Bool {-# INLINE isDoor #-}-isDoor Kind.Ops{ospeedup = Just TileSpeedup{isDoorTab}} = accessTab isDoorTab-isDoor cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile+isDoor TileSpeedup{isDoorTab} = accessTab isDoorTab +-- | Whether a tile is changable.+isChangable :: TileSpeedup -> Kind.Id TileKind -> Bool+{-# INLINE isChangable #-}+isChangable TileSpeedup{isChangableTab} = accessTab isChangableTab+ -- | Whether a tile is suspect. -- Essential for efficiency of pathfinding, hence tabulated.-isSuspect :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+isSuspect :: TileSpeedup -> Kind.Id TileKind -> Bool {-# INLINE isSuspect #-}-isSuspect Kind.Ops{ospeedup = Just TileSpeedup{isSuspectTab}} =-  accessTab isSuspectTab-isSuspect cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile+isSuspect TileSpeedup{isSuspectTab} = accessTab isSuspectTab --- | Whether a tile kind (specified by its id) has a ChangeTo feature.--- Essential for efficiency of pathfinding, hence tabulated.-isChangeable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-{-# INLINE isChangeable #-}-isChangeable Kind.Ops{ospeedup = Just TileSpeedup{isChangeableTab}} =-  accessTab isChangeableTab-isChangeable cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile+isHideAs :: TileSpeedup -> Kind.Id TileKind -> Bool+{-# INLINE isHideAs #-}+isHideAs TileSpeedup{isHideAsTab} = accessTab isHideAsTab +consideredByAI :: TileSpeedup -> Kind.Id TileKind -> Bool+{-# INLINE consideredByAI #-}+consideredByAI TileSpeedup{consideredByAITab} = accessTab consideredByAITab++isOftenItem :: TileSpeedup -> Kind.Id TileKind -> Bool+{-# INLINE isOftenItem #-}+isOftenItem TileSpeedup{isOftenItemTab} = accessTab isOftenItemTab++isOftenActor:: TileSpeedup -> Kind.Id TileKind -> Bool+{-# INLINE isOftenActor #-}+isOftenActor TileSpeedup{isOftenActorTab} = accessTab isOftenActorTab++isNoItem :: TileSpeedup -> Kind.Id TileKind -> Bool+{-# INLINE isNoItem #-}+isNoItem TileSpeedup{isNoItemTab} = accessTab isNoItemTab++isNoActor :: TileSpeedup -> Kind.Id TileKind -> Bool+{-# INLINE isNoActor #-}+isNoActor TileSpeedup{isNoActorTab} = accessTab isNoActorTab++-- | Whether a tile kind (specified by its id) has an OpenTo feature+-- and reasonable alter min skill.+isEasyOpen :: TileSpeedup -> Kind.Id TileKind -> Bool+{-# INLINE isEasyOpen #-}+isEasyOpen TileSpeedup{isEasyOpenTab} = accessTab isEasyOpenTab++alterMinSkill :: TileSpeedup -> Kind.Id TileKind -> Int+{-# INLINE alterMinSkill #-}+alterMinSkill TileSpeedup{alterMinSkillTab} =+  fromEnum . accessTab alterMinSkillTab++alterMinWalk :: TileSpeedup -> Kind.Id TileKind -> Int+{-# INLINE alterMinWalk #-}+alterMinWalk TileSpeedup{alterMinWalkTab} =+  fromEnum . accessTab alterMinWalkTab+ -- | Whether one can easily explore a tile, possibly finding a treasure -- or a clue. Doors can't be explorable since revealing a secret tile -- should not change it's (walkable and) explorable status. -- Door status should not depend on whether they are open or not -- so that a foe opening a door doesn't force us to backtrack to explore it.-isExplorable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-{-# INLINE isExplorable #-}-isExplorable cotile t =-  (isWalkable cotile t || isClear cotile t) && not (isDoor cotile t)---- | The player can't tell one tile from the other.-lookSimilar :: TileKind -> TileKind -> Bool-{-# INLINE lookSimilar #-}-lookSimilar t u =-  TK.tsymbol t == TK.tsymbol u &&-  TK.tname   t == TK.tname   u &&-  TK.tcolor  t == TK.tcolor  u &&-  TK.tcolor2 t == TK.tcolor2 u+isExplorable :: TileSpeedup -> Kind.Id TileKind -> Bool+isExplorable coTileSpeedup t =+  (isWalkable coTileSpeedup t || isClear coTileSpeedup t)+  && not (isDoor coTileSpeedup t)  speedup :: Bool -> Kind.Ops TileKind -> TileSpeedup speedup allClear cotile =@@ -170,66 +160,93 @@   -- taken makes random lookups more or less efficient, so not optimizing   -- further, until I have benchmarks.   let isClearTab | allClear = createTab cotile-                              $ not . kindHasFeature TK.Impenetrable+                              $ not . (== maxBound) . TK.talter                  | otherwise = createTab cotile                                $ kindHasFeature TK.Clear       isLitTab = createTab cotile $ not . kindHasFeature TK.Dark       isWalkableTab = createTab cotile $ kindHasFeature TK.Walkable-      isPassableTab = createTab cotile $ isPassableKind True-      isPassableNoSuspectTab = createTab cotile $ isPassableKind False       isDoorTab = createTab cotile $ \tk ->         let getTo TK.OpenTo{} = True             getTo TK.CloseTo{} = True             getTo _ = False         in any getTo $ TK.tfeature tk-      isSuspectTab = createTab cotile $ kindHasFeature TK.Suspect-      isChangeableTab = createTab cotile $ \tk ->+      isChangableTab = createTab cotile $ \tk ->         let getTo TK.ChangeTo{} = True             getTo _ = False         in any getTo $ TK.tfeature tk+      isSuspectTab = createTab cotile TK.isSuspectKind+      isHideAsTab = createTab cotile $ \tk ->+        let getTo TK.HideAs{} = True+            getTo _ = False+        in any getTo $ TK.tfeature tk+      consideredByAITab = createTab cotile $ kindHasFeature TK.ConsideredByAI+      isOftenItemTab = createTab cotile $ kindHasFeature TK.OftenItem+      isOftenActorTab = createTab cotile $ kindHasFeature TK.OftenActor+      isNoItemTab = createTab cotile $ kindHasFeature TK.NoItem+      isNoActorTab = createTab cotile $ kindHasFeature TK.NoActor+      isEasyOpenTab = createTab cotile isEasyOpenKind+      alterMinSkillTab = createTabWithKey cotile alterMinSkillKind+      alterMinWalkTab = createTabWithKey cotile alterMinWalkKind   in TileSpeedup {..} -isPassableKind :: Bool -> TileKind -> Bool-isPassableKind passSuspect tk =-  let getTo TK.Walkable = True-      getTo TK.OpenTo{} = True-      getTo TK.ChangeTo{} = True  -- can change to passable and may have loot-      getTo TK.Suspect | passSuspect = True+-- Check that alter can be used, if not, @maxBound@.+-- For now, we assume only items with @Embed@ may have embedded items,+-- whether inserted at dungeon creation or later on.+-- This is used by UI and server to validate (sensibility of) altering.+-- See the comment for @alterMinWalkKind@ regarding @HideAs@.+alterMinSkillKind :: Kind.Id TileKind -> TileKind -> Word8+alterMinSkillKind _k tk =+  let getTo TK.OpenTo{} = True+      getTo TK.CloseTo{} = True+      getTo TK.ChangeTo{} = True+      getTo TK.HideAs{} = True  -- in case tile swapped, but server sends hidden+      getTo TK.RevealAs{} = True+      getTo TK.ObscureAs{} = True+      getTo TK.Embed{} = True+      getTo TK.ConsideredByAI = True       getTo _ = False-  in any getTo $ TK.tfeature tk+  in if any getTo $ TK.tfeature tk then TK.talter tk else maxBound +-- How high alter skill is needed to make it walkable. If already+-- walkable, put @0@, if can't, put @maxBound@. Used only be AI and Bfs+-- We don't include @HideAs@, because it's very unlikely anybody swapped+-- the tile while AI was not looking so AI can assume it's still uninteresting.+-- Pathfinding in UI will also not show such tile as passable, which is OK.+-- If a human player has a suspicion the tile was swapped, he can check+-- it manually, disregarding the displayed path hints.+alterMinWalkKind :: Kind.Id TileKind -> TileKind -> Word8+alterMinWalkKind k tk =+  let getTo TK.OpenTo{} = True+      getTo TK.RevealAs{} = True+      getTo TK.ObscureAs{} = True+      getTo _ = False+  in if | kindHasFeature TK.Walkable tk -> 0+        | isUknownSpace k -> TK.talter tk+        | any getTo $ TK.tfeature tk -> TK.talter tk+        | otherwise -> maxBound+ openTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind) openTo Kind.Ops{okind, opick} t = do   let getTo (TK.OpenTo grp) acc = grp : acc       getTo _ acc = acc   case foldr getTo [] $ TK.tfeature $ okind t of-    [] -> return t-    groups -> do-      grp <- oneOf groups-      fromMaybe (assert `failure` grp) <$> opick grp (const True)+    [grp] -> fromMaybe (assert `failure` grp) <$> opick grp (const True)+    _ -> return t  closeTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind) closeTo Kind.Ops{okind, opick} t = do   let getTo (TK.CloseTo grp) acc = grp : acc       getTo _ acc = acc   case foldr getTo [] $ TK.tfeature $ okind t of-    [] -> return t-    groups -> do-      grp <- oneOf groups-      fromMaybe (assert `failure` grp) <$> opick grp (const True)+    [grp] -> fromMaybe (assert `failure` grp) <$> opick grp (const True)+    _ -> return t -embedItems :: Kind.Ops TileKind -> Kind.Id TileKind -> [GroupName ItemKind]-embedItems Kind.Ops{okind} t =+embeddedItems :: Kind.Ops TileKind -> Kind.Id TileKind -> [GroupName ItemKind]+embeddedItems Kind.Ops{okind} t =   let getTo (TK.Embed eff) acc = eff : acc       getTo _ acc = acc   in foldr getTo [] $ TK.tfeature $ okind t -causeEffects :: Kind.Ops TileKind -> Kind.Id TileKind -> [IK.Effect]-causeEffects Kind.Ops{okind} t =-  let getTo (TK.Cause eff) acc = eff : acc-      getTo _ acc = acc-  in foldr getTo [] $ TK.tfeature $ okind t- revealAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind) revealAs Kind.Ops{okind, opick} t = do   let getTo (TK.RevealAs grp) acc = grp : acc@@ -240,40 +257,43 @@       grp <- oneOf groups       fromMaybe (assert `failure` grp) <$> opick grp (const True) -hideAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Kind.Id TileKind-hideAs Kind.Ops{okind, ouniqGroup} t =-  let getTo (TK.HideAs grp) _ = Just grp+obscureAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind)+obscureAs Kind.Ops{okind, opick} t = do+  let getTo (TK.ObscureAs grp) acc = grp : acc       getTo _ acc = acc-  in case foldr getTo Nothing (TK.tfeature (okind t)) of-       Nothing    -> t-       Just grp -> ouniqGroup grp+  case foldr getTo [] $ TK.tfeature $ okind t of+    [] -> return t+    groups -> do+      grp <- oneOf groups+      fromMaybe (assert `failure` grp) <$> opick grp (const True) --- | Whether a tile kind (specified by its id) has an OpenTo feature.-isOpenable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-isOpenable Kind.Ops{okind} t =-  let getTo TK.OpenTo{} = True+hideAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Kind.Id TileKind+hideAs Kind.Ops{okind, ouniqGroup} t =+  let getTo TK.HideAs{} = True       getTo _ = False-  in any getTo $ TK.tfeature $ okind t+  in case find getTo $ TK.tfeature $ okind t of+       Just (TK.HideAs grp) -> ouniqGroup grp+       _ -> t --- | Whether a tile kind (specified by its id) has a CloseTo feature.-isClosable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-isClosable Kind.Ops{okind} t =-  let getTo TK.CloseTo{} = True+buildAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Kind.Id TileKind+buildAs Kind.Ops{okind, ouniqGroup} t =+  let getTo TK.BuildAs{} = True       getTo _ = False-  in any getTo $ TK.tfeature $ okind t+  in case find getTo $ TK.tfeature $ okind t of+       Just (TK.BuildAs grp) -> ouniqGroup grp+       _ -> t -isEscape :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-isEscape cotile t = let isEffectEscape IK.Escape{} = True-                        isEffectEscape _ = False-                    in any isEffectEscape $ causeEffects cotile t+isEasyOpenKind :: TileKind -> Bool+isEasyOpenKind tk =+  let getTo TK.OpenTo{} = True+      getTo TK.Walkable = True  -- very easy open+      getTo _ = False+  in TK.talter tk < 10 && any getTo (TK.tfeature tk) -isStair :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-isStair cotile t = let isEffectAscend IK.Ascend{} = True-                       isEffectAscend _ = False-                   in any isEffectAscend $ causeEffects cotile t+-- | Whether a tile kind (specified by its id) has an OpenTo feature.+isOpenable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+isOpenable Kind.Ops{okind} t = TK.isOpenableKind $ okind t -ascendTo :: Kind.Ops TileKind -> Kind.Id TileKind -> [Int]-ascendTo cotile t =-  let getTo (IK.Ascend k) acc = k : acc-      getTo _ acc = acc-  in foldr getTo [] (causeEffects cotile t)+-- | Whether a tile kind (specified by its id) has a CloseTo feature.+isClosable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+isClosable Kind.Ops{okind} t = TK.isClosableKind $ okind t

Game/LambdaHack/Common/Time.hs view

@@ -2,21 +2,25 @@ -- | Game time and speed. module Game.LambdaHack.Common.Time   ( Time, timeZero, timeClip, timeTurn, timeEpsilon-  , absoluteTimeAdd, absoluteTimeNegate, timeFit, timeFitUp+  , absoluteTimeAdd, absoluteTimeSubtract, absoluteTimeNegate+  , timeFit, timeFitUp   , Delta(..), timeShift, timeDeltaToFrom-  , timeDeltaSubtract, timeDeltaReverse, timeDeltaScale+  , timeDeltaSubtract, timeDeltaReverse, timeDeltaScale, timeDeltaPercent   , timeDeltaToDigit, ticksPerMeter-  , Speed, toSpeed, fromSpeed, speedZero, speedNormal+  , Speed, toSpeed, fromSpeed+  , speedZero, speedWalk, speedThrust, modifyDamageBySpeed   , speedScale, timeDeltaDiv, speedAdd, speedNegate-  , speedFromWeight, rangeFromSpeed, rangeFromSpeedAndLinger+  , speedFromWeight, rangeFromSpeedAndLinger   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Data.Binary import qualified Data.Char as Char import Data.Int (Int64) -import Game.LambdaHack.Common.Misc- -- | Game time in ticks. The time dimension. -- One tick is 1 microsecond (one millionth of a second), -- one turn is 0.5 s.@@ -43,15 +47,12 @@ timeEpsilon :: Time timeEpsilon = _timeTick --- TODO: don't have a fixed time, but instead set it at 1/3 or 1/4--- of timeTurn depending on level. Clips are a UI feature--- after all, so should depend on the user situation.--- | At least once per clip all moves are resolved and a frame--- or a frame delay is generated.--- Currently one clip is 0.1 s, but it may change,+-- | At least once per clip all moves are resolved+-- and a frame or a frame delay is generated.+-- Currently one clip is 0.05 s, but it may change, -- and the code should not depend on this fixed value. timeClip :: Time-timeClip = Time 100000+timeClip = Time 50000  -- | One turn is 0.5 s. The code may depend on that. -- Actors at normal speed (2 m/s) take one turn to move one tile (1 m by 1 m).@@ -71,57 +72,78 @@ -- | Absolute time addition, e.g., for summing the total game session time -- from the times of individual games. absoluteTimeAdd :: Time -> Time -> Time+{-# INLINE absoluteTimeAdd #-} absoluteTimeAdd (Time t1) (Time t2) = Time (t1 + t2) +absoluteTimeSubtract :: Time -> Time -> Time+{-# INLINE absoluteTimeSubtract #-}+absoluteTimeSubtract (Time t1) (Time t2) = Time (t1 - t2)+ -- | Shifting an absolute time by a time vector. timeShift :: Time -> Delta Time -> Time+{-# INLINE timeShift #-} timeShift (Time t1) (Delta (Time t2)) = Time (t1 + t2)  -- | How many time intervals of the latter kind fits in an interval -- of the former kind. timeFit :: Time -> Time -> Int-timeFit (Time t1) (Time t2) = fromIntegral $ t1 `div` t2+{-# INLINE timeFit #-}+timeFit (Time t1) (Time t2) = fromEnum $ t1 `div` t2  -- | How many time intervals of the latter kind cover an interval -- of the former kind (rounded up). timeFitUp :: Time -> Time -> Int-timeFitUp (Time t1) (Time t2) = fromIntegral $ t1 `divUp` t2+{-# INLINE timeFitUp #-}+timeFitUp (Time t1) (Time t2) = fromEnum $ t1 `divUp` t2  -- | Reverse a time vector. timeDeltaReverse :: Delta Time -> Delta Time+{-# INLINE timeDeltaReverse #-} timeDeltaReverse (Delta (Time t)) = Delta (Time (-t))  -- | Absolute time negation. To be used for reversing time flow, -- e.g., for comparing absolute times in the reverse order. absoluteTimeNegate :: Time -> Time+{-# INLINE absoluteTimeNegate #-} absoluteTimeNegate (Time t) = Time (-t)  -- | Time time vector between the second and the first absolute times. -- The arguments are in the same order as in the underlying scalar subtraction. timeDeltaToFrom :: Time -> Time -> Delta Time+{-# INLINE timeDeltaToFrom #-} timeDeltaToFrom (Time t1) (Time t2) = Delta $ Time (t1 - t2)  -- | Time time vector between the second and the first absolute times. -- The arguments are in the same order as in the underlying scalar subtraction. timeDeltaSubtract :: Delta Time -> Delta Time -> Delta Time+{-# INLINE timeDeltaSubtract #-} timeDeltaSubtract (Delta (Time t1)) (Delta (Time t2)) = Delta $ Time (t1 - t2)  -- | Scale the time vector by an @Int@ scalar value. timeDeltaScale :: Delta Time -> Int -> Delta Time+{-# INLINE timeDeltaScale #-} timeDeltaScale (Delta (Time t)) s = Delta (Time (t * fromIntegral s)) +-- | Take the given percent of the time vector..+timeDeltaPercent :: Delta Time -> Int -> Delta Time+{-# INLINE timeDeltaPercent #-}+timeDeltaPercent (Delta (Time t)) s =+  Delta (Time (t * fromIntegral s `div` 100))+ -- | Divide a time vector. timeDeltaDiv :: Delta Time -> Int -> Delta Time+{-# INLINE timeDeltaDiv #-} timeDeltaDiv (Delta (Time t)) n = Delta (Time (t `div` fromIntegral n))  -- | Represent the main 10 thresholds of a time range by digits, -- given the total length of the time range. timeDeltaToDigit :: Delta Time -> Delta Time -> Char+{-# INLINE timeDeltaToDigit #-} timeDeltaToDigit (Delta (Time maxT)) (Delta (Time t)) =-  let k = 10 * t `div` maxT+  let k = 1 + 9 * t `div` maxT       digit | k > 9     = '*'-            | k < 0     = '-'-            | otherwise = Char.intToDigit $ fromIntegral k+            | k < 1     = '-'+            | otherwise = Char.intToDigit $ fromEnum k   in digit  -- | Speed in meters per 1 million seconds (m/Ms).@@ -139,6 +161,7 @@  -- | Constructor for content definitions. toSpeed :: Int -> Speed+{-# INLINE toSpeed #-} toSpeed s = Speed $ fromIntegral s * sInMs `div` 10  -- Can't be lower or actors would slow down (via tmp organs and weight),@@ -148,30 +171,55 @@  -- | Pretty-printing of speed in the format used in content definitions. fromSpeed :: Speed -> Int-fromSpeed (Speed s) = fromIntegral $ s * 10 `div` sInMs+{-# INLINE fromSpeed #-}+fromSpeed (Speed s) = fromEnum $ s * 10 `div` sInMs  -- | No movement possible at that speed. speedZero :: Speed speedZero = Speed 0 --- | Normal speed (2 m/s) that suffices to move one tile in one turn.-speedNormal :: Speed-speedNormal = Speed $ 2 * sInMs+-- | Fast walk speed (2 m/s) that suffices to move one tile in one turn.+speedWalk :: Speed+speedWalk = Speed $ 2 * sInMs +-- | Sword thrust speed (10 m/s). Base weapon damages, both melee and ranged,+-- are given assuming this speed and ranged damage is modified+-- accordingly when projectile speeds differ. Differences in melee+-- weapon swing speeds are captured in damage bonuses instead,+-- since many other factors influence total damage.+--+-- Billiard ball is 25 m/s, sword swing at the tip is 35 m/s,+-- medieval bow is 70 m/s, AK47 is 700 m/s.+speedThrust :: Speed+speedThrust = Speed $ 10 * sInMs++-- | Modify damage when projectiles is at a non-standard speed.+-- Energy and so damage is proportional to the square of speed,+-- hence the formula.+modifyDamageBySpeed :: Int64 -> Speed -> Int64+modifyDamageBySpeed dmg (Speed s) =+  let Speed sThrust = speedThrust+  in round (fromIntegral dmg * fromIntegral s ^ (2 :: Int)  -- overflows Int64+            / fromIntegral sThrust ^ (2 :: Int) :: Double)+ -- | Scale speed by an @Int@ scalar value. speedScale :: Rational -> Speed -> Speed+{-# INLINE speedScale #-} speedScale s (Speed v) = Speed (round $ fromIntegral v * s)  -- | Speed addition. speedAdd :: Speed -> Speed -> Speed+{-# INLINE speedAdd #-} speedAdd (Speed s1) (Speed s2) = Speed (s1 + s2)  -- | Speed negation. speedNegate :: Speed -> Speed+{-# INLINE speedNegate #-} speedNegate (Speed n) = Speed (-n)  -- | The number of time ticks it takes to walk 1 meter at the given speed. ticksPerMeter :: Speed -> Delta Time+{-# INLINE ticksPerMeter #-} ticksPerMeter (Speed v) =   Delta $ Time $ _ticksInSecond * sInMs `divUp` max minimalSpeed v @@ -179,15 +227,14 @@ -- and velocity percent modifier. -- See <https://github.com/LambdaHack/LambdaHack/wiki/Item-statistics>. speedFromWeight :: Int -> Int -> Speed-speedFromWeight weight velocityPercent =+speedFromWeight !weight !velocityPercent =   let w = fromIntegral weight       vp = fromIntegral velocityPercent-      mpMs | w <= 500 = sInMs * 16-           | w > 500 && w <= 2000 = sInMs * 16 * 1500 `div` (w + 1000)-           | w < 16000 = sInMs * (18000 - w) `div` 1000+      mpMs | w < 250 = sInMs * 20+           | w < 1500 = sInMs * 20 * 1250 `div` (w + 1000)+           | w < 10500 = sInMs * (11500 - w) `div` 1000            | w < 200000 = sInMs  -- half a step per turn is the minimum            | otherwise = minimalSpeed  -- unless _very_ heavy-               -- TODO: such high weight should also affect moving       v = mpMs * vp `div` 100       -- We round down to the nearest multiple of 2M (unless the speed       -- is very low), to ensure both turns of flight cover the same distance@@ -202,10 +249,11 @@ -- With this formula, each projectile flies for at most 1 second, -- that is 2 turns, and then drops to the ground. rangeFromSpeed :: Speed -> Int-rangeFromSpeed (Speed v) = fromIntegral $ v `div` sInMs+{-# INLINE rangeFromSpeed #-}+rangeFromSpeed (Speed v) = fromEnum $ v `div` sInMs  -- | Calculate maximum range taking into account the linger percentage. rangeFromSpeedAndLinger :: Speed -> Int -> Int-rangeFromSpeedAndLinger speed linger =+rangeFromSpeedAndLinger !speed !linger =   let range = rangeFromSpeed speed   in linger * range `divUp` 100

Game/LambdaHack/Common/Vector.hs view

@@ -3,18 +3,24 @@ -- but not unique, way. module Game.LambdaHack.Common.Vector   ( Vector(..), isUnit, isDiagonal, neg, chessDistVector, euclidDistSqVector-  , moves, movesCardinal, movesDiagonal, compassText, vicinity, vicinityCardinal+  , moves, movesCardinal, movesDiagonal, compassText+  , vicinity, vicinityUnsafe, vicinityCardinal, vicinityCardinalUnsafe+  , squareUnsafeSet   , shift, shiftBounded, trajectoryToPath, trajectoryToPathBounded   , vectorToFrom, pathToTrajectory   , RadianAngle, rotate, towards   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Control.DeepSeq-import Control.Exception.Assert.Sugar import Data.Binary import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES import Data.Int (Int32)-import Data.Text (Text)+ import GHC.Generics (Generic)  import Game.LambdaHack.Common.Point@@ -26,15 +32,22 @@   { vx :: !X   , vy :: !Y   }-  deriving (Eq, Ord, Show, Read, Generic)+  deriving (Show, Read, Eq, Ord, Generic)  instance Binary Vector where   put = put . (fromIntegral :: Int -> Int32) . fromEnum   get = fmap (toEnum . (fromIntegral :: Int32 -> Int)) get +-- Note that the conversion is not monotonic wrt the natural @Ord@ instance,+-- to keep it in sync with Point. instance Enum Vector where-  fromEnum = fromEnumVector-  toEnum = toEnumVector+  fromEnum (Vector vx vy) = vx + vy * (2 ^ maxLevelDimExponent)+  toEnum n =+    let (y, x) = n `quotRem` (2 ^ maxLevelDimExponent)+        (vx, vy) | x > maxVectorDim = (x - 2 ^ maxLevelDimExponent, y + 1)+                 | x < - maxVectorDim = (x + 2 ^ maxLevelDimExponent, y - 1)+                 | otherwise = (x, y)+    in Vector{..}  instance NFData Vector @@ -43,19 +56,6 @@ {-# INLINE maxVectorDim #-} maxVectorDim = 2 ^ (maxLevelDimExponent - 1) - 1 -fromEnumVector :: Vector -> Int-{-# INLINE fromEnumVector #-}-fromEnumVector (Vector vx vy) = vx + vy * (2 ^ maxLevelDimExponent)--toEnumVector :: Int -> Vector-{-# INLINE toEnumVector #-}-toEnumVector n =-  let (y, x) = n `quotRem` (2 ^ maxLevelDimExponent)-      (vx, vy) | x > maxVectorDim = (x - 2 ^ maxLevelDimExponent, y + 1)-               | x < - maxVectorDim = (x + 2 ^ maxLevelDimExponent, y - 1)-               | otherwise = (x, y)-  in Vector{..}- -- | Tells if a vector has length 1 in the chessboard metric. isUnit :: Vector -> Bool {-# INLINE isUnit #-}@@ -75,10 +75,8 @@  -- | Squared euclidean distance between two vectors. euclidDistSqVector :: Vector -> Vector -> Int-{-# INLINE euclidDistSqVector #-} euclidDistSqVector (Vector x0 y0) (Vector x1 y1) =-  let square n = n ^ (2 :: Int)-  in square (x1 - x0) + square (y1 - y0)+  (x1 - x0) ^ (2 :: Int) + (y1 - y0) ^ (2 :: Int)  -- | The lenght of a vector in the chessboard metric, -- where diagonal moves cost 1.@@ -89,16 +87,19 @@ -- | Vectors of all unit moves in the chessboard metric, -- clockwise, starting north-west. moves :: [Vector]-{-# NOINLINE moves #-} moves =   map (uncurry Vector)     [(-1, -1), (0, -1), (1, -1), (1, 0), (1, 1), (0, 1), (-1, 1), (-1, 0)] -moveTexts :: [Text]-moveTexts = ["NW", "N", "NE", "E", "SE", "S", "SW", "W"]+_moveTexts :: [Text]+_moveTexts = ["NW", "N", "NE", "E", "SE", "S", "SW", "W"] +longMoveTexts :: [Text]+longMoveTexts = [ "northwest", "north", "northeast", "east"+                , "southeast", "south", "southwest", "west" ]+ compassText :: Vector -> Text-compassText v = let m = EM.fromList $ zip moves moveTexts+compassText v = let m = EM.fromList $ zip moves longMoveTexts                     assFail = assert `failure` "not a unit vector" `twith` v                 in EM.findWithDefault assFail v m @@ -122,9 +123,7 @@              , inside res (0, 0, lxsize - 1, lysize - 1) ]  vicinityUnsafe :: Point -> [Point]-vicinityUnsafe p =-  [ res | dxy <- moves-        , let res = shift p dxy ]+vicinityUnsafe p = [ shift p dxy | dxy <- moves ]  -- | All (4 at most) cardinal direction neighbours of a point within an area. vicinityCardinal :: X -> Y   -- ^ limit the search to this area@@ -135,6 +134,22 @@         , let res = shift p dxy         , inside res (0, 0, lxsize - 1, lysize - 1) ] +vicinityCardinalUnsafe :: Point -> [Point]+vicinityCardinalUnsafe p = [ shift p dxy | dxy <- movesCardinal ]++squareUnsafeSet :: Point -> ES.EnumSet Point+squareUnsafeSet (Point x y) =+  ES.fromDistinctAscList $ map (uncurry Point)+    [ (x - 1, y - 1)+    , (x,     y - 1)+    , (x + 1, y - 1)+    , (x - 1, y)+    , (x,     y)  -- full square, including the origin+    , (x + 1, y)+    , (x - 1, y + 1)+    , (x,     y + 1)+    , (x + 1, y + 1) ]+ -- | Translate a point by a vector. shift :: Point -> Vector -> Point {-# INLINE shift #-}@@ -173,6 +188,7 @@ pathToTrajectory :: [Point] -> [Vector] pathToTrajectory [] = [] pathToTrajectory lp1@(_ : lp2) = zipWith vectorToFrom lp2 lp1+ type RadianAngle = Double  -- | Rotate a vector by the given angle (expressed in radians)@@ -188,7 +204,6 @@       dy = x * sin (-angle) + y * cos (-angle)   in normalize dx dy --- TODO: use bla for that -- | Given a vector of arbitrary non-zero length, produce a unit vector -- that points in the same direction (in the chessboard metric). -- Of several equally good directions it picks one of those that visually@@ -217,10 +232,6 @@              `twith` (v, res))      res --- TODO: Perhaps produce all acceptable directions and let AI choose.--- That would also eliminate the Doubles. Or only directions from bla?--- Smart monster could really use all dirs to be less predictable,--- but it wouldn't look as natural as bla, so for less smart bla is better. -- | Given two distinct positions, determine the direction (a unit vector) -- in which one should move from the first in order to get closer -- to the second. Ignores obstacles. Of several equally good directions

Game/LambdaHack/Content/CaveKind.hs view

@@ -3,7 +3,10 @@   ( CaveKind(..), validateSingleCaveKind, validateAllCaveKind   ) where -import Data.Text (Text)+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import qualified Data.Text as T  import qualified Game.LambdaHack.Common.Dice as Dice@@ -23,13 +26,14 @@   , cxsize          :: !X            -- ^ X size of the whole cave   , cysize          :: !Y            -- ^ Y size of the whole cave   , cgrid           :: !Dice.DiceXY  -- ^ the dimensions of the grid of places-  , cminPlaceSize   :: !Dice.DiceXY  -- ^ minimal size of places+  , cminPlaceSize   :: !Dice.DiceXY  -- ^ minimal size of places; for merging   , cmaxPlaceSize   :: !Dice.DiceXY  -- ^ maximal size of places   , cdarkChance     :: !Dice.Dice    -- ^ the chance a place is dark   , cnightChance    :: !Dice.Dice    -- ^ the chance the cave is dark   , cauxConnects    :: !Rational     -- ^ a proportion of extra connections   , cmaxVoid        :: !Rational     -- ^ at most this proportion of rooms void   , cminStairDist   :: !Int          -- ^ minimal distance between stairs+  , cextraStairs    :: !Dice.Dice    -- ^ extra stairs on top of from above   , cdoorChance     :: !Chance       -- ^ the chance of a door in an opening   , copenChance     :: !Chance       -- ^ if there's a door, is it open?   , chidden         :: !Int          -- ^ if not open, hidden one in n times@@ -48,6 +52,10 @@   , couterFenceTile :: !(GroupName TileKind)  -- ^ the outer fence wall   , clegendDarkTile :: !(GroupName TileKind)  -- ^ the dark place plan legend   , clegendLitTile  :: !(GroupName TileKind)  -- ^ the lit place plan legend+  , cescapeGroup    :: !(Maybe (GroupName PlaceKind))  -- ^ escape, if any+  , cstairFreq      :: !(Freqs PlaceKind)+      -- ^ place groups to consider for stairs; in this case the rarity+      --   of items in the group does not affect group choice   }   deriving Show  -- No Eq and Ord to make extending it logically sound @@ -55,36 +63,36 @@ -- of the cave descriptions to make sure they fit on screen. Etc. validateSingleCaveKind :: CaveKind -> [Text] validateSingleCaveKind CaveKind{..} =-  let (maxGridX, maxGridY) = Dice.maxDiceXY cgrid+  let (minGridX, minGridY) = Dice.minDiceXY cgrid+      (maxGridX, maxGridY) = Dice.maxDiceXY cgrid       (minMinSizeX, minMinSizeY) = Dice.minDiceXY cminPlaceSize       (maxMinSizeX, maxMinSizeY) = Dice.maxDiceXY cminPlaceSize       (minMaxSizeX, minMaxSizeY) = Dice.minDiceXY cmaxPlaceSize-      -- If there is at most one room, we need extra borders for a passage,-      -- but if there may be more rooms, we have that space, anyway,-      -- because multiple rooms take more space than borders.-      xborder = if maxGridX == 1 || couterFenceTile /= "basic outer fence"-                then 2-                else 0-      yborder = if maxGridY == 1 || couterFenceTile /= "basic outer fence"-                then 2-                else 0+      xborder = if couterFenceTile /= "basic outer fence" then 2 else 0+      yborder = if couterFenceTile /= "basic outer fence" then 2 else 0   in [ "cname longer than 25" | T.length cname > 25 ]      ++ [ "cxsize < 7" | cxsize < 7 ]      ++ [ "cysize < 7" | cysize < 7 ]+     ++ [ "minGridX < 1" | minGridX < 1 ]+     ++ [ "minGridY < 1" | minGridY < 1 ]      ++ [ "minMinSizeX < 1" | minMinSizeX < 1 ]      ++ [ "minMinSizeY < 1" | minMinSizeY < 1 ]      ++ [ "minMaxSizeX < maxMinSizeX" | minMaxSizeX < maxMinSizeX ]      ++ [ "minMaxSizeY < maxMinSizeY" | minMaxSizeY < maxMinSizeY ]      ++ [ "cxsize too small"-        | maxGridX * (maxMinSizeX + 1) + xborder >= cxsize ]+        | maxGridX * (maxMinSizeX - 4) + xborder >= cxsize ]      ++ [ "cysize too small"-        | maxGridY * (maxMinSizeY + 1) + yborder >= cysize ]+        | maxGridY * maxMinSizeY + yborder >= cysize ]+     ++ [ "cextraStairs < 0" | cextraStairs < 0 ]+     ++ [ "chidden < 0" | chidden < 0 ]+     ++ [ "cactorCoeff < 0" | cactorCoeff < 0 ]+     ++ [ "citemNum < 0" | citemNum < 0 ]  -- | Validate all cave kinds. -- Note that names don't have to be unique: we can have several variants -- of a cave with a given name. validateAllCaveKind :: [CaveKind] -> [Text] validateAllCaveKind lk =-  if any (maybe False (> 0) . lookup "campaign random" . cfreq) lk+  if any (maybe False (> 0) . lookup "default random" . cfreq) lk   then []-  else ["no cave defined for \"campaign random\""]+  else ["no cave defined for \"default random\""]

Game/LambdaHack/Content/ItemKind.hs view

@@ -1,23 +1,24 @@-{-# LANGUAGE DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable #-}+{-# LANGUAGE DeriveGeneric #-} -- | The type of kinds of weapons, treasure, organs, blasts and actors. module Game.LambdaHack.Content.ItemKind   ( ItemKind(..)   , Effect(..), TimerDice(..)   , Aspect(..), ThrowMod(..)   , Feature(..), EqpSlot(..)-  , slotName-  , toVelocity, toLinger, toOrganGameTurn, toOrganActorTurn, toOrganNone+  , forApplyEffect, forIdEffect+  , toDmg, toVelocity, toLinger, toOrganGameTurn, toOrganActorTurn, toOrganNone   , validateSingleItemKind, validateAllItemKind   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Control.DeepSeq import Data.Binary-import Data.Foldable (Foldable) import Data.Hashable (Hashable) import qualified Data.Set as S-import Data.Text (Text) import qualified Data.Text as T-import Data.Traversable (Traversable) import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU @@ -25,7 +26,6 @@ import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg  -- | Item properties that are fixed for a given kind of items. data ItemKind = ItemKind@@ -35,12 +35,11 @@   , iflavour :: ![Flavour]         -- ^ possible flavours   , icount   :: !Dice.Dice         -- ^ created in that quantity   , irarity  :: !Rarity            -- ^ rarity on given depths-  , iverbHit :: !MU.Part           -- ^ the verb for applying and melee+  , iverbHit :: !MU.Part           -- ^ the verb&noun for applying and hit   , iweight  :: !Int               -- ^ weight in grams-  , iaspects :: ![Aspect Dice.Dice]-                                   -- ^ keep the aspect continuously-  , ieffects :: ![Effect]-                                   -- ^ cause the effect when triggered+  , idamage  :: ![(Int, Dice.Dice)]  -- ^ frequency of basic impact damage+  , iaspects :: ![Aspect]          -- ^ keep the aspect continuously+  , ieffects :: ![Effect]          -- ^ cause the effect when triggered   , ifeature :: ![Feature]         -- ^ public properties   , idesc    :: !Text              -- ^ description   , ikit     :: ![(GroupName ItemKind, CStore)]@@ -48,58 +47,83 @@   }   deriving Show  -- No Eq and Ord to make extending it logically sound --- 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. Constructors are sorted vs increasing impact/danger. data Effect =     -- Ordinary effects.-    NoEffect !Text-  | Hurt !Dice.Dice-  | Burn !Dice.Dice  -- TODO: generalize to other elements? ignite terrain?+    ELabel !Text        -- ^ secret (learned as effect) label of the item+  | EqpSlot !EqpSlot    -- ^ AI and UI flag that leaks item properties+  | Burn !Dice.Dice   | Explode !(GroupName ItemKind)-                          -- ^ explode, producing this group of blasts+      -- ^ explode, producing this group of blasts   | RefillHP !Int-  | OverfillHP !Int   | RefillCalm !Int-  | OverfillCalm !Int   | Dominate   | Impress-  | CallFriend !Dice.Dice-  | Summon !(Freqs ItemKind) !Dice.Dice-  | Ascend !Int-  | Escape !Int           -- ^ the Int says if can be placed on last level, etc.-  | Paralyze !Dice.Dice-  | InsertMove !Dice.Dice+  | Summon !(GroupName ItemKind) !Dice.Dice+  | Ascend !Bool+  | Escape+  | Paralyze !Dice.Dice  -- ^ expressed in game clips+  | InsertMove !Dice.Dice  -- ^ expressed in game turns   | Teleport !Dice.Dice   | CreateItem !CStore !(GroupName ItemKind) !TimerDice-                          -- ^ create an item of the group and insert into-                          --   the store with the given random timer-  | DropItem !CStore !(GroupName ItemKind) !Bool-                          -- ^ @DropItem CGround x True@ means stomp on items+      -- ^ create an item of the group and insert into the store with the given+      --   random timer+  | DropItem !Int !Int !CStore !(GroupName ItemKind)   | PolyItem   | Identify+  | Detect !Int+  | DetectActor !Int+  | DetectItem !Int+  | DetectExit !Int+  | DetectHidden !Int   | SendFlying !ThrowMod   | PushActor !ThrowMod   | PullActor !ThrowMod   | DropBestWeapon-  | ActivateInv !Char     -- ^ symbol @' '@ means all+  | ActivateInv !Char   -- ^ symbol @' '@ means all   | ApplyPerfume     -- Exotic effects follow.   | OneOf ![Effect]-  | OnSmash !Effect       -- ^ trigger if item smashed (not applied nor meleed)-  | Recharging !Effect    -- ^ this effect inactive until timeout passes-  | Temporary !Text       -- ^ the item is temporary, vanishes at even void-                          --   Periodic activation, unless Durable-  deriving (Show, Read, Eq, Ord, Generic)+  | OnSmash !Effect     -- ^ trigger if item smashed (not applied nor meleed)+  | Recharging !Effect  -- ^ this effect inactive until timeout passes+  | Temporary !Text+      -- ^ the item is temporary, vanishes at even void Periodic activation,+      --   unless Durable and not Fragile, and shows message with+      --   this verb at last copy activation or at each activation+      --   unless Durable and Fragile+  | Unique              -- ^ at most one copy can ever be generated+  | Periodic            -- ^ in eqp, triggered as often as @Timeout@ permits+  deriving (Show, Eq, Ord, Generic)  instance NFData Effect +forApplyEffect :: Effect -> Bool+forApplyEffect eff = case eff of+  ELabel{} -> False+  EqpSlot{} -> False+  OnSmash{} -> False+  Temporary{} -> False+  Unique -> False+  Periodic -> False+  _ -> True++forIdEffect :: Effect -> Bool+forIdEffect eff = case eff of+  ELabel{} -> False+  EqpSlot{} -> False+  OnSmash{} -> False+  Explode{} -> False  -- tentative; needed for rings to auto-identify+  Unique -> False+  Periodic -> False+  _ -> True+ data TimerDice =     TimerNone   | TimerGameTurn !Dice.Dice   | TimerActorTurn !Dice.Dice-  deriving (Read, Eq, Ord, Generic)+  deriving (Eq, Ord, Generic)  instance Show TimerDice where   show TimerNone = "0"@@ -112,68 +136,83 @@  -- | Aspects of items. Those that are named @Add*@ are additive -- (starting at 0) for all items wielded by an actor and they affect the actor.-data Aspect a =-    Unique             -- ^ at most one copy can ever be generated-  | Periodic           -- ^ in equipment, apply as often as @Timeout@ permits-  | Timeout !a         -- ^ some effects will be disabled until item recharges-  | AddHurtMelee !a    -- ^ percentage damage bonus in melee-  | AddHurtRanged !a   -- ^ percentage damage bonus in ranged-  | AddArmorMelee !a   -- ^ percentage armor bonus against melee-  | AddArmorRanged !a  -- ^ percentage armor bonus against ranged-  | AddMaxHP !a        -- ^ maximal hp-  | AddMaxCalm !a      -- ^ maximal calm-  | 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, Foldable, Traversable)+data Aspect =+    Timeout !Dice.Dice         -- ^ some effects disabled until item recharges;+                               --   expressed in game turns+  | AddHurtMelee !Dice.Dice    -- ^ percentage damage bonus in melee+  | AddArmorMelee !Dice.Dice   -- ^ percentage armor bonus against melee+  | AddArmorRanged !Dice.Dice  -- ^ percentage armor bonus against ranged+  | AddMaxHP !Dice.Dice        -- ^ maximal hp+  | AddMaxCalm !Dice.Dice      -- ^ maximal calm+  | AddSpeed !Dice.Dice        -- ^ speed in m/10s (not of a projectile!)+  | AddSight !Dice.Dice        -- ^ FOV radius, where 1 means a single tile+  | AddSmell !Dice.Dice        -- ^ smell radius, where 1 means a single tile+  | AddShine !Dice.Dice        -- ^ shine radius, where 1 means a single tile+  | AddNocto !Dice.Dice        -- ^ noctovision radius, where 1 is single tile+  | AddAggression !Dice.Dice   -- ^ aggression, especially closing in for melee+  | AddAbility !Ability.Ability !Dice.Dice  -- ^ bonus to an ability+  deriving (Show, Eq, Ord, Generic) --- | Parameters modifying a throw. Not additive and don't start at 0.+-- | Parameters modifying a throw of a projectile or flight of pushed actor.+-- 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)+  deriving (Show, Eq, Ord, Generic)  instance NFData ThrowMod  -- | Features of item. Affect only the item in question, not the actor, -- and so not additive in any sense. data Feature =-    Fragile                 -- ^ drop and break at target tile, even if no hit-  | Durable                 -- ^ don't break even when 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                -- ^ can't throw or apply if not calm enough;-                            --   AI and UI flag: don't risk identifying by use-  | Tactic !Tactic          -- ^ overrides actor's tactic (TODO)+    Fragile            -- ^ drop and break at target tile, even if no hit+  | Lobable            -- ^ drop at target tile, even if no hit+  | Durable            -- ^ don't break even when hitting or applying+  | ToThrow !ThrowMod  -- ^ parameters modifying a throw+  | Identified         -- ^ the item starts identified+  | Applicable         -- ^ AI and UI flag: consider applying+  | Equipable          -- ^ AI and UI flag: consider equipping (independent of+                       -- ^ 'EqpSlot', e.g., in case of mixed blessings)+  | Meleeable          -- ^ AI and UI flag: consider meleeing with+  | Precious           -- ^ AI and UI flag: don't risk identifying by use+                       --   also, can't throw or apply if not calm enough;+  | Tactic !Tactic     -- ^ overrides actor's tactic   deriving (Show, Eq, Ord, Generic)  data EqpSlot =-    EqpSlotPeriodic-  | EqpSlotTimeout+    EqpSlotMiscBonus   | EqpSlotAddHurtMelee   | EqpSlotAddArmorMelee-  | EqpSlotAddHurtRanged   | EqpSlotAddArmorRanged   | EqpSlotAddMaxHP-  | EqpSlotAddMaxCalm   | EqpSlotAddSpeed-  | EqpSlotAddSkills Ability.Ability   | EqpSlotAddSight+  | EqpSlotLightSource+  | EqpSlotWeapon+  | EqpSlotMiscAbility+  | EqpSlotAbMove+  | EqpSlotAbMelee+  | EqpSlotAbDisplace+  | EqpSlotAbAlter+  | EqpSlotAbProject+  | EqpSlotAbApply+  -- Do not use in content:+  | EqpSlotAddMaxCalm   | EqpSlotAddSmell-  | EqpSlotAddLight-  | EqpSlotWeapon  -- ^ a hack exclusively for AI that shares weapons-  deriving (Show, Eq, Ord, Generic)+  | EqpSlotAddNocto+  | EqpSlotAddAggression+  | EqpSlotAbWait+  | EqpSlotAbMoveItem+  deriving (Show, Eq, Ord, Enum, Bounded, Generic) +instance NFData EqpSlot+ instance Hashable Effect  instance Hashable TimerDice -instance Hashable a => Hashable (Aspect a)+instance Hashable Aspect  instance Hashable ThrowMod @@ -185,7 +224,7 @@  instance Binary TimerDice -instance Binary a => Binary (Aspect a)+instance Binary Aspect  instance Binary ThrowMod @@ -193,21 +232,8 @@  instance Binary EqpSlot -slotName :: EqpSlot -> Text-slotName EqpSlotPeriodic = "periodicity"-slotName EqpSlotTimeout = "timeout"-slotName EqpSlotAddHurtMelee = "to melee damage"-slotName EqpSlotAddArmorMelee = "melee armor"-slotName EqpSlotAddHurtRanged = "to ranged damage"-slotName EqpSlotAddArmorRanged = "ranged armor"-slotName EqpSlotAddMaxHP = "max HP"-slotName EqpSlotAddMaxCalm = "max Calm"-slotName EqpSlotAddSpeed = "speed"-slotName EqpSlotAddSkills{} = "skills"-slotName EqpSlotAddSight = "sight radius"-slotName EqpSlotAddSmell = "smell radius"-slotName EqpSlotAddLight = "light radius"-slotName EqpSlotWeapon = "weapon damage"+toDmg :: Dice.Dice -> [(Int, Dice.Dice)]+toDmg dmg = [(1, dmg)]  toVelocity :: Int -> Feature toVelocity n = ToThrow $ ThrowMod n 100@@ -226,27 +252,65 @@  -- | Catch invalid item kind definitions. validateSingleItemKind :: ItemKind -> [Text]-validateSingleItemKind ItemKind{..} =+validateSingleItemKind ik@ItemKind{..} =   [ "iname longer than 23" | T.length iname > 23 ]+  ++ [ "icount < 0" | icount < 0 ]   ++ validateRarity irarity-  -- Reject duplicate Timeout and Periodic. Otherwise the behaviour-  -- may not agree with the item's in-game description.-  ++ let periodicAspect :: Aspect a -> Bool-         periodicAspect Periodic = True-         periodicAspect _ = False-         ps = filter periodicAspect iaspects-     in ["more than one Periodic specification" | length ps > 1]-  ++ let timeoutAspect :: Aspect a -> Bool-         timeoutAspect Timeout{} = True-         timeoutAspect _ = False-         ts = filter timeoutAspect iaspects-     in ["more than one Timeout specification" | length ts > 1]+  -- Reject duplicate Timeout, because it's not additive.+  ++ (let timeoutAspect :: Aspect -> Bool+          timeoutAspect Timeout{} = True+          timeoutAspect _ = False+          ts = filter timeoutAspect iaspects+      in ["more than one Timeout specification" | length ts > 1])+  ++ (let f :: Effect -> Bool+          f ELabel{} = True+          f _ = False+          ts = filter f ieffects+      in ["more than one ELabel specification" | length ts > 1])+  ++ (let f :: Effect -> Bool+          f EqpSlot{} = True+          f _ = False+          ts = filter f ieffects+      in ["more than one EqpSlot specification" | length ts > 1]+         ++ [ "EqpSlot specified but not Equipable nor Meleeable"+            | length ts > 0 && Equipable `notElem` ifeature+                            && Meleeable `notElem` ifeature ])+  ++ ["Reduntand Equipable or Meleeable" | Equipable `elem` ifeature+                                           && Meleeable `elem` ifeature]+  ++ (let f :: Effect -> Bool+          f Temporary{} = True+          f _ = False+          ts = filter f ieffects+      in ["more than one Temporary specification" | length ts > 1])+  ++ (let f :: Effect -> Bool+          f Unique = True+          f _ = False+          ts = filter f ieffects+      in ["more than one Unique specification" | length ts > 1])+  ++ (let f :: Effect -> Bool+          f Periodic = True+          f _ = False+          ts = filter f ieffects+      in ["more than one Periodic specification" | length ts > 1])+  ++ (let f :: Feature -> Bool+          f ToThrow{} = True+          f _ = False+          ts = filter f ifeature+      in ["more than one ToThrow specification" | length ts > 1])+  ++ (let f :: Feature -> Bool+          f Tactic{} = True+          f _ = False+          ts = filter f ifeature+      in ["more than one Tactic specification" | length ts > 1])+  ++ concatMap (validateDups ik)+       [ Fragile, Lobable, Durable, Identified, Applicable+       , Equipable, Meleeable, Precious ] --- TODO: if "treasure" stays wired-in, assure there are some treasure items--- TODO: (spans multiple contents) check that there is at least one item--- in each ifreq group for each level (thought more precisely we'd need--- to lookup caves and modes and only check at the levels the caves--- can appear at).+validateDups :: ItemKind -> Feature -> [Text]+validateDups ItemKind{..} feat =+  let ts = filter (== feat) ifeature+  in ["more than one" <+> tshow feat <+> "specification" | length ts > 1]+ -- | Validate all item kinds. validateAllItemKind :: [ItemKind] -> [Text] validateAllItemKind content =@@ -265,4 +329,15 @@         _ -> ["no groups" <+> tshow missingGroups               <+> "among content that has groups"               <+> tshow (S.elems kindFreq)]+      hardwiredAbsent = filter (`S.notMember` kindFreq) hardwiredItemGroups   in errorMsg+     ++ [ "Hardwired groups not in content:" <+> tshow hardwiredAbsent+        | not $ null hardwiredAbsent ]++hardwiredItemGroups :: [GroupName ItemKind]+hardwiredItemGroups =+  -- From Preferences.hs:+  [ "temporary condition", "treasure", "useful", "any scroll", "any vial"+  , "potion", "flask" ]+  -- Assorted:+  ++ ["bonus HP", "currency", "impressed", "mobile"]

Game/LambdaHack/Content/ModeKind.hs view

@@ -6,24 +6,26 @@   , validateSingleModeKind, validateAllModeKind   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.IntMap.Strict as IM-import Data.Text (Text)+import qualified Data.Set as S import qualified Data.Text as T import GHC.Generics (Generic)-import qualified NLP.Miniutter.English as MU ()  import Game.LambdaHack.Common.Ability import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg import Game.LambdaHack.Content.CaveKind import Game.LambdaHack.Content.ItemKind (ItemKind)  -- | Game mode specification. data ModeKind = ModeKind-  { msymbol :: !Char    -- ^ a symbol (matches the keypress, if any)+  { msymbol :: !Char    -- ^ a symbol   , mname   :: !Text    -- ^ short description   , mfreq   :: !(Freqs ModeKind)  -- ^ frequency within groups   , mroster :: !Roster  -- ^ players taking part in the game@@ -35,13 +37,15 @@ -- | Requested cave groups for particular levels. The second component -- is the @Escape@ feature on the level. @True@ means it's represented -- by @<@, @False@, by @>@.-type Caves = IM.IntMap (GroupName CaveKind, Maybe Bool)+type Caves = IM.IntMap (GroupName CaveKind)  -- | The specification of players for the game mode. data Roster = Roster-  { rosterList  :: ![Player Dice.Dice]  -- ^ players in the particular team-  , rosterEnemy :: ![(Text, Text)]      -- ^ the initial enmity matrix-  , rosterAlly  :: ![(Text, Text)]      -- ^ the initial aliance matrix+  { rosterList  :: ![(Player, [(Int, Dice.Dice, GroupName ItemKind)])]+      -- ^ players in the particular team and levels, numbers and groups+      --   of their initial members+  , rosterEnemy :: ![(Text, Text)]  -- ^ the initial enmity matrix+  , rosterAlly  :: ![(Text, Text)]  -- ^ the initial aliance matrix   }   deriving (Show, Eq) @@ -70,28 +74,28 @@ type HiCondPoly = [HiSummand]  -- | Properties of a particular player.-data Player a = Player-  { fname          :: !Text        -- ^ name of the player-  , fgroup         :: !(GroupName ItemKind)  -- ^ name of the monster group to control-  , fskillsOther   :: !Skills      -- ^ fixed skill modifiers to the non-leader-                                   --   actors; also summed with skills implied-                                   --   by ftactic (which is not fixed)-  , fcanEscape     :: !Bool        -- ^ the player can escape the dungeon-  , fneverEmpty    :: !Bool        -- ^ the faction declared killed if no actors-  , fhiCondPoly    :: !HiCondPoly  -- ^ score polynomial for the player-  , fhasNumbers    :: !Bool        -- ^ whether actors have numbers, not symbols-  , fhasGender     :: !Bool        -- ^ whether actors have gender-  , ftactic        :: !Tactic      -- ^ non-leader behave according to this-                                   --   tactic; can be changed during the game-  , fentryLevel    :: !a           -- ^ level where the initial members start-  , finitialActors :: !a           -- ^ number of initial members-  , fleaderMode    :: !LeaderMode  -- ^ the mode of switching the leader-  , fhasUI         :: !Bool        -- ^ does the faction have a UI client-                                   --   (for control or passive observation)+data Player = Player+  { fname        :: !Text        -- ^ name of the player+  , fgroups      :: ![GroupName ItemKind]+                                 -- ^ names of actor groups that may naturally+                                 --   fall under player's control, e.g., upon+                                 --   spawning or summoning+  , fskillsOther :: !Skills      -- ^ fixed skill modifiers to the non-leader+                                 --   actors; also summed with skills implied+                                 --   by ftactic (which is not fixed)+  , fcanEscape   :: !Bool        -- ^ the player can escape the dungeon+  , fneverEmpty  :: !Bool        -- ^ the faction declared killed if no actors+  , fhiCondPoly  :: !HiCondPoly  -- ^ score polynomial for the player+  , fhasGender   :: !Bool        -- ^ whether actors have gender+  , ftactic      :: !Tactic      -- ^ non-leaders behave according to this+                                 --   tactic; can be changed during the game+  , fleaderMode  :: !LeaderMode  -- ^ the mode of switching the leader+  , fhasUI       :: !Bool        -- ^ does the faction have a UI client+                                 --   (for control or passive observation)   }   deriving (Show, Eq, Ord, Generic) -instance Binary a => Binary (Player a)+instance Binary Player  -- | If a faction with @LeaderUI@ and @LeaderAI@ has any actor, it has a leader. data LeaderMode =@@ -113,58 +117,69 @@       --   and no other actor of the faction resides on his level,       --   but the client (particularly UI) is expected to do changes as well   , autoLevel   :: !Bool-      -- ^ leader switching within a level is automatically done by the server-      --   and client is not permitted to change leaders-      --   (server is guaranteed to switch leader within a level very rarely,-      --   e.g., when the old leader dies);+      -- ^ client is discouraged from leader switching (e.g., because+      --   non-leader actors have the same skills as leader);+      --   server is guaranteed to switch leader within a level very rarely,+      --   e.g., when the old leader dies;       --   if the flag is @False@, server still does a subset-      --   of the automatic switching, but the client is permitted to do more+      --   of the automatic switching, but the client is expected to do more,+      --   because it's advantageous for that kind of a faction   }   deriving (Show, Eq, Ord, Generic)  instance Binary AutoLeader --- TODO: (spans multiple contents) Check that caves with the given groups exist. -- | Catch invalid game mode kind definitions. validateSingleModeKind :: ModeKind -> [Text] validateSingleModeKind ModeKind{..} =   [ "mname longer than 20" | T.length mname > 20 ]   ++ validateSingleRoster mcaves mroster --- TODO: if the diplomacy system stays in, check no teams are at once--- in war and alliance, taking into account symmetry (but not transitvity) -- | Checks, in particular, that there is at least one faction with fneverEmpty--- or the game could get stuck when the dungeon is devoid of actors+-- or the game would get stuck as soon as the dungeon is devoid of actors. validateSingleRoster :: Caves -> Roster -> [Text] validateSingleRoster caves Roster{..} =-  [ "no player keeps the dungeon alive" | all (not . fneverEmpty) rosterList ]-  ++ concatMap (validateSinglePlayer caves) rosterList+  [ "no player keeps the dungeon alive"+  | all (not . fneverEmpty . fst) rosterList ]+  ++ concatMap (validateSinglePlayer . fst) rosterList   ++ let checkPl field pl =            [ pl <+> "is not a player name in" <+> field-           | all ((/= pl) . fname) rosterList ]+           | all ((/= pl) . fname . fst) rosterList ]          checkDipl field (pl1, pl2) =            [ "self-diplomacy in" <+> field | pl1 == pl2 ]            ++ checkPl field pl1            ++ checkPl field pl2      in concatMap (checkDipl "rosterEnemy") rosterEnemy         ++ concatMap (checkDipl "rosterAlly") rosterAlly+  ++ let f (_, l) = concatMap g l+         g i3@(ln, _, _) =+           if ln `elem` IM.keys caves+           then []+           else ["initial actor levels not among caves:" <+> tshow i3]+     in concatMap f rosterList -validateSinglePlayer :: Caves -> Player Dice.Dice -> [Text]-validateSinglePlayer caves Player{..} =+validateSinglePlayer :: Player -> [Text]+validateSinglePlayer  Player{..} =   [ "fname empty:" <+> fname | T.null fname ]-  ++ [ "first word of fname longer than 15:" <+> fname-     | T.length (head $ T.words fname) > 15 ]   ++ [ "no UI client, but UI leader:" <+> fname      | not fhasUI && case fleaderMode of                        LeaderUI _ -> True                        _ -> False ]-  ++ [ "fentryLevel value not among cave numbers:" <+> fname-     | any (`notElem` IM.keys caves)-           [Dice.minDice fentryLevel-            .. Dice.maxDice fentryLevel] ]  -- simplification   ++ [ "fskillsOther not negative:" <+> fname      | any (>= 0) $ EM.elems fskillsOther ] --- | Validate all game mode kinds. Currently always valid.+-- | Validate game mode kinds together. validateAllModeKind :: [ModeKind] -> [Text]-validateAllModeKind _ = []+validateAllModeKind content =+  let kindFreq :: S.Set (GroupName ModeKind)  -- cf. Kind.kindFreq+      kindFreq = let tuples = [ cgroup+                              | k <- content+                              , (cgroup, n) <- mfreq k+                              , n > 0 ]+                 in S.fromList tuples+      hardwiredAbsent = filter (`S.notMember` kindFreq) hardwiredModeGroups+  in [ "Hardwired groups not in content:" <+> tshow hardwiredAbsent+     | not $ null hardwiredAbsent ]++hardwiredModeGroups :: [GroupName ModeKind]+hardwiredModeGroups = [ "campaign scenario", "starting", "starting JS" ]

Game/LambdaHack/Content/PlaceKind.hs view

@@ -4,7 +4,10 @@   , validateSinglePlaceKind, validateAllPlaceKind   ) where -import Data.Text (Text)+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import qualified Data.Text as T  import Game.LambdaHack.Common.Misc@@ -23,13 +26,15 @@   }   deriving Show  -- No Eq and Ord to make extending it logically sound --- | A method of filling the whole area (except for CVerbatim, which is just--- placed in the middle of the area) by transforming a given corner.+-- | A method of filling the whole area (except for CVerbatim and CMirror,+-- which are just placed in the middle of the area) by transforming+-- a given corner. data Cover =     CAlternate  -- ^ reflect every other corner, overlapping 1 row and column   | CStretch    -- ^ fill symmetrically 4 corners and stretch their borders   | CReflect    -- ^ tile separately and symmetrically quarters of the place   | CVerbatim   -- ^ just build the given interior, without filling the area+  | CMirror     -- ^ build the given interior in one of 4 mirrored variants   deriving (Show, Eq)  -- | The choice of a fence type for the place.@@ -40,12 +45,6 @@   | FNone   -- ^ skip the fence and fill all with the place proper   deriving (Show, Eq) --- TODO: Verify that places are fully accessible from any entrace on the fence--- that is at least 4 tiles distant from the edges, if the place is big enough,--- (unless the place has FNone fence, in which case the entrance is--- at the outer tiles of the place).--- TODO: (spans multiple contents) Check that all symbols in place plans--- are present in the legend. -- | Catch invalid place kind definitions. In particular, verify that -- the top-left corner map is rectangular and not empty. validateSinglePlaceKind :: PlaceKind -> [Text]

Game/LambdaHack/Content/RuleKind.hs view

@@ -1,20 +1,16 @@ -- | The type of game rule sets and assorted game data. module Game.LambdaHack.Content.RuleKind-  ( RuleKind(..), FovMode(..), validateSingleRuleKind, validateAllRuleKind+  ( RuleKind(..), validateSingleRuleKind, validateAllRuleKind   ) where -import Data.Binary-import Data.Text (Text)+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Data.Version  import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Point --- TODO: very few rules are configurable yet, extend as needed.--- TODO: in the future, in @raccessible@ check flying for chasms,--- swimming for water, etc.--- TODO: tweak other code to allow games with only cardinal direction moves- -- | The type of game rule sets and assorted game data. -- -- For now the rules are immutable througout the game, so there is@@ -24,44 +20,23 @@ -- based on data mining of player behaviour, we may add such a type -- and then @RuleKind@ will become just a starting template, analogously -- as for the other content.------ The @raccessible@ field holds extra conditions that have to be met--- for a tile to be accessible, on top of being an open tile--- (or openable, in some contexts). The @raccessibleDoor@ field--- contains yet additional conditions concerning tiles that are doors,--- whether open or closed.--- Precondition: the two positions are next to each other.--- We assume the predicate is symmetric. data RuleKind = RuleKind   { rsymbol         :: !Char      -- ^ a symbol   , rname           :: !Text      -- ^ short description   , rfreq           :: !(Freqs RuleKind)  -- ^ frequency within groups-  , raccessible     :: !(Maybe (Point -> Point -> Bool))  -- ^ see above-  , raccessibleDoor :: !(Maybe (Point -> Point -> Bool))  -- ^ see above-  , rtitle          :: !Text      -- ^ the title of the game-  , rpathsDataFile  :: FilePath -> IO FilePath-                                  -- ^ the path to data files-  , rpathsVersion   :: !Version   -- ^ the version of the game-  , rcfgUIName      :: !FilePath  -- ^ base name of the UI config file+  , rtitle          :: !Text      -- ^ title of the game (not lib)+  , rexeVersion     :: !Version   -- ^ version of the game+  , rcfgUIName      :: !FilePath  -- ^ name of the UI config file   , rcfgUIDefault   :: !String    -- ^ the default UI settings config file   , rmainMenuArt    :: !Text      -- ^ the ASCII art for the Main Menu   , rfirstDeathEnds :: !Bool      -- ^ whether first non-spawner actor death                                   --   ends the game-  , rfovMode        :: !FovMode   -- ^ FOV calculation mode   , rwriteSaveClips :: !Int       -- ^ game is saved that often   , rleadLevelClips :: !Int       -- ^ server switches leader level that often   , rscoresFile     :: !FilePath  -- ^ name of the scores file-  , rsavePrefix     :: !String    -- ^ name of the savefile prefix   , rnearby         :: !Int       -- ^ what distance between actors is 'nearby'   } --- | Field Of View scanning mode.-data FovMode =-    Shadow      -- ^ restrictive shadow casting (not symmetric!)-  | Permissive  -- ^ permissive FOV-  | Digital     -- ^ digital FOV-  deriving (Show, Read)- -- | A dummy instance of the 'Show' class, to satisfy general requirments -- about content. We won't have many rule sets and they contain functions, -- so defining a proper instance is not practical.@@ -69,22 +44,9 @@   show _ = "The game ruleset specification."  -- | Catch invalid rule kind definitions.--- In particular, this validates the ASCII art format (TODO). validateSingleRuleKind :: RuleKind -> [Text] validateSingleRuleKind _ = []  -- | Since we have only one rule kind, the set of rule kinds is always valid. validateAllRuleKind :: [RuleKind] -> [Text] validateAllRuleKind _ = []--instance Binary FovMode where-  put Shadow      = putWord8 0-  put Permissive  = putWord8 1-  put Digital     = putWord8 2-  get = do-    tag <- getWord8-    case tag of-      0 -> return Shadow-      1 -> return Permissive-      2 -> return Digital-      _ -> fail "no parse (FovMode)"

Game/LambdaHack/Content/TileKind.hs view

@@ -3,23 +3,29 @@ module Game.LambdaHack.Content.TileKind   ( TileKind(..), Feature(..)   , validateSingleTileKind, validateAllTileKind, actionFeatures+  , TileSpeedup(..), Tab(..), isUknownSpace, unknownId+  , isSuspectKind, isOpenableKind, isClosableKind, talterForStairs, floorSymbol   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Control.DeepSeq-import Control.Exception.Assert.Sugar import Data.Binary+import qualified Data.Char as Char import Data.Hashable import qualified Data.IntSet as IS import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Text (Text)+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Vector.Unboxed as U import GHC.Generics (Generic)  import Game.LambdaHack.Common.Color+import qualified Game.LambdaHack.Common.KindOps as KindOps import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg import Game.LambdaHack.Content.ItemKind (ItemKind)-import qualified Game.LambdaHack.Content.ItemKind as IK  -- | The type of kinds of terrain tiles. See @Tile.hs@ for explanation -- of the absence of a corresponding type @Tile@ that would hold@@ -27,40 +33,60 @@ -- Note that tile names (and any other content names) should not be plural -- (that would lead to "a stairs"), so "road with cobblestones" is fine, -- but "granite cobblestones" is wrong.+--+-- Tile kind for unknown space has the minimal @KindOps.Id@ index.+-- The @talter@ for unknown space is @1@ and no other tile kind has that value. data TileKind = TileKind   { tsymbol  :: !Char         -- ^ map symbol   , tname    :: !Text         -- ^ short description   , tfreq    :: !(Freqs TileKind)  -- ^ frequency within groups   , tcolor   :: !Color        -- ^ map color   , tcolor2  :: !Color        -- ^ map color when not in FOV-  , tfeature :: ![Feature]  -- ^ properties+  , talter   :: !Word8        -- ^ minimal skill needed to alter the tile+  , tfeature :: ![Feature]    -- ^ properties   }   deriving Show  -- No Eq and Ord to make extending it logically sound  -- | All possible terrain tile features. data Feature =-    Embed !(GroupName ItemKind)  -- ^ embed an item of this group, to cause effects (WIP)-  | Cause !IK.Effect             -- ^ causes the effect when triggered;-                                 --   more succint than @Embed@, but will-                                 --   probably get supplanted by @Embed@-  | OpenTo !(GroupName TileKind)    -- ^ goes from a closed to an open tile when altered-  | CloseTo !(GroupName TileKind)   -- ^ goes from an open to a closed tile when altered-  | ChangeTo !(GroupName TileKind)  -- ^ alters tile, but does not change walkability-  | HideAs !(GroupName TileKind)    -- ^ when hidden, looks as a tile of the group-  | RevealAs !(GroupName TileKind)  -- ^ if secret, can be revealed to belong to the group+    Embed !(GroupName ItemKind)+      -- ^ initially an item of this group is embedded;+      --   we assume the item has effects and is supposed to be triggered+  | OpenTo !(GroupName TileKind)+      -- ^ goes from a closed to (randomly closed or) open tile when altered+  | CloseTo !(GroupName TileKind)+      -- ^ goes from an open to (randomly opened or) closed tile when altered+  | ChangeTo !(GroupName TileKind)+      -- ^ alters tile, but does not change walkability+  | HideAs !(GroupName TileKind)+      -- ^ when hidden, looks as the unique tile of the group +  -- The following three are only used in dungeon generation.+  | BuildAs !(GroupName TileKind)+      -- ^ when generating, may be transformed to the unique tile of the group+  | RevealAs !(GroupName TileKind)+      -- ^ when generating in opening, can be revealed to belong to the group+  | ObscureAs !(GroupName TileKind)+      -- ^ when generating in solid wall, 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)-  | Impenetrable         -- ^ can never be excavated nor seen through+  | Dark                 -- ^ is not lit with an ambient light    | OftenItem            -- ^ initial items often generated there-  | OftenActor           -- ^ initial actors and stairs often generated there+  | OftenActor           -- ^ initial actors often generated there   | NoItem               -- ^ no items ever generated there-  | NoActor              -- ^ no actors nor stairs ever generated there+  | NoActor              -- ^ no actors ever generated there+  | Indistinct           -- ^ is allowed to have the same look as another tile+  | ConsideredByAI       -- ^ even if otherwise uninteresting, taken into+                         --   account for triggering by AI   | Trail                -- ^ used for visible trails throughout the level-  deriving (Show, Read, Eq, Ord, Generic)+  | Spice                -- ^ in place normal legend and in override,+                         --   don't roll a tile kind only once per place,+                         --   but roll for each position; one non-spicy and+                         --   at most one spicy is rolled per place and then+                         --   one of the two is rolled for each position+  deriving (Show, Eq, Ord, Generic)  instance Binary Feature @@ -68,67 +94,192 @@  instance NFData Feature --- TODO: (spans multiple contents) check that all posible solid place--- fences have hidden counterparts.+data TileSpeedup = TileSpeedup+  { isClearTab        :: !(Tab Bool)+  , isLitTab          :: !(Tab Bool)+  , isWalkableTab     :: !(Tab Bool)+  , isDoorTab         :: !(Tab Bool)+  , isChangableTab    :: !(Tab Bool)+  , isSuspectTab      :: !(Tab Bool)+  , isHideAsTab       :: !(Tab Bool)+  , consideredByAITab :: !(Tab Bool)+  , isOftenItemTab    :: !(Tab Bool)+  , isOftenActorTab   :: !(Tab Bool)+  , isNoItemTab       :: !(Tab Bool)+  , isNoActorTab      :: !(Tab Bool)+  , isEasyOpenTab     :: !(Tab Bool)+  , alterMinSkillTab  :: !(Tab Word8)+  , alterMinWalkTab   :: !(Tab Word8)+  }++-- Vectors of booleans can be slower than arrays, because they are not packed,+-- but with growing cache sizes they may as well turn out faster at some point.+-- The advantage of vectors are exposed internals, in particular unsafe+-- indexing. Also, in JS bool arrays are obviously not packed.+newtype Tab a = Tab (U.Vector a)  -- morally indexed by @Id a@++isUknownSpace :: KindOps.Id TileKind -> Bool+{-# INLINE isUknownSpace #-}+isUknownSpace tt = KindOps.Id 0 == tt++unknownId :: KindOps.Id TileKind+{-# INLINE unknownId #-}+unknownId = KindOps.Id 0+ -- | Validate a single tile kind. validateSingleTileKind :: TileKind -> [Text]-validateSingleTileKind TileKind{..} =+validateSingleTileKind t@TileKind{..} =   [ "suspect tile is walkable" | Walkable `elem` tfeature-                                 && Suspect `elem` tfeature ]+                                 && isSuspectKind t ]+  ++ [ "openable tile is open" | Walkable `elem` tfeature+                                 && isOpenableKind t ]+  ++ [ "closable tile is closed" | Walkable `notElem` tfeature+                                   && isClosableKind t ]+  ++ [ "walkable tile is considered for triggering by AI"+     | Walkable `elem` tfeature+       && ConsideredByAI `elem` tfeature ]+  ++ [ "trail tile not walkable" | Walkable `notElem` tfeature+                                   && Trail `elem` tfeature ]+  ++ [ "OftenItem and NoItem on a tile" | OftenItem `elem` tfeature+                                          && NoItem `elem` tfeature ]+  ++ [ "OftenActor and NoActor on a tile" | OftenItem `elem` tfeature+                                            && NoItem `elem` tfeature ]+  ++ (let f :: Feature -> Bool+          f OpenTo{} = True+          f CloseTo{} = True+          f ChangeTo{} = True+          f _ = False+          ts = filter f tfeature+      in [ "more than one OpenTo, CloseTo and ChangeTo specification"+         | length ts > 1 ])+  ++ (let f :: Feature -> Bool+          f HideAs{} = True+          f _ = False+          ts = filter f tfeature+      in ["more than one HideAs specification" | length ts > 1])+  ++ (let f :: Feature -> Bool+          f BuildAs{} = True+          f _ = False+          ts = filter f tfeature+      in ["more than one BuildAs specification" | length ts > 1])+  ++ concatMap (validateDups t)+       [ Walkable, Clear, Dark, OftenItem, OftenActor, NoItem, NoActor+       , Indistinct, ConsideredByAI, Trail, Spice ] --- TODO: verify that OpenTo, CloseTo and ChangeTo are assigned as specified.+validateDups :: TileKind -> Feature -> [Text]+validateDups TileKind{..} feat =+  let ts = filter (== feat) tfeature+  in ["more than one" <+> tshow feat <+> "specification" | length ts > 1]++isSuspectKind :: TileKind -> Bool+isSuspectKind t =+  let getTo RevealAs{} = True+      getTo ObscureAs{} = True+      getTo _ = False+  in any getTo $ tfeature t++isOpenableKind ::TileKind -> Bool+isOpenableKind t =+  let getTo OpenTo{} = True+      getTo _ = False+  in any getTo $ tfeature t++isClosableKind :: TileKind -> Bool+isClosableKind t =+  let getTo CloseTo{} = True+      getTo _ = False+  in any getTo $ tfeature t+ -- | Validate all tile kinds. ----- If tiles look the same on the map, the description and the substantial+-- If tiles look the same on the map (symbol and color), their substantial -- features should be the same, too. Otherwise, the player has to inspect -- manually all the tiles of that kind, or even experiment with them,--- to see if any is special. This would be tedious. Note that iiles may freely--- differ wrt dungeon generation, AI preferences, etc.+-- to see if any is special. This would be tedious. Note that tiles may freely+-- differ wrt text blurb, dungeon generation, AI preferences, etc. validateAllTileKind :: [TileKind] -> [Text] validateAllTileKind lt =-  let listVis f = map (\kt -> ( ( tsymbol kt-                                  , Suspect `elem` tfeature kt-                                  , f kt-                                  )-                                , [kt] ) ) lt-      mapVis :: (TileKind -> Color) -> M.Map (Char, Bool, Color) [TileKind]+  let kindFreq :: S.Set (GroupName TileKind)  -- cf. Kind.kindFreq+      kindFreq = let tuples = [ cgroup+                              | k <- lt+                              , (cgroup, n) <- tfreq k+                              , n > 0 ]+                 in S.fromList tuples+      listVis f = map (\kt -> ( (tsymbol kt, f kt)+                              , [(kt, actionFeatures True kt)] )) lt+      mapVis :: (TileKind -> Color)+             -> M.Map (Char, Color) [(TileKind, IS.IntSet)]       mapVis f = M.fromListWith (++) $ listVis f-      namesUnequal [] = assert `failure` "no TileKind content" `twith` lt-      namesUnequal (hd : tl) =-        -- Catch if at least one is different.-        any (/= tname hd) (map tname tl)-        -- TODO: calculate actionFeatures only once for each tile kind-        || any (/= actionFeatures True hd) (map (actionFeatures True) tl)-      confusions f = filter namesUnequal $ M.elems $ mapVis f-  in case confusions tcolor ++ confusions tcolor2 of-    [] -> []-    cfs -> ["tile confusions detected:" <+> tshow cfs]+      isConfused [] =  assert `failure` lt+      isConfused [_] = False+      isConfused (hd : tl) =+        any ((Indistinct `notElem`) . tfeature . fst) (hd : tl)+        && any ((/= snd hd) . snd) tl+      confusions f = filter isConfused $ M.elems $ mapVis f+      hardwiredAbsent = filter (`S.notMember` kindFreq) hardwiredTileGroups+  in [ "first tile should be the unknown one"+     | talter (head lt) /= 1 || tname (head lt) /= "unknown space" ]+     ++ [ "only unknown tile may have talter 1"+        | any ((== 1) . talter) $ tail lt ]+     ++ case confusions tcolor ++ confusions tcolor2 of+       [] -> []+       cfs -> ["tile confusions detected:" <+> tshow cfs]+     ++ [ "Hardwired groups not in content:" <+> tshow hardwiredAbsent+        | not $ null hardwiredAbsent ] +hardwiredTileGroups :: [GroupName TileKind]+hardwiredTileGroups =+  [ "unknown space", "legendLit", "legendDark", "basic outer fence"+  , "stair terminal" ]+ -- | Features of tiles that differentiate them substantially from one another.--- By tile content validation condition, this means the player--- can tell such tile apart, and only looking at the map, not tile name.+-- The intention is the player can easily tell such tiles apart by their+-- behaviour and only looking at the map, not tile name nor description. -- So if running uses this function, it won't stop at places that the player -- can't himself tell from other places, and so running does not confer -- any advantages, except UI convenience. Hashes are accurate enough -- for our purpose, given that we use arbitrary heuristics anyway. actionFeatures :: Bool -> TileKind -> IS.IntSet actionFeatures markSuspect t =-  let f feat = case feat of+  let stripLight grp = maybe grp toGroupName+                       $ maybe (T.stripSuffix "Dark" $ tshow grp) Just+                       $ T.stripSuffix "Lit" $ tshow grp+      f feat = case feat of         Embed{} -> Just feat-        Cause{} -> Just feat-        OpenTo{} -> Just $ OpenTo ""  -- if needed, remove prefix/suffix-        CloseTo{} -> Just $ CloseTo ""-        ChangeTo{} -> Just $ ChangeTo ""+        OpenTo grp -> Just $ OpenTo $ stripLight grp+        CloseTo grp -> Just $ CloseTo $ stripLight grp+        ChangeTo grp -> Just $ ChangeTo $ stripLight grp         Walkable -> Just feat         Clear -> Just feat-        Suspect -> if markSuspect then Just feat else Nothing-        Impenetrable -> Just feat-        Trail -> Just feat  -- doesn't affect tile behaviour, but important         HideAs{} -> Nothing-        RevealAs{} -> Nothing+        BuildAs{} -> Nothing+        RevealAs{} -> if markSuspect then Just feat else Nothing+        ObscureAs{} -> if markSuspect then Just feat else Nothing         Dark -> Nothing  -- not important any longer, after FOV computed         OftenItem -> Nothing         OftenActor -> Nothing         NoItem -> Nothing         NoActor -> Nothing+        Indistinct -> Nothing+        ConsideredByAI -> Nothing+        Trail -> Just feat  -- doesn't affect tile behaviour, but important+        Spice -> Nothing   in IS.fromList $ map hash $ mapMaybe f $ tfeature t++talterForStairs :: Word8+talterForStairs = 3++floorSymbol :: Char.Char+floorSymbol = Char.chr 183++-- Alter skill schema:+-- 0  can be altered by everybody (escape)+-- 1  unknown only+-- 2  openable and suspect+-- 3  stairs+-- 4  closable+-- 5  changeable (e.g., caches)+-- 10  weak obstructions+-- 50  considerable obstructions+-- 100  walls+-- maxBound  impenetrable walls, etc., can never be altered

Game/LambdaHack/SampleImplementation/SampleMonadClient.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE CPP, FlexibleInstances, GeneralizedNewtypeDeriving,-             MultiParamTypeClasses #-}+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} -- | The main game action monad type implementation. Just as any other -- component of the library, this implementation can be substituted. -- This module should not be imported anywhere except in 'Action'@@ -8,97 +7,143 @@   ( executorCli #ifdef EXPOSE_INTERNAL     -- * Internal operations-  , CliImplementation+  , CliState(..), CliImplementation(..) #endif   ) where -import Control.Applicative-import Control.Concurrent.STM+import Prelude ()++import Game.LambdaHack.Common.Prelude++import Control.Concurrent import qualified Control.Monad.IO.Class as IO import Control.Monad.Trans.State.Strict hiding (State)-import Data.Maybe+import GHC.Generics (Generic) import System.FilePath -import Game.LambdaHack.Atomic.HandleAtomicWrite-import Game.LambdaHack.Atomic.MonadAtomic-import Game.LambdaHack.Atomic.MonadStateWrite+import Game.LambdaHack.Atomic+import Game.LambdaHack.Client.HandleResponseM import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.ProtocolClient import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.MonadClientUI+import Game.LambdaHack.Client.UI import Game.LambdaHack.Common.ClientOptions+import Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Response import qualified Game.LambdaHack.Common.Save as Save import Game.LambdaHack.Common.State-import Game.LambdaHack.Server.ProtocolServer -data CliState resp req = CliState-  { cliState   :: !State        -- ^ current global state-  , cliClient  :: !StateClient  -- ^ current client state-  , cliDict    :: !(ChanServer resp req)-                                -- ^ this client connection information-  , cliToSave  :: !(Save.ChanSave (State, StateClient))-                                -- ^ connection to the save thread-  , cliSession :: SessionUI     -- ^ UI setup data, empty for AI clients+data CliState = CliState+  { cliState   :: !State              -- ^ current global state+  , cliClient  :: !StateClient        -- ^ current client state+  , cliSession :: !(Maybe SessionUI)  -- ^ UI state, empty for AI clients+  , cliDict    :: !ChanServer         -- ^ this client connection information+  , cliToSave  :: !(Save.ChanSave (State, StateClient, Maybe SessionUI))+                                      -- ^ connection to the save thread   }+  deriving Generic  -- | Client state transformation monad.-newtype CliImplementation resp req a =-    CliImplementation {runCliImplementation :: StateT (CliState resp req) IO a}+newtype CliImplementation a = CliImplementation+  { runCliImplementation :: StateT CliState IO a }   deriving (Monad, Functor, Applicative) -instance MonadStateRead (CliImplementation resp req) where-  getState    = CliImplementation $ gets cliState+instance MonadStateRead CliImplementation where+  {-# INLINE getsState #-}   getsState f = CliImplementation $ gets $ f . cliState -instance MonadStateWrite (CliImplementation resp req) where+instance MonadStateWrite CliImplementation where+  {-# INLINE modifyState #-}   modifyState f = CliImplementation $ state $ \cliS ->-    let newCliS = cliS {cliState = f $ cliState cliS}-    in newCliS `seq` ((), newCliS)-  putState    s = CliImplementation $ state $ \cliS ->-    let newCliS = cliS {cliState = s}-    in newCliS `seq` ((), newCliS)+    let !newCliState = f $ cliState cliS+    in ((), cliS {cliState = newCliState}) -instance MonadClient (CliImplementation resp req) where-  getClient      = CliImplementation $ gets cliClient+instance MonadClient CliImplementation where+  {-# INLINE getsClient #-}   getsClient   f = CliImplementation $ gets $ f . cliClient+  {-# INLINE modifyClient #-}   modifyClient f = CliImplementation $ state $ \cliS ->-    let newCliS = cliS {cliClient = f $ cliClient cliS}-    in newCliS `seq` ((), newCliS)-  putClient    s = CliImplementation $ state $ \cliS ->-    let newCliS = cliS {cliClient = s}-    in newCliS `seq` ((), newCliS)-  liftIO         = CliImplementation . IO.liftIO-  saveChanClient = CliImplementation $ gets cliToSave+    let !newCliState = f $ cliClient cliS+    in ((), cliS {cliClient = newCliState})+  liftIO = CliImplementation . IO.liftIO -instance MonadClientUI (CliImplementation resp req) where-  getsSession f  = CliImplementation $ gets $ f . cliSession-  liftIO         = CliImplementation . IO.liftIO+instance MonadClientSetup CliImplementation where+  saveClient = CliImplementation $ do+    toSave <- gets cliToSave+    s <- gets cliState+    cli <- gets cliClient+    msess <- gets cliSession+    IO.liftIO $ Save.saveToChan toSave (s, cli, msess)+  restartClient  = CliImplementation $ state $ \cliS ->+    case cliSession cliS of+      Just sess ->+        let !newSess = (emptySessionUI (sconfig sess))+                         { schanF = schanF sess+                         , sbinding = sbinding sess+                         , shistory = shistory sess+                         , _sreport = _sreport sess+                         , sstart = sstart sess+                         , sgstart = sgstart sess+                         , sallTime = sallTime sess+                         , snframes = snframes sess+                         , sallNframes = sallNframes sess+                         }+        in ((), cliS {cliSession = Just newSess})+      Nothing -> ((), cliS) -instance MonadClientReadResponse resp (CliImplementation resp req) where-  receiveResponse     = CliImplementation $ do+instance MonadClientUI CliImplementation where+  {-# INLINE getsSession #-}+  getsSession   f = CliImplementation $ gets $ f . fromJust . cliSession+  {-# INLINE modifySession #-}+  modifySession f = CliImplementation $ state $ \cliS ->+    let !newCliSession = f $ fromJust $ cliSession cliS+    in ((), cliS {cliSession = Just newCliSession})+  liftIO = CliImplementation . IO.liftIO++instance MonadClientReadResponse CliImplementation where+  receiveResponse = CliImplementation $ do     ChanServer{responseS} <- gets cliDict-    IO.liftIO $ atomically . readTQueue $ responseS+    IO.liftIO $ takeMVar responseS -instance MonadClientWriteRequest req (CliImplementation resp req) where-  sendRequest scmd = CliImplementation $ do-    ChanServer{requestS} <- gets cliDict-    IO.liftIO $ atomically . writeTQueue requestS $ scmd+instance MonadClientWriteRequest CliImplementation where+  sendRequestAI scmd = CliImplementation $ do+    ChanServer{requestAIS} <- gets cliDict+    IO.liftIO $ putMVar requestAIS scmd+  sendRequestUI scmd = CliImplementation $ do+    ChanServer{requestUIS} <- gets cliDict+    IO.liftIO $ putMVar (fromJust requestUIS) scmd+  clientHasUI = CliImplementation $ do+    mSession <- gets cliSession+    return $! isJust mSession  -- | The game-state semantics of atomic commands -- as computed on the client.-instance MonadAtomic (CliImplementation resp req) where-  execAtomic = handleCmdAtomic+instance MonadAtomic CliImplementation where+  {-# INLINE execUpdAtomic #-}+  execUpdAtomic = handleUpdAtomic+  {-# INLINE execSfxAtomic #-}+  execSfxAtomic _sfx = return ()+  {-# INLINE execSendPer #-}+  execSendPer _ _ _ _ _ = return ()  -- | Init the client, then run an action, with a given session, -- state and history, in the @IO@ monad.-executorCli :: CliImplementation resp req ()-            -> SessionUI -> State -> StateClient -> ChanServer resp req+executorCli :: CliImplementation ()+            -> Maybe SessionUI+            -> Kind.COps+            -> FactionId+            -> ChanServer             -> IO ()-executorCli m cliSession cliState cliClient cliDict =-  let saveFile (_, cli2) =-        fromMaybe "save" (ssavePrefixCli (sdebugCli cli2))-        <.> saveName (sside cli2) (sisAI cli2)-      exe cliToSave =-        evalStateT (runCliImplementation m) CliState{..}-  in Save.wrapInSaves saveFile exe+executorCli m cliSession cops fid cliDict =+  let stateToFileName (_, cli, _) =+        ssavePrefixCli (sdebugCli cli) <.> Save.saveNameCli (sside cli)+      totalState cliToSave = CliState+        { cliState = emptyState cops+        , cliClient = emptyStateClient fid+        , cliDict+        , cliToSave+        , cliSession+        }+      exe = evalStateT (runCliImplementation m) . totalState+  in Save.wrapInSaves cops stateToFileName exe

Game/LambdaHack/SampleImplementation/SampleMonadServer.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | The main game action monad type implementation. Just as any other -- component of the library, this implementation can be substituted. -- This module should not be imported anywhere except in 'Action'@@ -7,30 +7,41 @@   ( executorSer #ifdef EXPOSE_INTERNAL     -- * Internal operations-  , SerImplementation+  , SerState(..), SerImplementation(..) #endif   ) where -import Control.Applicative+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Control.Concurrent import qualified Control.Exception as Ex import qualified Control.Monad.IO.Class as IO import Control.Monad.Trans.State.Strict hiding (State) import qualified Data.EnumMap.Strict as EM-import Data.Maybe+import qualified Data.Text.IO as T import System.FilePath+import System.IO (hFlush, stdout) -import Game.LambdaHack.Atomic.BroadcastAtomicWrite-import Game.LambdaHack.Atomic.CmdAtomic-import Game.LambdaHack.Atomic.MonadAtomic-import Game.LambdaHack.Atomic.MonadStateWrite+import Game.LambdaHack.Atomic+import Game.LambdaHack.Client+import Game.LambdaHack.Client.UI.Config+import Game.LambdaHack.Client.UI.Content.KeyKind+import Game.LambdaHack.Common.ClientOptions+import Game.LambdaHack.Common.File+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import qualified Game.LambdaHack.Common.Save as Save import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Thread-import Game.LambdaHack.Server.CommonServer+import Game.LambdaHack.SampleImplementation.SampleMonadClient (executorCli)+import Game.LambdaHack.Server+import Game.LambdaHack.Server.BroadcastAtomic+import Game.LambdaHack.Server.HandleAtomicM import Game.LambdaHack.Server.MonadServer-import Game.LambdaHack.Server.ProtocolServer+import Game.LambdaHack.Server.ProtocolM import Game.LambdaHack.Server.State  data SerState = SerState@@ -47,73 +58,94 @@   deriving (Monad, Functor, Applicative)  instance MonadStateRead SerImplementation where-  getState    = SerImplementation $ gets serState+  {-# INLINE getsState #-}   getsState f = SerImplementation $ gets $ f . serState  instance MonadStateWrite SerImplementation where+  {-# INLINE modifyState #-}   modifyState f = SerImplementation $ state $ \serS ->-    let newSerS = serS {serState = f $ serState serS}-    in newSerS `seq` ((), newSerS)-  putState    s = SerImplementation $ state $ \serS ->-    let newSerS = serS {serState = s}-    in newSerS `seq` ((), newSerS)+    let !newSerState = f $ serState serS+    in ((), serS {serState = newSerState})  instance MonadServer SerImplementation where-  getServer      = SerImplementation $ gets serServer+  {-# INLINE getsServer #-}   getsServer   f = SerImplementation $ gets $ f . serServer+  {-# INLINE modifyServer #-}   modifyServer f = SerImplementation $ state $ \serS ->-    let newSerS = serS {serServer = f $ serServer serS}-    in newSerS `seq` ((), newSerS)-  putServer    s = SerImplementation $ state $ \serS ->-    let newSerS = serS {serServer = s}-    in newSerS `seq` ((), newSerS)-  liftIO         = SerImplementation . IO.liftIO+    let !newSerServer = f $ serServer serS+    in ((), serS {serServer = newSerServer})   saveChanServer = SerImplementation $ gets serToSave+  liftIO         = SerImplementation . IO.liftIO  instance MonadServerReadRequest SerImplementation where-  getDict      = SerImplementation $ gets serDict+  {-# INLINE getsDict #-}   getsDict   f = SerImplementation $ gets $ f . serDict-  modifyDict f =-    SerImplementation $ modify $ \serS -> serS {serDict = f $ serDict serS}-  putDict    s =-    SerImplementation $ modify $ \serS -> serS {serDict = s}-  liftIO       = SerImplementation . IO.liftIO+  {-# INLINE modifyDict #-}+  modifyDict f = SerImplementation $ state $ \serS ->+    let !newSerDict = f $ serDict serS+    in ((), serS {serDict = newSerDict})+  liftIO = SerImplementation . IO.liftIO  -- | The game-state semantics of atomic commands -- as computed on the server. instance MonadAtomic SerImplementation where-  execAtomic = handleAndBroadcastServer---- | Send an atomic action to all clients that can see it.-handleAndBroadcastServer :: (MonadStateWrite m, MonadServerReadRequest m)-                         => CmdAtomic -> m ()-handleAndBroadcastServer atomic = do-  persOld <- getsServer sper-  knowEvents <- getsServer $ sknowEvents . sdebugSer-  handleAndBroadcast knowEvents persOld resetFidPerception resetLitInDungeon-                     sendUpdateAI sendUpdateUI atomic+  execUpdAtomic cmd = cmdAtomicSemSer cmd >> handleAndBroadcast (UpdAtomic cmd)+  execSfxAtomic sfx = handleAndBroadcast (SfxAtomic sfx)+  execSendPer = sendPer +-- Don't inline this, to keep GHC hard work inside the library+-- for easy access of code analysis tools. -- | Run an action in the @IO@ monad, with undefined state.-executorSer :: SerImplementation () -> IO ()-executorSer m = do-  let saveFile (_, ser) =-        fromMaybe "save" (ssavePrefixSer (sdebugSer ser))-        <.> saveName-      exe serToSave =-        evalStateT (runSerImplementation m)-          SerState { serState = emptyState-                   , serServer = emptyStateServer-                   , serDict = EM.empty-                   , serToSave-                   }-      exeWithSaves = Save.wrapInSaves saveFile exe+executorSer :: Kind.COps -> KeyKind -> DebugModeSer -> IO ()+executorSer cops copsClient sdebugNxtCmdline = do+  -- Parse UI client configuration file.+  -- It is reparsed at each start of the game executable.+  sconfig <- mkConfig cops (sbenchmark $ sdebugCli sdebugNxtCmdline)+  sdebugNxt <- case configCmdline sconfig of+    [] -> return sdebugNxtCmdline+    args -> return $! debugArgs args+  -- Options for the clients modified with the configuration file.+  -- The client debug inside server debug only holds the client commandline+  -- options and is never updated with config options, etc.+  let sdebugMode = applyConfigToDebug cops sconfig $ sdebugCli sdebugNxt+      -- Partially applied main loop of the clients.+      executorClient = executorCli (loopCli copsClient sconfig sdebugMode)+  -- Wire together game content, the main loop of game clients+  -- and the game server loop.+  let m = loopSer sdebugNxt sconfig executorClient+      stateToFileName (_, ser) =+        ssavePrefixSer (sdebugSer ser) <.> Save.saveNameSer+      totalState serToSave = SerState+        { serState = emptyState cops+        , serServer = emptyStateServer+        , serDict = EM.empty+        , serToSave+        }+      exe = evalStateT (runSerImplementation m) . totalState+      exeWithSaves = Save.wrapInSaves cops stateToFileName exe+      defPrefix = ssavePrefixSer defDebugModeSer+      bkpOneSave name = do+        dataDir <- appDataDir+        let path bkp = dataDir </> "saves" </> bkp <> name+        b <- doesFileExist (path "")+        when b $ renameFile (path "") (path "bkp.")+      bkpAllSaves = do+        T.hPutStrLn stdout "The game crashed, so savefiles are moved aside."+        bkpOneSave $ defPrefix <.> Save.saveNameSer+        forM_ [-99..99] $ \n ->+          bkpOneSave $ defPrefix <.> Save.saveNameCli (toEnum n)   -- Wait for clients to exit even in case of server crash   -- (or server and client crash), which gives them time to save   -- and report their own inconsistencies, if any.-  -- TODO: send them a message to tell users "server crashed"-  -- and then wait for them to exit normally.   Ex.handle (\(ex :: Ex.SomeException) -> do-               threadDelay 1000000  -- let clients report their errors+               Ex.uninterruptibleMask_ $ threadDelay 1000000+                 -- let clients report their errors and save+               when (ssavePrefixSer sdebugNxt == defPrefix) bkpAllSaves+               hFlush stdout                Ex.throw ex)  -- crash eventually, which kills clients             exeWithSaves+--  T.hPutStrLn stdout "Server exiting, waiting for clients."+--  hFlush stdout   waitForChildren childrenServer  -- no crash, wait for clients indefinitely+--  T.hPutStrLn stdout "Server exiting now."+--  hFlush stdout

Game/LambdaHack/Server.hs view

@@ -3,17 +3,16 @@ -- See -- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>. module Game.LambdaHack.Server-  ( -- * Re-exported from "Game.LambdaHack.Server.LoopServer"+  ( -- * Re-exported from "Game.LambdaHack.Server.LoopM"     loopSer-    -- * Re-exported from "Game.LambdaHack.Server.MonadServer"-  , speedupCOps     -- * Re-exported from "Game.LambdaHack.Server.Commandline"   , debugArgs     -- * Re-exported from "Game.LambdaHack.Server.State"-  , sdebugCli+  , DebugModeSer(..)   ) where -import Game.LambdaHack.Server.Commandline-import Game.LambdaHack.Server.LoopServer-import Game.LambdaHack.Server.MonadServer-import Game.LambdaHack.Server.State+import Prelude ()++import Game.LambdaHack.Server.Commandline (debugArgs)+import Game.LambdaHack.Server.LoopM (loopSer)+import Game.LambdaHack.Server.State (DebugModeSer (..))

+ Game/LambdaHack/Server/BroadcastAtomic.hs view

@@ -0,0 +1,206 @@+-- | Sending atomic commands to clients and executing them on the server.+-- See+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.+module Game.LambdaHack.Server.BroadcastAtomic+  ( handleAndBroadcast, sendPer+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , handleCmdAtomicServer, atomicRemember+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import Data.Key (mapWithKeyM_)++import Game.LambdaHack.Atomic+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Perception+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Server.ItemM+import Game.LambdaHack.Server.MonadServer+import Game.LambdaHack.Server.ProtocolM+import Game.LambdaHack.Server.State++--storeUndo :: MonadServer m => CmdAtomic -> m ()+--storeUndo _atomic =+--  maybe skip (\a -> modifyServer $ \ser -> ser {sundo = a : sundo ser})+--    $ Nothing   -- undoCmdAtomic atomic++handleCmdAtomicServer :: MonadStateWrite m => PosAtomic -> UpdAtomic -> m ()+{-# INLINE handleCmdAtomicServer #-}+handleCmdAtomicServer posAtomic cmd =+  when (seenAtomicSer posAtomic) $+-- Not implemented ATM:+--    storeUndo atomic+    handleUpdAtomic cmd++-- | Send an atomic action to all clients that can see it.+handleAndBroadcast :: (MonadStateWrite m, MonadServerReadRequest m)+                   => CmdAtomic -> m ()+handleAndBroadcast atomic = do+  -- This is calculated in the server State before action (simulating+  -- current client State, because action has not been applied+  -- on the client yet).+  -- E.g., actor's position in @breakUpdAtomic@ is assumed to be pre-action.+  -- To get rid of breakUpdAtomic we'd need to send only Spot and Lose+  -- commands instead of Move and Displace (plus Sfx for Displace).+  -- So this only makes sense when we switch to sending state diffs.+  (ps, atomicBroken, psBroken) <-+    case atomic of+      UpdAtomic cmd -> do+        ps <- posUpdAtomic cmd+        atomicBroken <- breakUpdAtomic cmd+        psBroken <- mapM posUpdAtomic atomicBroken+        -- Perform the action on the server. The only part that requires+        -- @MonadStateWrite@ and modifies server State.+        handleCmdAtomicServer ps cmd+        return (ps, atomicBroken, psBroken)+      SfxAtomic sfx -> do+        ps <- posSfxAtomic sfx+        return (ps, [], [])+  knowEvents <- getsServer $ sknowEvents . sdebugSer+  sperFidOld <- getsServer sperFid+  -- Send some actions to the clients, one faction at a time.+  let sendAtomic fid (UpdAtomic cmd) = sendUpdate fid cmd+      sendAtomic fid (SfxAtomic sfx) = sendSfx fid sfx+      breakSend lid fid fact perFidLid = do+        -- We take the new leader, from after cmd execution.+        let hear atomic2 = do+              local <- case _gleader fact of+                Nothing -> return True  -- give leaderless factions some love+                Just leader -> do+                  body <- getsState $ getActorBody leader+                  return $! (blid body == lid)+              loud <- case atomic2 of+                UpdAtomic cmd -> loudUpdAtomic local cmd+                SfxAtomic cmd -> loudSfxAtomic local cmd+              case loud of+                Nothing -> return ()+                Just msg -> sendSfx fid $ SfxMsgFid fid msg+            send2 (cmd2, ps2) =+              when (seenAtomicCli knowEvents fid perFidLid ps2) $+                sendUpdate fid cmd2+        case psBroken of+          _ : _ -> mapM_ send2 $ zip atomicBroken psBroken+          [] -> hear atomic  -- broken commands are never loud+      -- We assume players perceive perception change before the action,+      -- so the action is perceived in the new perception,+      -- even though the new perception depends on the action's outcome+      -- (e.g., new actor created).+      anySend lid fid fact perFidLid =+        if seenAtomicCli knowEvents fid perFidLid ps+        then sendAtomic fid atomic+        else breakSend lid fid fact perFidLid+      posLevel lid fid fact =+        anySend lid fid fact $ sperFidOld EM.! fid EM.! lid+      send fid fact = case ps of+        PosSight lid _ -> posLevel lid fid fact+        PosFidAndSight _ lid _ -> posLevel lid fid fact+        PosFidAndSer (Just lid) _ -> posLevel lid fid fact+        PosSmell lid _ -> posLevel lid fid fact+        PosFid fid2 -> when (fid == fid2) $ sendAtomic fid atomic+        PosFidAndSer Nothing fid2 ->+          when (fid == fid2) $ sendAtomic fid atomic+        PosSer -> return ()+        PosAll -> sendAtomic fid atomic+        PosNone -> assert `failure` (fid, fact, atomic)+  -- Factions that are eliminated by the command are processed as well,+  -- because they are not deleted from @sfactionD@.+  factionD <- getsState sfactionD+  mapWithKeyM_ send factionD++-- | Messages for some unseen atomic commands.+loudUpdAtomic :: MonadStateRead m => Bool -> UpdAtomic -> m (Maybe SfxMsg)+loudUpdAtomic local cmd = do+  Kind.COps{coTileSpeedup} <- getsState scops+  mcmd <- case cmd of+    UpdDestroyActor _ body _ | not $ bproj body -> return $ Just cmd+    UpdCreateItem _ _ _ (CActor _ CGround) -> return $ Just cmd+    UpdTrajectory _ (Just (l, _)) Nothing | not (null l) && local ->+      -- Projectile hits an non-walkable tile on leader's level.+      return $ Just cmd+    UpdAlterTile _ _ fromTile _ -> return $!+      if Tile.isDoor coTileSpeedup fromTile+      then if local then Just cmd else Nothing+      else Just cmd+    UpdAlterClear{} -> return $ Just cmd+    _ -> return Nothing+  return $! SfxLoudUpd local <$> mcmd++-- | Messages for some unseen sfx.+loudSfxAtomic :: MonadServer m => Bool -> SfxAtomic -> m (Maybe SfxMsg)+loudSfxAtomic local cmd =+  case cmd of+    SfxStrike source _ iid cstore | local -> do+      itemToF <- itemToFullServer+      sb <- getsState $ getActorBody source+      bag <- getsState $ getBodyStoreBag sb cstore+      let kit = EM.findWithDefault (1, []) iid bag+          itemFull = itemToF iid kit+          ik = itemKindId $ fromJust $ itemDisco itemFull+          distance = 20  -- TODO: distance to leader; also, add a skill+      return $ Just $ SfxLoudStrike local ik distance+    _ -> return Nothing++sendPer :: MonadServerReadRequest m+        => FactionId -> LevelId+        -> Perception -> Perception -> Perception -> m ()+{-# INLINE sendPer #-}+sendPer fid lid outPer inPer perNew = do+  sendUpdate fid $ UpdPerception lid outPer inPer+  remember <- getsState $ atomicRemember lid inPer+  let seenNew = seenAtomicCli False fid perNew+  psRem <- mapM posUpdAtomic remember+  -- Verify that we remember only currently seen things.+  let !_A = assert (allB seenNew psRem) ()+  mapM_ (sendUpdate fid) remember++atomicRemember :: LevelId -> Perception -> State -> [UpdAtomic]+{-# INLINE atomicRemember #-}+atomicRemember lid inPer s =+  -- No @UpdLoseItem@ is sent for items that became out of sight.+  -- The client will create these atomic actions based on @outPer@,+  -- if required. Any client that remembers out of sight items, OTOH,+  -- will create atomic actions that forget remembered items+  -- that are revealed not to be there any more (no @UpdSpotItem@ for them).+  -- Similarly no @UpdLoseActor@, @UpdLoseTile@ nor @UpdLoseSmell@.+  let inFov = ES.elems $ totalVisible inPer+      lvl = sdungeon s EM.! lid+      -- Actors.+      inAssocs = concatMap (\p -> posToAssocs p lid s) inFov+      fActor (aid, b) = let ais = getCarriedAssocs b s+                        in UpdSpotActor aid b ais+      inActor = map fActor inAssocs+      -- Items.+      pMaybe p = maybe Nothing (\x -> Just (p, x))+      inContainer fc itemFloor =+        let inItem = mapMaybe (\p -> pMaybe p $ EM.lookup p itemFloor) inFov+            fItem p (iid, kit) =+              UpdSpotItem True iid (getItemBody iid s) kit (fc lid p)+            fBag (p, bag) = map (fItem p) $ EM.assocs bag+        in concatMap fBag inItem+      inFloor = inContainer CFloor (lfloor lvl)+      inEmbed = inContainer CEmbed (lembed lvl)+      -- Tiles.+      Kind.COps{cotile} = scops s+      hideTile p = Tile.hideAs cotile $ lvl `at` p+      inTileMap = map (\p -> (p, hideTile p)) inFov+      atomicTile = if null inTileMap then [] else [UpdSpotTile lid inTileMap]+      -- Smells.+      inSmellFov = ES.elems $ totalSmelled inPer+      inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p (lsmell lvl)) inSmellFov+      atomicSmell = if null inSm then [] else [UpdSpotSmell lid inSm]+  in atomicTile ++ inFloor ++ inEmbed ++ atomicSmell ++ inActor

Game/LambdaHack/Server/Commandline.hs view

@@ -3,91 +3,135 @@   ( debugArgs   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import qualified Data.Text as T  import Game.LambdaHack.Common.ClientOptions+import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Misc import Game.LambdaHack.Server.State --- TODO: make more maintainable- -- | Parse server debug parameters from commandline arguments.-debugArgs :: [String] -> IO DebugModeSer-debugArgs args = do-  let usage =+debugArgs :: [String] -> DebugModeSer+debugArgs =+  let breakPar s = let (params, args) = break ("-" `isPrefixOf`) s+                   in (unwords params, args)+      usage =         [ "Configure debug options here, gameplay options in config.rules.ini."         , "  --knowMap  reveal map for all clients in the next game"         , "  --knowEvents  show all events in the next game (needs --knowMap)"+        , "  --knowItems  auto-identify all items in the next game (needs --knowEvents)"         , "  --sniffIn  display all incoming commands on console "         , "  --sniffOut  display all outgoing commands on console "         , "  --allClear  let all map tiles be translucent"+        , "  --boostRandomItem  pick a random item and make it very common"         , "  --gameMode m  start next game in the given mode"         , "  --automateAll  give control of all UI teams to computer"         , "  --keepAutomated  keep factions automated after game over"         , "  --newGame n  start a new game, overwriting the save file,"         , "               with difficulty for all UI players set to n"-        , "  --stopAfter n  exit this game session after around n seconds"-        , "  --benchmark  print stats, limit saving and other file operations"+        , "  --stopAfterSeconds n  exit game session after around n seconds"+        , "  --stopAfterFrames n  exit game session after around n frames"+        , "  --benchmark  restrict file IO, print stats"         , "  --setDungeonRng s  set dungeon generation RNG seed to string s"         , "  --setMainRng s  set the main game RNG seed to string s"         , "  --dumpInitRngs  dump RNG states from the start of the game"         , "  --dbgMsgSer  let the server emit its internal debug messages"-        , "  --font fn  use the given font for the main game window"-        , "  --noColorIsBold  don't use bold attribute for colorful characters"+        , "  --gtkFontFamily s  use the given font family for the main game window in GTK"+        , "  --sdlFontFile s  use the given font file for the main game window in SDL2"+        , "  --sdlTtfSizeAdd s  enlarge map cells over scalable font max height in SDL2"+        , "  --sdlFonSizeAdd s  enlarge map cells on top of .fon font max height in SDL2"+        , "  --fontSize s  use the given font size for the main game window"+        , "  --noColorIsBold  refrain from making some bright color characters bolder"         , "  --maxFps n  display at most n frames per second"-        , "  --noDelay  don't maintain any requested delays between frames"         , "  --disableAutoYes  never auto-answer all prompts"         , "  --noAnim  don't show any animations"         , "  --savePrefix  prepend the text to all savefile names"-        , "  --frontendStd  use the simple stdout/stdin frontend"-        , "  --frontendNull  use no frontend at all (for AIvsAI benchmarks)"+        , "  --frontendTeletype  use the line terminal frontend (for tests)"+        , "  --frontendNull  use frontend with no display (for benchmarks)"+        , "  --frontendLazy  use frontend that not even computes frames (for benchmarks)"         , "  --dbgMsgCli  let clients emit their internal debug messages"-        , "  --fovMode m  set a Field of View mode, where m can be"-        , "    Digital"-        , "    Permissive"-        , "    Shadow"         ]       parseArgs [] = defDebugModeSer       parseArgs ("--knowMap" : rest) =         (parseArgs rest) {sknowMap = True}       parseArgs ("--knowEvents" : rest) =         (parseArgs rest) {sknowEvents = True}+      parseArgs ("--knowItems" : rest) =+        (parseArgs rest) {sknowItems = True}       parseArgs ("--sniffIn" : rest) =         (parseArgs rest) {sniffIn = True}       parseArgs ("--sniffOut" : rest) =         (parseArgs rest) {sniffOut = True}       parseArgs ("--allClear" : rest) =         (parseArgs rest) {sallClear = True}-      parseArgs ("--gameMode" : s : rest) =-        (parseArgs rest) {sgameMode = Just $ toGroupName (T.pack s)}+      parseArgs ("--boostRandomItem" : rest) =+        (parseArgs rest) {sboostRandomItem = True}+      parseArgs ("--gameMode" : rest) =+        let (params, args) = breakPar rest+        in (parseArgs args) {sgameMode = Just $ toGroupName (T.pack params)}       parseArgs ("--automateAll" : rest) =         (parseArgs rest) {sautomateAll = True}       parseArgs ("--keepAutomated" : rest) =         (parseArgs rest) {skeepAutomated = True}-      parseArgs ("--newGame" : s : rest) =-        let debugSer = parseArgs rest-            scurDiffSer = read s-        in debugSer { scurDiffSer+      parseArgs ("--newGame" : rest) =+        let (params, args) = breakPar rest+            debugSer = parseArgs args+            cdiff = read params+        in debugSer { scurChalSer = (scurChalSer debugSer) {cdiff}                     , snewGameSer = True                     , sdebugCli = (sdebugCli debugSer) {snewGameCli = True}}-      parseArgs ("--stopAfter" : s : rest) =-        (parseArgs rest) {sstopAfter = Just $ read s}+      parseArgs ("--stopAfterSeconds" : rest) =+        let (params, args) = breakPar rest+            debugSer = parseArgs args+        in debugSer {sdebugCli =+             (sdebugCli debugSer) {sstopAfterSeconds = Just $ read params}}+      parseArgs ("--stopAfterFrames" : rest) =+        let (params, args) = breakPar rest+            debugSer = parseArgs args+        in debugSer {sdebugCli =+             (sdebugCli debugSer) {sstopAfterFrames = Just $ read params}}       parseArgs ("--benchmark" : rest) =         let debugSer = parseArgs rest         in debugSer {sdebugCli = (sdebugCli debugSer) {sbenchmark = True}}-      parseArgs ("--setDungeonRng" : s : rest) =-        (parseArgs rest) {sdungeonRng = Just $ read s}-      parseArgs ("--setMainRng" : s : rest) =-        (parseArgs rest) {smainRng = Just $ read s}+      parseArgs ("--setDungeonRng" : rest) =+        let (params, args) = breakPar rest+        in (parseArgs args) {sdungeonRng = Just $ read params}+      parseArgs ("--setMainRng" : rest) =+        let (params, args) = breakPar rest+        in (parseArgs args) {smainRng = Just $ read params}       parseArgs ("--dumpInitRngs" : rest) =         (parseArgs rest) {sdumpInitRngs = True}-      parseArgs ("--fovMode" : mode : rest) =-        (parseArgs rest) {sfovMode = Just $ read mode}       parseArgs ("--dbgMsgSer" : rest) =         (parseArgs rest) {sdbgMsgSer = True}-      parseArgs ("--font" : s : rest) =-        let debugSer = parseArgs rest-        in debugSer {sdebugCli = (sdebugCli debugSer) {sfont = Just s}}+      parseArgs ("--gtkFontFamily" : rest) =+        let (params, args) = breakPar rest+            debugSer = parseArgs args+        in debugSer {sdebugCli = (sdebugCli debugSer) {sgtkFontFamily =+                                                         Just $ T.pack params}}+      parseArgs ("--sdlFontFile" : rest) =+        let (params, args) = breakPar rest+            debugSer = parseArgs args+        in debugSer {sdebugCli = (sdebugCli debugSer) {sdlFontFile =+                                                         Just $ T.pack params}}+      parseArgs ("--sdlTtfSizeAdd" : rest) =+        let (params, args) = breakPar rest+            debugSer = parseArgs args+        in debugSer {sdebugCli = (sdebugCli debugSer) {sdlTtfSizeAdd =+                                                         Just $ read params}}+      parseArgs ("--sdlFonSizeAdd" : rest) =+        let (params, args) = breakPar rest+            debugSer = parseArgs args+        in debugSer {sdebugCli = (sdebugCli debugSer) {sdlFonSizeAdd =+                                                         Just $ read params}}+      parseArgs ("--fontSize" : rest) =+        let (params, args) = breakPar rest+            debugSer = parseArgs args+        in debugSer {sdebugCli = (sdebugCli debugSer) {sfontSize =+                                                         Just $ read params}}       parseArgs ("--noColorIsBold" : rest) =         let debugSer = parseArgs rest         in debugSer {sdebugCli =@@ -96,29 +140,31 @@         let debugSer = parseArgs rest         in debugSer {sdebugCli =                        (sdebugCli debugSer) {smaxFps = Just $ max 1 $ read n}}-      parseArgs ("--noDelay" : rest) =-        let debugSer = parseArgs rest-        in debugSer {sdebugCli = (sdebugCli debugSer) {snoDelay = True}}       parseArgs ("--disableAutoYes" : rest) =         let debugSer = parseArgs rest         in debugSer {sdebugCli = (sdebugCli debugSer) {sdisableAutoYes = True}}       parseArgs ("--noAnim" : rest) =         let debugSer = parseArgs rest         in debugSer {sdebugCli = (sdebugCli debugSer) {snoAnim = Just True}}-      parseArgs ("--savePrefix" : s : rest) =-        let debugSer = parseArgs rest-        in debugSer { ssavePrefixSer = Just s+      parseArgs ("--savePrefix" : rest) =+        let (params, args) = breakPar rest+            debugSer = parseArgs args+        in debugSer { ssavePrefixSer = params                     , sdebugCli =-                        (sdebugCli debugSer) {ssavePrefixCli = Just s}}-      parseArgs ("--frontendStd" : rest) =+                        (sdebugCli debugSer) {ssavePrefixCli = params}}+      parseArgs ("--frontendTeletype" : rest) =         let debugSer = parseArgs rest-        in debugSer {sdebugCli = (sdebugCli debugSer) {sfrontendStd = True}}+        in debugSer {sdebugCli = (sdebugCli debugSer)+                                    {sfrontendTeletype = True}}       parseArgs ("--frontendNull" : rest) =         let debugSer = parseArgs rest         in debugSer {sdebugCli = (sdebugCli debugSer) {sfrontendNull = True}}+      parseArgs ("--frontendLazy" : rest) =+        let debugSer = parseArgs rest+        in debugSer {sdebugCli = (sdebugCli debugSer) {sfrontendLazy = True}}       parseArgs ("--dbgMsgCli" : rest) =         let debugSer = parseArgs rest         in debugSer {sdebugCli = (sdebugCli debugSer) {sdbgMsgCli = True}}       parseArgs (wrong : _rest) =         error $ "Unrecognized: " ++ wrong ++ "\n" ++ unlines usage-  return $! parseArgs args+  in parseArgs

+ Game/LambdaHack/Server/CommonM.hs view

@@ -0,0 +1,488 @@+{-# LANGUAGE TupleSections #-}+-- | Server operations common to many modules.+module Game.LambdaHack.Server.CommonM+  ( execFailure, getPerFid+  , revealItems, moveStores, deduceQuits, deduceKilled+  , electLeader, supplantLeader+  , addActor, addActorIid, projectFail+  , pickWeaponServer, currentSkillsServer+  , recomputeCachePer+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.Text as T+import qualified Text.Show.Pretty as Show.Pretty++import Game.LambdaHack.Atomic+import qualified Game.LambdaHack.Common.Ability as Ability+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.ItemStrongest+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Perception+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Content.ItemKind as IK+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Server.Fov+import Game.LambdaHack.Server.ItemM+import Game.LambdaHack.Server.MonadServer+import Game.LambdaHack.Server.State++execFailure :: (MonadAtomic m, MonadServer m)+            => ActorId -> RequestTimed a -> ReqFailure -> m ()+execFailure aid req failureSer = do+  -- Clients should rarely do that (only in case of invisible actors)+  -- so we report it to the client, but do not crash+  -- (server should work OK with stupid clients, too).+  body <- getsState $ getActorBody aid+  let fid = bfid body+      msg = showReqFailure failureSer+      impossible = impossibleReqFailure failureSer+      debugShow :: Show a => a -> Text+      debugShow = T.pack . Show.Pretty.ppShow+      possiblyAlarm = if impossible+                      then debugPossiblyPrintAndExit+                      else debugPossiblyPrint+  possiblyAlarm $+    "execFailure:" <+> msg <> "\n"+    <> debugShow body <> "\n" <> debugShow req <> "\n" <> debugShow failureSer+  execSfxAtomic $ SfxMsgFid fid $ SfxUnexpected failureSer++getPerFid :: MonadServer m => FactionId -> LevelId -> m Perception+getPerFid fid lid = do+  pers <- getsServer sperFid+  let failFact = assert `failure` "no perception for faction" `twith` (lid, fid)+      fper = EM.findWithDefault failFact fid pers+      failLvl = assert `failure` "no perception for level" `twith` (lid, fid)+      per = EM.findWithDefault failLvl lid fper+  return $! per++revealItems :: (MonadAtomic m, MonadServer m) => Maybe FactionId -> m ()+revealItems mfid = do+  itemToF <- itemToFullServer+  let discover aid store iid k =+        let itemFull = itemToF iid k+            c = CActor aid store+        in case itemDisco itemFull of+          Just ItemDisco{itemKindId} -> do+            seed <- getsServer $ (EM.! iid) . sitemSeedD+            execUpdAtomic $ UpdDiscover c iid itemKindId seed+          _ -> assert `failure` (mfid, c, iid, itemFull)+      f aid = do+        b <- getsState $ getActorBody aid+        let ourSide = maybe True (== bfid b) mfid+        -- Don't ID projectiles, because client may not see them.+        when (not (bproj b) && ourSide) $+          -- CSha is IDed for each actor of each faction, which is OK,+          -- even though it may introduce a slight lag.+          -- AI clients being sent this is a bigger waste anyway.+          join $ getsState $ mapActorItems_ (discover aid) b+  as <- getsState $ EM.keys . sactorD+  mapM_ f as++moveStores :: (MonadAtomic m, MonadServer m)+           => Bool -> ActorId -> CStore -> CStore -> m ()+moveStores verbose aid fromStore toStore = do+  b <- getsState $ getActorBody aid+  let g iid (k, _) = do+        move <- generalMoveItem verbose iid k (CActor aid fromStore)+                                              (CActor aid toStore)+        mapM_ execUpdAtomic move+  mapActorCStore_ fromStore g b++quitF :: (MonadAtomic m, MonadServer m) =>  Status -> FactionId -> m ()+quitF status fid = do+  fact <- getsState $ (EM.! fid) . sfactionD+  let oldSt = gquit fact+  case stOutcome <$> oldSt of+    Just Killed -> return ()    -- Do not overwrite in case+    Just Defeated -> return ()  -- many things happen in 1 turn.+    Just Conquer -> return ()+    Just Escape -> return ()+    _ -> do+      when (fhasUI $ gplayer fact) $ do+        keepAutomated <- getsServer $ skeepAutomated . sdebugSer+        when (isAIFact fact+              && fleaderMode (gplayer fact) /= LeaderNull+              && not keepAutomated) $+          execUpdAtomic $ UpdAutoFaction fid False+        revealItems (Just fid)+        registerScore status fid+      execUpdAtomic $ UpdQuitFaction fid oldSt $ Just status+      modifyServer $ \ser -> ser {squit = True}  -- check game over ASAP++-- Send any UpdQuitFaction actions that can be deduced from factions'+-- current state.+deduceQuits :: (MonadAtomic m, MonadServer m) => FactionId -> Status -> m ()+deduceQuits fid0 status@Status{stOutcome}+  | stOutcome `elem` [Defeated, Camping, Restart, Conquer] =+    assert `failure` "no quitting to deduce" `twith` (fid0, status)+deduceQuits fid0 status = do+  fact0 <- getsState $ (EM.! fid0) . sfactionD+  let factHasUI = fhasUI . gplayer+      quitFaction (stOutcome, (fid, _)) = quitF status{stOutcome} fid+      mapQuitF outfids = do+        let (withUI, withoutUI) =+              partition (factHasUI . snd . snd)+                        ((stOutcome status, (fid0, fact0)) : outfids)+        mapM_ quitFaction (withoutUI ++ withUI)+      inGameOutcome (fid, fact) = do+        let mout | fid == fid0 = Just $ stOutcome status+                 | otherwise = stOutcome <$> gquit fact+        case mout of+          Just Killed -> False+          Just Defeated -> False+          Just Restart -> False  -- effectively, commits suicide+          _ -> True+  factionD <- getsState sfactionD+  let assocsInGame = filter inGameOutcome $ EM.assocs factionD+      assocsKeepArena = filter (keepArenaFact . snd) assocsInGame+      assocsUI = filter (factHasUI . snd) assocsInGame+      nonHorrorAIG = filter (not . isHorrorFact . snd) assocsInGame+      worldPeace =+        all (\(fid1, _) -> all (\(_, fact2) -> not $ isAtWar fact2 fid1)+                           nonHorrorAIG)+        nonHorrorAIG+      othersInGame = filter ((/= fid0) . fst) assocsInGame+  if | null assocsUI ->+       -- Only non-UI players left in the game and they all win.+       mapQuitF $ zip (repeat Conquer) othersInGame+     | null assocsKeepArena ->+       -- Only leaderless and spawners remain (the latter may sometimes+       -- have no leader, just as the former), so they win,+       -- or we could get stuck in a state with no active arena+       -- and so no spawns.+       mapQuitF $ zip (repeat Conquer) othersInGame+     | worldPeace ->+       -- Nobody is at war any more, so all win (e.g., horrors, but never mind).+       mapQuitF $ zip (repeat Conquer) othersInGame+     | stOutcome status == Escape -> do+       -- Otherwise, in a game with many warring teams alive,+       -- only complete Victory matters, until enough of them die.+       let (victors, losers) = partition (flip isAllied fid0 . snd) othersInGame+       mapQuitF $ zip (repeat Escape) victors ++ zip (repeat Defeated) losers+     | otherwise -> quitF status fid0++-- | Tell whether a faction that we know is still in game, keeps arena.+-- Keeping arena means, if the faction is still in game,+-- it always has a leader in the dungeon somewhere.+-- So, leaderless factions and spawner factions do not keep an arena,+-- even though the latter usually has a leader for most of the game.+keepArenaFact :: Faction -> Bool+keepArenaFact fact = fleaderMode (gplayer fact) /= LeaderNull+                     && fneverEmpty (gplayer fact)++-- We assume the actor in the second argument has HP <= 0 or is going to be+-- dominated right now. Even if the actor is to be dominated,+-- @bfid@ of the actor body is still the old faction.+deduceKilled :: (MonadAtomic m, MonadServer m) => ActorId -> m ()+deduceKilled aid = do+  Kind.COps{corule} <- getsState scops+  body <- getsState $ getActorBody aid+  let firstDeathEnds = rfirstDeathEnds $ Kind.stdRuleset corule+  fact <- getsState $ (EM.! bfid body) . sfactionD+  when (fneverEmpty $ gplayer fact) $ do+    actorsAlive <- anyActorsAlive (bfid body) aid+    when (not actorsAlive || firstDeathEnds) $+      deduceQuits (bfid body) $ Status Killed (fromEnum $ blid body) Nothing++anyActorsAlive :: MonadServer m => FactionId -> ActorId -> m Bool+anyActorsAlive fid aid = do+  as <- getsState $ fidActorNotProjAssocs fid+  return $! map fst as /= [aid]++electLeader :: MonadAtomic m => FactionId -> LevelId -> ActorId -> m ()+electLeader fid lid aidDead = do+  mleader <- getsState $ _gleader . (EM.! fid) . sfactionD+  when (mleader == Just aidDead) $ do+    actorD <- getsState sactorD+    let ours (_, b) = bfid b == fid && not (bproj b)+        party = filter ours $ EM.assocs actorD+    onLevel <- getsState $ fidActorRegularIds fid lid+    let mleaderNew = case filter (/= aidDead) $ onLevel ++ map fst party of+          [] -> Nothing+          aid : _ -> Just aid+    execUpdAtomic $ UpdLeadFaction fid mleader mleaderNew++supplantLeader :: MonadAtomic m => FactionId -> ActorId -> m ()+supplantLeader fid aid = do+  fact <- getsState $ (EM.! fid) . sfactionD+  unless (fleaderMode (gplayer fact) == LeaderNull) $+    execUpdAtomic $ UpdLeadFaction fid (_gleader fact) (Just aid)++-- The missile item is removed from the store only if the projection+-- went into effect (no failure occured).+projectFail :: (MonadAtomic m, MonadServer m)+            => ActorId    -- ^ actor projecting the item (is on current lvl)+            -> Point      -- ^ target position of the projectile+            -> Int        -- ^ digital line parameter+            -> ItemId     -- ^ the item to be projected+            -> CStore     -- ^ whether the items comes from floor or inventory+            -> Bool       -- ^ whether the item is a blast+            -> m (Maybe ReqFailure)+projectFail source tpxy eps iid cstore isBlast = do+  Kind.COps{coTileSpeedup} <- getsState scops+  sb <- getsState $ getActorBody source+  let lid = blid sb+      spos = bpos sb+  lvl@Level{lxsize, lysize} <- getLevel lid+  case bla lxsize lysize eps spos tpxy of+    Nothing -> return $ Just ProjectAimOnself+    Just [] -> assert `failure` "projecting from the edge of level"+                      `twith` (spos, tpxy)+    Just (pos : restUnlimited) -> do+      bag <- getsState $ getBodyStoreBag sb cstore+      case EM.lookup iid bag of+        Nothing ->  return $ Just ProjectOutOfReach+        Just kit -> do+          itemToF <- itemToFullServer+          actorSk <- currentSkillsServer source+          actorAspect <- getsServer sactorAspect+          let ar = actorAspect EM.! source+              skill = EM.findWithDefault 0 Ability.AbProject actorSk+              itemFull@ItemFull{itemBase} = itemToF iid kit+              forced = isBlast || bproj sb+              calmE = calmEnough sb ar+              legal = permittedProject forced skill calmE "" itemFull+          case legal of+            Left reqFail -> return $ Just reqFail+            Right _ -> do+              let lobable = IK.Lobable `elem` jfeature itemBase+                  rest = if lobable+                         then take (chessDist spos tpxy - 1) restUnlimited+                         else restUnlimited+                  t = lvl `at` pos+              if not $ Tile.isWalkable coTileSpeedup t+                then return $ Just ProjectBlockTerrain+                else do+                  lab <- getsState $ posToAssocs pos lid+                  if not $ all (bproj . snd) lab+                    then if isBlast && bproj sb then do+                           -- Hit the blocking actor.+                           projectBla source spos (pos:rest) iid cstore isBlast+                           return Nothing+                         else return $ Just ProjectBlockActor+                    else do+                      if isBlast && bproj sb && eps `mod` 2 == 0 then+                        -- Make the explosion a bit less regular.+                        projectBla source spos (pos:rest) iid cstore isBlast+                      else+                        projectBla source pos rest iid cstore isBlast+                      return Nothing++projectBla :: (MonadAtomic m, MonadServer m)+           => ActorId    -- ^ actor projecting the item (is on current lvl)+           -> Point      -- ^ starting point of the projectile+           -> [Point]    -- ^ rest of the trajectory of the projectile+           -> ItemId     -- ^ the item to be projected+           -> CStore     -- ^ whether the items comes from floor or inventory+           -> Bool       -- ^ whether the item is a blast+           -> m ()+projectBla source pos rest iid cstore isBlast = do+  sb <- getsState $ getActorBody source+  item <- getsState $ getItemBody iid+  let lid = blid sb+  localTime <- getsState $ getLocalTime lid+  unless isBlast $ execSfxAtomic $ SfxProject source iid cstore+  bag <- getsState $ getBodyStoreBag sb cstore+  case iid `EM.lookup` bag of+    Nothing -> assert `failure` (source, pos, rest, iid, cstore)+    Just kit@(_, it) -> do+      let btime = absoluteTimeAdd timeEpsilon localTime+      addProjectile pos rest iid kit lid (bfid sb) btime isBlast+      let c = CActor source cstore+      execUpdAtomic $ UpdLoseItem False iid item (1, take 1 it) c++-- | Create a projectile actor containing the given missile.+--+-- Projectile has no organs except for the trunk.+addProjectile :: (MonadAtomic m, MonadServer m)+              => Point -> [Point] -> ItemId -> ItemQuant -> LevelId+              -> FactionId -> Time -> Bool+              -> m ()+addProjectile bpos rest iid (_, it) blid bfid btime _isBlast = do+  itemToF <- itemToFullServer+  let itemFull@ItemFull{itemBase} = itemToF iid (1, take 1 it)+      (trajectory, (speed, _)) = itemTrajectory itemBase (bpos : rest)+      tweakBody b = b { bhp = oneM+                      , bproj = True+                      , btrajectory = Just (trajectory, speed)+                      , beqp = EM.singleton iid (1, take 1 it)+                      , borgan = EM.empty }  -- don't confer bonuses from trunk+  void $ addActorIid iid itemFull True bfid bpos blid tweakBody btime++addActor :: (MonadAtomic m, MonadServer m)+         => GroupName ItemKind -> FactionId -> Point -> LevelId+         -> (Actor -> Actor) -> Time+         -> m (Maybe ActorId)+addActor actorGroup bfid pos lid tweakBody time = do+  -- We bootstrap the actor by first creating the trunk of the actor's body+  -- contains the constant properties.+  let trunkFreq = [(actorGroup, 1)]+  m2 <- rollAndRegisterItem lid trunkFreq (CTrunk bfid lid pos) False Nothing+  case m2 of+    Nothing -> return Nothing+    Just (trunkId, (trunkFull, _)) ->+      addActorIid trunkId trunkFull False bfid pos lid tweakBody time++addActorIid :: (MonadAtomic m, MonadServer m)+            => ItemId -> ItemFull -> Bool -> FactionId -> Point -> LevelId+            -> (Actor -> Actor) -> Time+            -> m (Maybe ActorId)+addActorIid trunkId trunkFull@ItemFull{..} bproj+            bfid pos lid tweakBody time = do+  let trunkKind = case itemDisco of+        Just ItemDisco{itemKind} -> itemKind+        Nothing -> assert `failure` trunkFull+      aspects = fromJust $ itemAspect $ fromJust itemDisco+  -- Initial HP and Calm is based only on trunk and ignores organs.+      hp = xM (max 2 $ aMaxHP aspects) `div` 2+      -- Hard to auto-id items that refill Calm, but reduced sight at game+      -- start is more confusing and frustrating:+      calm = xM (max 0 $ aMaxCalm aspects)+  -- Create actor.+  factionD <- getsState sfactionD+  let fact = factionD EM.! bfid+  curChalSer <- getsServer $ scurChalSer . sdebugSer+  nU <- nUI+  -- If difficulty is below standard, HP is added to the UI factions,+  -- otherwise HP is added to their enemies.+  -- If no UI factions, their role is taken by the escapees (for testing).+  let diffBonusCoeff = difficultyCoeff $ cdiff curChalSer+      hasUIorEscapes Faction{gplayer} =+        fhasUI gplayer || nU == 0 && fcanEscape gplayer+      boostFact = not bproj+                  && if diffBonusCoeff > 0+                     then hasUIorEscapes fact+                          || any hasUIorEscapes+                                 (filter (`isAllied` bfid) $ EM.elems factionD)+                     else any hasUIorEscapes+                              (filter (`isAtWar` bfid) $ EM.elems factionD)+      diffHP | boostFact = if cdiff curChalSer `elem` [1, difficultyBound]+                           then xM 999 - hp -- as much as UI can stand+                           else hp * 2 ^ abs diffBonusCoeff+             | otherwise = hp+      bonusHP = fromEnum $ (diffHP - hp) `divUp` oneM+      healthOrgans = [(Just bonusHP, ("bonus HP", COrgan)) | bonusHP /= 0]+      b = actorTemplate trunkId diffHP calm pos lid bfid+      -- Insert the trunk as the actor's organ.+      withTrunk = b { borgan = EM.singleton trunkId (itemK, itemTimer)+                    , bweapon = if isMelee itemBase then 1 else 0 }+  aid <- getsServer sacounter+  modifyServer $ \ser -> ser {sacounter = succ aid}+  execUpdAtomic $ UpdCreateActor aid (tweakBody withTrunk) [(trunkId, itemBase)]+  modifyServer $ \ser ->+    ser {sactorTime = updateActorTime bfid lid aid time $ sactorTime ser}+  -- Create, register and insert all initial actor items, including+  -- the bonus health organs from difficulty setting.+  forM_ (healthOrgans ++ map (Nothing,) (IK.ikit trunkKind))+        $ \(mk, (ikText, cstore)) -> do+    let container = CActor aid cstore+        itemFreq = [(ikText, 1)]+    mIidEtc <- rollAndRegisterItem lid itemFreq container False mk+    case mIidEtc of+      Nothing -> assert `failure` (lid, itemFreq, container, mk)+      Just (_, (ItemFull{itemDisco=+                  Just ItemDisco{itemKind=IK.ItemKind{IK.ieffects}}}, _))+        | any IK.forIdEffect ieffects -> return ()  -- discover by use+      Just (iid, _) -> do+        seed <- getsServer $ (EM.! iid) . sitemSeedD+        execUpdAtomic $ UpdDiscoverSeed container iid seed+  return $ Just aid++pickWeaponServer :: MonadServer m => ActorId -> m (Maybe (ItemId, CStore))+pickWeaponServer source = do+  eqpAssocs <- fullAssocsServer source [CEqp]+  bodyAssocs <- fullAssocsServer source [COrgan]+  actorSk <- currentSkillsServer source+  actorAspect <- getsServer sactorAspect+  sb <- getsState $ getActorBody source+  let allAssocsRaw = eqpAssocs ++ bodyAssocs+      forced = bproj sb+      allAssocs | forced = allAssocsRaw  -- for projectiles, anything is weapon+                | otherwise = filter (isMelee . itemBase . snd) allAssocsRaw+  -- Server ignores item effects or it would leak item discovery info.+  -- In particular, it even uses weapons that would heal opponent,+  -- and not only in case of projectiles.+  strongest <- pickWeaponM Nothing allAssocs actorSk actorAspect source+  case strongest of+    [] -> return Nothing+    iis@((maxS, _) : _) -> do+      let maxIis = map snd $ takeWhile ((== maxS) . fst) iis+      (iid, _) <- rndToAction $ oneOf maxIis+      let cstore = if isJust (lookup iid bodyAssocs) then COrgan else CEqp+      return $ Just (iid, cstore)++currentSkillsServer :: MonadServer m => ActorId -> m Ability.Skills+currentSkillsServer aid  = do+  ar <- getsServer $ (EM.! aid) . sactorAspect+  body <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid body) . sfactionD+  let mleader = _gleader fact+  getsState $ actorSkills mleader aid ar++getCacheLucid :: MonadServer m => LevelId -> m FovLucid+getCacheLucid lid = do+  discoAspect <- getsServer sdiscoAspect+  actorAspect <- getsServer sactorAspect+  fovClearLid <- getsServer sfovClearLid+  fovLitLid <- getsServer sfovLitLid+  fovLucidLid <- getsServer sfovLucidLid+  let getNewLucid = getsState $ \s ->+        lucidFromLevel discoAspect actorAspect fovClearLid fovLitLid+                       s lid (sdungeon s EM.! lid)+  case EM.lookup lid fovLucidLid of+    Just (FovValid fovLucid) -> return fovLucid+    _ -> do+      newLucid <- getNewLucid+      modifyServer $ \ser ->+        ser {sfovLucidLid = EM.insert lid (FovValid newLucid)+                            $ sfovLucidLid ser}+      return newLucid++getCacheTotal :: MonadServer m => FactionId -> LevelId -> m CacheBeforeLucid+getCacheTotal fid lid = do+  sperCacheFidOld <- getsServer sperCacheFid+  let perCacheOld = sperCacheFidOld EM.! fid EM.! lid+  case ptotal perCacheOld of+    FovValid total -> return total+    FovInvalid -> do+      actorAspect <- getsServer sactorAspect+      fovClearLid <- getsServer sfovClearLid+      getActorB <- getsState $ flip getActorBody+      let perActorNew =+            perActorFromLevel (perActor perCacheOld) getActorB+                              actorAspect (fovClearLid EM.! lid)+          -- We don't check if any actor changed, because almost surely one is.+          -- Exception: when an actor is destroyed, but then union differs, too.+          total = totalFromPerActor perActorNew+          perCache = PerceptionCache { ptotal = FovValid total+                                     , perActor = perActorNew }+          fperCache = EM.adjust (EM.insert lid perCache) fid+      modifyServer $ \ser -> ser {sperCacheFid = fperCache $ sperCacheFid ser}+      return total++recomputeCachePer :: MonadServer m => FactionId -> LevelId -> m Perception+recomputeCachePer fid lid = do+  total <- getCacheTotal fid lid+  fovLucid <- getCacheLucid lid+  let perNew = perceptionFromPTotal fovLucid total+      fper = EM.adjust (EM.insert lid perNew) fid+  modifyServer $ \ser -> ser {sperFid = fper $ sperFid ser}+  return perNew

− Game/LambdaHack/Server/CommonServer.hs

@@ -1,491 +0,0 @@-{-# LANGUAGE TupleSections #-}--- | Server operations common to many modules.-module Game.LambdaHack.Server.CommonServer-  ( execFailure, resetFidPerception, resetLitInDungeon, getPerFid-  , revealItems, moveStores, deduceQuits, deduceKilled, electLeader-  , addActor, addActorIid, projectFail-  , pickWeaponServer, sumOrganEqpServer, actorSkillsServer-  ) where--import Control.Applicative-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.List-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T-import qualified NLP.Miniutter.English as MU-import qualified Text.Show.Pretty as Show.Pretty--import Game.LambdaHack.Atomic-import qualified Game.LambdaHack.Common.Ability as Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Color as Color-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Flavour-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemDescription-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.ItemKind (ItemKind)-import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Server.Fov-import Game.LambdaHack.Server.ItemServer-import Game.LambdaHack.Server.MonadServer-import Game.LambdaHack.Server.State--execFailure :: (MonadAtomic m, MonadServer m)-            => ActorId -> RequestTimed a -> ReqFailure -> m ()-execFailure aid req failureSer = do-  -- Clients should rarely do that (only in case of invisible actors)-  -- so we report it, send a --more-- meeesage (if not AI), but do not crash-  -- (server should work OK with stupid clients, too).-  body <- getsState $ getActorBody aid-  let fid = bfid body-      msg = showReqFailure failureSer-      impossible = impossibleReqFailure failureSer-      debugShow :: Show a => a -> Text-      debugShow = T.pack . Show.Pretty.ppShow-      possiblyAlarm = if impossible-                      then debugPossiblyPrintAndExit-                      else debugPossiblyPrint-  possiblyAlarm $-    "execFailure:" <+> msg <> "\n"-    <> debugShow body <> "\n" <> debugShow req-  execSfxAtomic $ SfxMsgFid fid $ "Unexpected problem:" <+> msg <> "."-    -- TODO: --more--, but keep in history---- | Update the cached perception for the selected level, for a faction.--- The assumption is the level, and only the level, has changed since--- the previous perception calculation.-resetFidPerception :: MonadServer m-                   => PersLit -> FactionId -> LevelId-                   -> m Perception-resetFidPerception persLit fid lid = do-  sfovMode <- getsServer $ sfovMode . sdebugSer-  lvl <- getLevel lid-  let fovMode = fromMaybe Digital sfovMode-      per = fidLidPerception fovMode persLit fid lid lvl-      upd = EM.adjust (EM.adjust (const per) lid) fid-  modifyServer $ \ser2 -> ser2 {sper = upd (sper ser2)}-  return $! per--resetLitInDungeon :: MonadServer m => m PersLit-resetLitInDungeon = do-  sfovMode <- getsServer $ sfovMode . sdebugSer-  ser <- getServer-  let fovMode = fromMaybe Digital sfovMode-  getsState $ \s -> litInDungeon fovMode s ser--getPerFid :: MonadServer m => FactionId -> LevelId -> m Perception-getPerFid fid lid = do-  pers <- getsServer sper-  let failFact = assert `failure` "no perception for faction" `twith` (lid, fid)-      fper = EM.findWithDefault failFact fid pers-      failLvl = assert `failure` "no perception for level" `twith` (lid, fid)-      per = EM.findWithDefault failLvl lid fper-  return $! per--revealItems :: (MonadAtomic m, MonadServer m)-            => Maybe FactionId -> Maybe (ActorId, Actor) -> m ()-revealItems mfid mbody = do-  let !_A = assert (maybe True (not . bproj . snd) mbody) ()-  itemToF <- itemToFullServer-  dungeon <- getsState sdungeon-  let discover aid store iid k =-        let itemFull = itemToF iid k-            c = CActor aid store-        in case itemDisco itemFull of-          Just ItemDisco{itemKindId} -> do-            seed <- getsServer $ (EM.! iid) . sitemSeedD-            Level{ldepth} <- getLevel $ jlid $ itemBase itemFull-            execUpdAtomic $ UpdDiscover c iid itemKindId seed ldepth-          _ -> assert `failure` (mfid, mbody, c, iid, itemFull)-      f aid = do-        b <- getsState $ getActorBody aid-        let ourSide = maybe True (== bfid b) mfid-        -- Don't ID projectiles, because client may not see them.-        when (not (bproj b) && ourSide) $-          -- CSha is IDed for each actor of each faction, which is OK,-          -- even though it may introduce a slight lag.-          -- AI clients being sent this is a bigger waste anyway.-          join $ getsState $ mapActorItems_ (discover aid) b-  mapDungeonActors_ f dungeon-  maybe (return ())-        (\(aid, b) -> join $ getsState $ mapActorItems_ (discover aid) b)-        mbody--moveStores :: (MonadAtomic m, MonadServer m)-           => ActorId -> CStore -> CStore -> m ()-moveStores aid fromStore toStore = do-  b <- getsState $ getActorBody aid-  let g iid (k, _) = execUpdAtomic $ UpdMoveItem iid k aid fromStore toStore-  mapActorCStore_ fromStore g b--quitF :: (MonadAtomic m, MonadServer m)-      => Maybe (ActorId, Actor) -> Status -> FactionId -> m ()-quitF mbody status fid = do-  let !_A = assert (maybe True ((fid ==) . bfid . snd) mbody) ()-  fact <- getsState $ (EM.! fid) . sfactionD-  let oldSt = gquit fact-  case stOutcome <$> oldSt of-    Just Killed -> return ()    -- Do not overwrite in case-    Just Defeated -> return ()  -- many things happen in 1 turn.-    Just Conquer -> return ()-    Just Escape -> return ()-    _ -> do-      when (fhasUI $ gplayer fact) $ do-        keepAutomated <- getsServer $ skeepAutomated . sdebugSer-        when (isAIFact fact-              && fleaderMode (gplayer fact) /= LeaderNull-              && not keepAutomated) $-          execUpdAtomic $ UpdAutoFaction fid False-        revealItems (Just fid) mbody-        registerScore status (snd <$> mbody) fid-      execUpdAtomic $ UpdQuitFaction fid (snd <$> mbody) oldSt $ Just status  -- TODO: send only aid to UpdQuitFaction and elsewhere --- aid is alive-      modifyServer $ \ser -> ser {squit = True}  -- end turn ASAP---- Send any QuitFactionA actions that can be deduced from their current state.-deduceQuits :: (MonadAtomic m, MonadServer m)-            => FactionId -> Maybe (ActorId, Actor) -> Status -> m ()-deduceQuits fid mbody status@Status{stOutcome}-  | stOutcome `elem` [Defeated, Camping, Restart, Conquer] =-    assert `failure` "no quitting to deduce" `twith` (fid, mbody, status)-deduceQuits fid mbody status = do-  let mapQuitF statusF fids = mapM_ (quitF Nothing statusF) $ delete fid fids-  quitF mbody status fid-  let inGameOutcome (_, fact) = case stOutcome <$> gquit fact of-        Just Killed -> False-        Just Defeated -> False-        Just Restart -> False  -- effectively, commits suicide-        _ -> True-  factionD <- getsState sfactionD-  let assocsInGame = filter inGameOutcome $ EM.assocs factionD-      keysInGame = map fst assocsInGame-      assocsKeepArena = filter (keepArenaFact . snd) assocsInGame-      assocsUI = filter (fhasUI . gplayer . snd) assocsInGame-      nonHorrorAIG = filter (not . isHorrorFact . snd) assocsInGame-      worldPeace =-        all (\(fid1, _) -> all (\(_, fact2) -> not $ isAtWar fact2 fid1)-                           nonHorrorAIG)-        nonHorrorAIG-  case assocsKeepArena of-    _ | null assocsUI ->-      -- Only non-UI players left in the game and they all win.-      mapQuitF status{stOutcome=Conquer} keysInGame-    [] ->-      -- Only leaderless and spawners remain (the latter may sometimes-      -- have no leader, just as the former), so they win,-      -- or we could get stuck in a state with no active arena and so no spawns.-      mapQuitF status{stOutcome=Conquer} keysInGame-    _ | worldPeace ->-      -- Nobody is at war any more, so all win (e.g., horrors, but never mind).-      mapQuitF status{stOutcome=Conquer} keysInGame-    _ | stOutcome status == Escape -> do-      -- Otherwise, in a game with many warring teams alive,-      -- only complete Victory matters, until enough of them die.-      let (victors, losers) =-            partition (flip isAllied fid . snd) assocsInGame-      mapQuitF status{stOutcome=Escape} $ map fst victors-      mapQuitF status{stOutcome=Defeated} $ map fst losers-    _ -> return ()---- | Tell whether a faction that we know is still in game, keeps arena.--- Keeping arena means, if the faction is still in game,--- it always has a leader in the dungeon somewhere.--- So, leaderless factions and spawner factions do not keep an arena,--- even though the latter usually has a leader for most of the game.-keepArenaFact :: Faction -> Bool-keepArenaFact fact = fleaderMode (gplayer fact) /= LeaderNull-                     && fneverEmpty (gplayer fact)---- We assume the actor in the second argumet is dead or dominated--- by this point. Even if the actor is to be dominated,--- @bfid@ of the actor body is still the old faction.-deduceKilled :: (MonadAtomic m, MonadServer m)-             => ActorId -> Actor -> m ()-deduceKilled aid body = do-  Kind.COps{corule} <- getsState scops-  let firstDeathEnds = rfirstDeathEnds $ Kind.stdRuleset corule-      fid = bfid body-  fact <- getsState $ (EM.! fid) . sfactionD-  when (fneverEmpty $ gplayer fact) $ do-    actorsAlive <- anyActorsAlive fid (Just aid)-    when (not actorsAlive || firstDeathEnds) $-      deduceQuits fid (Just (aid, body))-      $ Status Killed (fromEnum $ blid body) Nothing--anyActorsAlive :: MonadServer m => FactionId -> Maybe ActorId -> m Bool-anyActorsAlive fid maid = do-  fact <- getsState $ (EM.! fid) . sfactionD-  if fleaderMode (gplayer fact) /= LeaderNull-    then return $! isJust $ gleader fact-    else do-      as <- getsState $ fidActorNotProjAssocs fid-      return $! not $ null $ maybe as (\aid -> filter ((/= aid) . fst) as) maid--electLeader :: MonadAtomic m => FactionId -> LevelId -> ActorId -> m ()-electLeader fid lid aidDead = do-  mleader <- getsState $ gleader . (EM.! fid) . sfactionD-  when (isNothing mleader || fmap fst mleader == Just aidDead) $ do-    actorD <- getsState sactorD-    let ours (_, b) = bfid b == fid && not (bproj b)-        party = filter ours $ EM.assocs actorD-    onLevel <- getsState $ actorRegularAssocs (== fid) lid-    let mleaderNew = case filter (/= aidDead) $ map fst $ onLevel ++ party of-          [] -> Nothing-          aid : _ -> Just (aid, Nothing)-    unless (mleader == mleaderNew) $-      execUpdAtomic $ UpdLeadFaction fid mleader mleaderNew--projectFail :: (MonadAtomic m, MonadServer m)-            => ActorId    -- ^ actor projecting the item (is on current lvl)-            -> Point      -- ^ target position of the projectile-            -> Int        -- ^ digital line parameter-            -> ItemId     -- ^ the item to be projected-            -> CStore     -- ^ whether the items comes from floor or inventory-            -> Bool       -- ^ whether the item is a blast-            -> m (Maybe ReqFailure)-projectFail source tpxy eps iid cstore isBlast = do-  Kind.COps{cotile} <- getsState scops-  sb <- getsState $ getActorBody source-  let lid = blid sb-      spos = bpos sb-  lvl@Level{lxsize, lysize} <- getLevel lid-  case bla lxsize lysize eps spos tpxy of-    Nothing -> return $ Just ProjectAimOnself-    Just [] -> assert `failure` "projecting from the edge of level"-                      `twith` (spos, tpxy)-    Just (pos : restUnlimited) -> do-      bag <- getsState $ getActorBag source cstore-      case EM.lookup iid bag of-        Nothing ->  return $ Just ProjectOutOfReach-        Just kit -> do-          itemToF <- itemToFullServer-          activeItems <- activeItemsServer source-          actorSk <- actorSkillsServer source-          let skill = EM.findWithDefault 0 Ability.AbProject actorSk-              itemFull@ItemFull{itemBase} = itemToF iid kit-              forced = isBlast || bproj sb-              legal = permittedProject " " forced skill itemFull sb activeItems-          case legal of-            Left reqFail ->  return $ Just reqFail-            Right _ -> do-              let fragile = IK.Fragile `elem` jfeature itemBase-                  rest = if fragile-                         then take (chessDist spos tpxy - 1) restUnlimited-                         else restUnlimited-                  t = lvl `at` pos-              if not $ Tile.isWalkable cotile t-                then return $ Just ProjectBlockTerrain-                else do-                  lab <- getsState $ posToActors pos lid-                  if not $ all (bproj . snd) lab-                    then if isBlast && bproj sb then do-                           -- Hit the blocking actor.-                           projectBla source spos (pos:rest) iid cstore isBlast-                           return Nothing-                         else return $ Just ProjectBlockActor-                    else do-                      if isBlast && bproj sb && eps `mod` 2 == 0 then-                        -- Make the explosion a bit less regular.-                        projectBla source spos (pos:rest) iid cstore isBlast-                      else-                        projectBla source pos rest iid cstore isBlast-                      return Nothing---projectBla :: (MonadAtomic m, MonadServer m)-           => ActorId    -- ^ actor projecting the item (is on current lvl)-           -> Point      -- ^ starting point of the projectile-           -> [Point]    -- ^ rest of the trajectory of the projectile-           -> ItemId     -- ^ the item to be projected-           -> CStore     -- ^ whether the items comes from floor or inventory-           -> Bool       -- ^ whether the item is a blast-           -> m ()-projectBla source pos rest iid cstore isBlast = do-  sb <- getsState $ getActorBody source-  item <- getsState $ getItemBody iid-  let lid = blid sb-  localTime <- getsState $ getLocalTime lid-  unless isBlast $ execSfxAtomic $ SfxProject source iid cstore-  bag <- getsState $ getActorBag source cstore-  case iid `EM.lookup` bag of-    Nothing -> assert `failure` (source, pos, rest, iid, cstore)-    Just kit@(_, it) -> do-      addProjectile pos rest iid kit lid (bfid sb) localTime isBlast-      let c = CActor source cstore-      execUpdAtomic $ UpdLoseItem iid item (1, take 1 it) c---- | Create a projectile actor containing the given missile.------ Projectile has no organs except for the trunk.-addProjectile :: (MonadAtomic m, MonadServer m)-              => Point -> [Point] -> ItemId -> ItemQuant -> LevelId-              -> FactionId -> Time -> Bool-              -> m ()-addProjectile bpos rest iid (_, it) blid bfid btime isBlast = do-  localTime <- getsState $ getLocalTime blid-  itemToF <- itemToFullServer-  let itemFull@ItemFull{itemBase} = itemToF iid (1, take 1 it)-      (trajectory, (speed, trange)) = itemTrajectory itemBase (bpos : rest)-      adj | trange < 5 = "falling"-          | otherwise = "flying"-      -- Not much detail about a fast flying item.-      (_, object1, object2) = partItem CInv localTime-                                       (itemNoDisco (itemBase, 1))-      bname = makePhrase [MU.AW $ MU.Text adj, object1, object2]-      tweakBody b = b { bsymbol = if isBlast then bsymbol b else '*'-                      , bcolor = if isBlast then bcolor b else Color.BrWhite-                      , bname-                      , bhp = 1-                      , bproj = True-                      , btrajectory = Just (trajectory, speed)-                      , beqp = EM.singleton iid (1, take 1 it)-                      , borgan = EM.empty}-      bpronoun = "it"-  void $ addActorIid iid itemFull-                     True bfid bpos blid tweakBody bpronoun btime--addActor :: (MonadAtomic m, MonadServer m)-         => GroupName ItemKind -> FactionId -> Point -> LevelId-         -> (Actor -> Actor) -> Text -> Time-         -> m (Maybe ActorId)-addActor actorGroup bfid pos lid tweakBody bpronoun time = do-  -- We bootstrap the actor by first creating the trunk of the actor's body-  -- contains the constant properties.-  let trunkFreq = [(actorGroup, 1)]-  m2 <- rollAndRegisterItem lid trunkFreq (CTrunk bfid lid pos) False Nothing-  case m2 of-    Nothing -> return Nothing-    Just (trunkId, (trunkFull, _)) ->-      addActorIid trunkId trunkFull False bfid pos lid tweakBody bpronoun time--addActorIid :: (MonadAtomic m, MonadServer m)-            => ItemId -> ItemFull -> Bool -> FactionId -> Point -> LevelId-            -> (Actor -> Actor) -> Text -> Time-            -> m (Maybe ActorId)-addActorIid trunkId trunkFull@ItemFull{..} bproj-            bfid pos lid tweakBody bpronoun time = do-  let trunkKind = case itemDisco of-        Just ItemDisco{itemKind} -> itemKind-        Nothing -> assert `failure` trunkFull-  -- Initial HP and Calm is based only on trunk and ignores organs.-  let hp = xM (max 2 $ sumSlotNoFilter IK.EqpSlotAddMaxHP [trunkFull])-           `div` 2-      calm = xM $ max 1-             $ sumSlotNoFilter IK.EqpSlotAddMaxCalm [trunkFull]-  -- Create actor.-  factionD <- getsState sfactionD-  let factMine = factionD EM.! bfid-  DebugModeSer{scurDiffSer} <- getsServer sdebugSer-  nU <- nUI-  -- If difficulty is below standard, HP is added to the UI factions,-  -- otherwise HP is added to their enemies.-  -- If no UI factions, their role is taken by the escapees (for testing).-  let diffBonusCoeff = difficultyCoeff scurDiffSer-      hasUIorEscapes Faction{gplayer} =-        fhasUI gplayer || nU == 0 && fcanEscape gplayer-      boostFact = not bproj-                  && if diffBonusCoeff > 0-                     then hasUIorEscapes factMine-                          || any hasUIorEscapes-                                 (filter (`isAllied` bfid) $ EM.elems factionD)-                     else any hasUIorEscapes-                              (filter (`isAtWar` bfid) $ EM.elems factionD)-      diffHP | boostFact = hp * 2 ^ abs diffBonusCoeff-             | otherwise = hp-      bonusHP = fromIntegral $ (diffHP - hp) `divUp` oneM-      healthOrgans = [(Just bonusHP, ("bonus HP", COrgan)) | bonusHP /= 0]-      bsymbol = jsymbol itemBase-      bname = IK.iname trunkKind-      bcolor = flavourToColor $ jflavour itemBase-      b = actorTemplate trunkId bsymbol bname bpronoun bcolor diffHP calm-                        pos lid time bfid-      -- Insert the trunk as the actor's organ.-      withTrunk = b {borgan = EM.singleton trunkId (itemK, itemTimer)}-  aid <- getsServer sacounter-  modifyServer $ \ser -> ser {sacounter = succ aid}-  execUpdAtomic $ UpdCreateActor aid (tweakBody withTrunk) [(trunkId, itemBase)]-  -- Create, register and insert all initial actor items, including-  -- the bonus health organs from difficulty setting.-  forM_ (healthOrgans ++ map (Nothing,) (IK.ikit trunkKind))-        $ \(mk, (ikText, cstore)) -> do-    let container = CActor aid cstore-        itemFreq = [(ikText, 1)]-    mIidEtc <- rollAndRegisterItem lid itemFreq container False mk-    case mIidEtc of-      Nothing -> assert `failure` (lid, itemFreq, container, mk)-      Just (_, (ItemFull{itemDisco=-                  Just ItemDisco{itemAE=-                  Just ItemAspectEffect{jeffects=_:_}}}, _)) ->-        return ()  -- discover by use-      Just (iid, (ItemFull{itemBase=itemBase2}, _)) -> do-        seed <- getsServer $ (EM.! iid) . sitemSeedD-        Level{ldepth} <- getLevel $ jlid itemBase2-        execUpdAtomic $ UpdDiscoverSeed container iid seed ldepth-  return $ Just aid---- Server has to pick a random weapon or it could leak item discovery--- information. In case of non-projectiles, it only picks items--- with some effects, though, so it leaks properties of completely--- unidentified items.-pickWeaponServer :: MonadServer m => ActorId -> m (Maybe (ItemId, CStore))-pickWeaponServer source = do-  eqpAssocs <- fullAssocsServer source [CEqp]-  bodyAssocs <- fullAssocsServer source [COrgan]-  actorSk <- actorSkillsServer source-  sb <- getsState $ getActorBody source-  localTime <- getsState $ getLocalTime (blid sb)-  -- For projectiles we need to accept even items without any effect,-  -- so that the projectile dissapears and "No effect" feedback is produced.-  let allAssocs = eqpAssocs ++ bodyAssocs-      calm10 = calmEnough10 sb $ map snd allAssocs-      forced = bproj sb-      permitted = permittedPrecious calm10 forced-      legalPrecious = either (const False) (const True) . permitted-      preferredPrecious = either (const False) id . permitted-      strongest = strongestMelee True localTime allAssocs-      strongestLegal = filter (legalPrecious . snd . snd) strongest-      strongestPreferred = filter (preferredPrecious . snd . snd) strongestLegal-      best = case strongestPreferred of-        _ | bproj sb -> map (1,) eqpAssocs-        _ | EM.findWithDefault 0 Ability.AbMelee actorSk <= 0 -> []-        _:_ -> strongestPreferred-        [] -> strongestLegal-  case best of-    [] -> return Nothing-    iis@((maxS, _) : _) -> do-      let maxIis = map snd $ takeWhile ((== maxS) . fst) iis-      (iid, _) <- rndToAction $ oneOf maxIis-      let cstore = if isJust (lookup iid bodyAssocs) then COrgan else CEqp-      return $ Just (iid, cstore)--sumOrganEqpServer :: MonadServer m-                 => IK.EqpSlot -> ActorId -> m Int-sumOrganEqpServer eqpSlot aid = do-  activeAssocs <- activeItemsServer aid-  return $! sumSlotNoFilter eqpSlot activeAssocs--actorSkillsServer :: MonadServer m => ActorId -> m Ability.Skills-actorSkillsServer aid  = do-  activeItems <- activeItemsServer aid-  body <- getsState $ getActorBody aid-  fact <- getsState $ (EM.! bfid body) . sfactionD-  let mleader = fst <$> gleader fact-  getsState $ actorSkills mleader aid activeItems

+ Game/LambdaHack/Server/DebugM.hs view

@@ -0,0 +1,94 @@+-- | Debug output for requests and responseQs.+module Game.LambdaHack.Server.DebugM+  ( debugResponse+  , debugRequestAI, debugRequestUI+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.EnumMap.Strict as EM+import Data.Int (Int64)+import qualified Data.Text as T+import qualified Text.Show.Pretty as Show.Pretty++import Game.LambdaHack.Atomic+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.Response+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Server.MonadServer+import Game.LambdaHack.Server.State++-- We debug these on the server, not on the clients, because we want+-- a single log, knowing the order in which the server received requests+-- and sent responseQs. Clients interleave and block non-deterministically+-- so their logs would be harder to interpret.++debugShow :: Show a => a -> Text+debugShow = T.pack . Show.Pretty.ppShow++debugResponse :: MonadServer m => FactionId -> Response -> m ()+debugResponse fid cmd = case cmd of+  RespUpdAtomic cmdA@UpdPerception{} -> debugPlain fid cmd cmdA+  RespUpdAtomic cmdA@UpdResume{} -> debugPlain fid cmd cmdA+  RespUpdAtomic cmdA@UpdSpotTile{} -> debugPlain fid cmd cmdA+  RespUpdAtomic cmdA -> debugPretty fid cmd cmdA+  RespQueryAI aid -> do+    d <- debugAid aid "RespQueryAI" cmd+    serverPrint d+  RespSfxAtomic sfx -> do+    ps <- posSfxAtomic sfx+    serverPrint $ debugShow (fid, cmd, ps)+  RespQueryUI -> serverPrint "RespQueryUI"++debugPretty :: (MonadServer m, Show a) => FactionId -> a -> UpdAtomic -> m ()+debugPretty fid cmd cmdA = do+  ps <- posUpdAtomic cmdA+  serverPrint $ debugShow (fid, cmd, ps)++debugPlain :: (MonadServer m, Show a) => FactionId -> a -> UpdAtomic -> m ()+debugPlain fid cmd cmdA = do+  ps <- posUpdAtomic cmdA+  serverPrint $ T.pack $ show (fid, cmd, ps)  -- too large for pretty printing++debugRequestAI :: MonadServer m => ActorId -> RequestAI -> m ()+debugRequestAI aid cmd = do+  d <- debugAid aid "AI request" cmd+  serverPrint d++debugRequestUI :: MonadServer m => ActorId -> RequestUI -> m ()+debugRequestUI aid cmd = do+  d <- debugAid aid "UI request" cmd+  serverPrint d++data DebugAid a = DebugAid+  { label   :: !Text+  , aid     :: !ActorId+  , cmd     :: !a+  , faction :: !FactionId+  , lid     :: !LevelId+  , bHP     :: !Int64+  , btime   :: !Time+  , time    :: !Time+  }+  deriving Show++debugAid :: (MonadServer m, Show a) => ActorId -> Text -> a -> m Text+debugAid aid label cmd = do+  b <- getsState $ getActorBody aid+  time <- getsState $ getLocalTime (blid b)+  btime <- getsServer $ (EM.! aid) . (EM.! blid b) . (EM.! bfid b) . sactorTime+  return $! debugShow DebugAid { label+                               , aid+                               , cmd+                               , faction = bfid b+                               , lid = blid b+                               , bHP = bhp b+                               , btime+                               , time }

− Game/LambdaHack/Server/DebugServer.hs

@@ -1,96 +0,0 @@--- | Debug output for requests and responseQs.-module Game.LambdaHack.Server.DebugServer-  ( debugResponseAI, debugResponseUI-  , debugRequestAI, debugRequestUI-  ) where--import Data.Text (Text)-import qualified Data.Text as T-import qualified Text.Show.Pretty as Show.Pretty--import Game.LambdaHack.Atomic-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.Response-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Server.MonadServer---- We debug these on the server, not on the clients, because we want--- a single log, knowing the order in which the server received requests--- and sent responseQs. Clients interleave and block non-deterministically--- so their logs would be harder to interpret.--debugShow :: Show a => a -> Text-debugShow = T.pack . Show.Pretty.ppShow--debugResponseAI :: MonadServer m => ResponseAI -> m ()-debugResponseAI cmd = case cmd of-  RespUpdAtomicAI cmdA@UpdPerception{} -> debugPlain cmd cmdA-  RespUpdAtomicAI cmdA@UpdResume{} -> debugPlain cmd cmdA-  RespUpdAtomicAI cmdA@UpdSpotTile{} -> debugPlain cmd cmdA-  RespUpdAtomicAI cmdA -> debugPretty cmd cmdA-  RespQueryAI aid -> do-    d <- debugAid aid "RespQueryAI" cmd-    serverPrint d-  RespPingAI -> serverPrint $ debugShow cmd--debugResponseUI :: MonadServer m => ResponseUI -> m ()-debugResponseUI cmd = case cmd of-  RespUpdAtomicUI cmdA@UpdPerception{} -> debugPlain cmd cmdA-  RespUpdAtomicUI cmdA@UpdResume{} -> debugPlain cmd cmdA-  RespUpdAtomicUI cmdA@UpdSpotTile{} -> debugPlain cmd cmdA-  RespUpdAtomicUI cmdA -> debugPretty cmd cmdA-  RespSfxAtomicUI sfx -> do-    ps <- posSfxAtomic sfx-    serverPrint $ debugShow (cmd, ps)-  RespQueryUI -> serverPrint $ "RespQueryUI:" <+> debugShow cmd-  RespPingUI -> serverPrint $ debugShow cmd--debugPretty :: (MonadServer m, Show a) => a -> UpdAtomic -> m ()-debugPretty cmd cmdA = do-  ps <- posUpdAtomic cmdA-  serverPrint $ debugShow (cmd, ps)--debugPlain :: (MonadServer m, Show a) => a -> UpdAtomic -> m ()-debugPlain cmd cmdA = do-  ps <- posUpdAtomic cmdA-  serverPrint $ T.pack $ show (cmd, ps)  -- too large for pretty printing--debugRequestAI :: MonadServer m => ActorId -> RequestAI -> m ()-debugRequestAI aid cmd = do-  d <- debugAid aid "AI request" cmd-  serverPrint d--debugRequestUI :: MonadServer m => ActorId -> RequestUI -> m ()-debugRequestUI aid cmd = do-  d <- debugAid aid "UI request" cmd-  serverPrint d--data DebugAid a = DebugAid-  { label   :: !Text-  , cmd     :: !a-  , lid     :: !LevelId-  , time    :: !Time-  , aid     :: !ActorId-  , faction :: !FactionId-  }-  deriving Show--debugAid :: (MonadStateRead m, Show a) => ActorId -> Text -> a -> m Text-debugAid aid label cmd =-  if aid == toEnum (-1) then-    return $ "Pong:" <+> debugShow label <+> debugShow cmd-  else do-    b <- getsState $ getActorBody aid-    time <- getsState $ getLocalTime (blid b)-    return $! debugShow DebugAid { label-                                 , cmd-                                 , lid = blid b-                                 , time-                                 , aid-                                 , faction = bfid b }

Game/LambdaHack/Server/DungeonGen.hs view

@@ -1,21 +1,23 @@-{-# LANGUAGE CPP #-} -- | The unpopulated dungeon generation routine. module Game.LambdaHack.Server.DungeonGen   ( FreshDungeon(..), dungeonGen #ifdef EXPOSE_INTERNAL     -- * Internal operations-  , convertTileMaps, placeStairs, buildLevel, levelFromCaveKind, findGenerator+  , convertTileMaps, placeDownStairs, buildLevel, levelFromCaveKind #endif   ) where -import Control.Applicative-import Control.Exception.Assert.Sugar-import Control.Monad+import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Control.Monad.Trans.State.Strict as St import qualified Data.EnumMap.Strict as EM import qualified Data.IntMap.Strict as IM-import Data.List-import Data.Maybe+import Data.Tuple+import qualified System.Random as R +import Game.LambdaHack.Common.Frequency import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc@@ -25,38 +27,34 @@ import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.CaveKind-import Game.LambdaHack.Content.ItemKind (ItemKind)-import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Content.PlaceKind (PlaceKind) import Game.LambdaHack.Content.TileKind (TileKind) import qualified Game.LambdaHack.Content.TileKind as TK-import Game.LambdaHack.Server.DungeonGen.Area import Game.LambdaHack.Server.DungeonGen.Cave import Game.LambdaHack.Server.DungeonGen.Place -convertTileMaps :: Kind.COps+convertTileMaps :: Kind.COps -> Bool                 -> Rnd (Kind.Id TileKind) -> Maybe (Rnd (Kind.Id TileKind))                 -> Int -> Int -> TileMapEM                 -> Rnd TileMap-convertTileMaps Kind.COps{cotile}-                cdefTile mcdefTileWalkable cxsize cysize ltile = do-  let f :: Point -> Rnd (Kind.Id TileKind)-      f p = case EM.lookup p ltile of-        Just t -> return t-        Nothing -> cdefTile-  converted1 <- PointArray.generateMA cxsize cysize f-  case mcdefTileWalkable of+convertTileMaps Kind.COps{coTileSpeedup} areAllWalkable+                cdefTile mpickPassable cxsize cysize ltile = do+  let runCdefTile :: R.StdGen -> (Kind.Id TileKind, R.StdGen)+      runCdefTile = St.runState cdefTile+      runUnfold gen =+        let (gen1, gen2) = R.split gen+        in (PointArray.unfoldrNA cxsize cysize runCdefTile gen1, gen2)+  converted0 <- St.state runUnfold+  let converted1 = converted0 PointArray.// EM.assocs ltile+  case mpickPassable of+    _ | areAllWalkable -> return converted1  -- all walkable; passes OK     Nothing -> return converted1  -- no walkable tiles for filling the map-    Just cdefTileWalkable -> do  -- some tiles walkable, so ensure connectivity-      -- TODO: perhaps checking connectivity with BFS would be better,-      -- but it's still artibrary how we recover connectivity and we still-      -- need ltile not to break rooms (unless that's a good idea,-      -- but surely it's not for starship hull walls, vaults, fire pits, etc.,-      -- so perhaps all but impenetrable walls is game).+    Just pickPassable -> do  -- some tiles walkable, so ensure connectivity       let passes p@Point{..} array =             px >= 0 && px <= cxsize - 1             && py >= 0 && py <= cysize - 1-            && Tile.isWalkable cotile (array PointArray.! p)+            && Tile.isWalkable coTileSpeedup (array PointArray.! p)           -- If no point blocks on both ends, then I can eventually go           -- from bottom to top of the map and from left to right           -- unless there are disconnected areas inside rooms).@@ -70,188 +68,168 @@           yeven Point{..} = py `mod` 2 == 0           connect included blocks walkableTile array =             let g n c = if included n-                           && not (Tile.isWalkable cotile c)+                           && not (Tile.isEasyOpen coTileSpeedup c)                            && n `EM.notMember` ltile                            && blocks n array                         then walkableTile                         else c             in PointArray.imapA g array-      walkable2 <- cdefTileWalkable+      walkable2 <- pickPassable       let converted2 = connect xeven blocksHorizontal walkable2 converted1-      walkable3 <- cdefTileWalkable+      walkable3 <- pickPassable       let converted3 = connect yeven blocksVertical walkable3 converted2-      walkable4 <- cdefTileWalkable+      walkable4 <- pickPassable       let converted4 =             connect (not . xeven) blocksHorizontal walkable4 converted3-      walkable5 <- cdefTileWalkable+      walkable5 <- pickPassable       let converted5 =             connect (not . yeven) blocksVertical walkable5 converted4       return converted5 -placeStairs :: Kind.COps -> TileMap -> CaveKind -> [Point]-            -> Rnd Point-placeStairs Kind.COps{cotile} cmap CaveKind{..} ps = do-  let dist cmin l _ = all (\pos -> chessDist l pos > cmin) ps-  findPosTry 1000 cmap-    (\p t -> Tile.isWalkable cotile t-             && not (Tile.hasFeature cotile TK.NoActor t)-             && dist 0 p t)  -- can't overwrite stairs with other stairs-    [ dist cminStairDist-    , dist $ cminStairDist `div` 2-    , dist $ cminStairDist `div` 4-    , const $ Tile.hasFeature cotile TK.OftenActor-    , dist $ cminStairDist `div` 8-    ]---- | Create a level from a cave.-buildLevel :: Kind.COps -> Cave-           -> AbsDepth -> LevelId -> LevelId -> LevelId -> AbsDepth-           -> Int -> Maybe Bool-           -> Rnd Level-buildLevel cops@Kind.COps{ cotile=Kind.Ops{opick, okind}-                         , cocave=Kind.Ops{okind=cokind} }-           Cave{..} ldepth ln minD maxD totalDepth nstairUp escapeFeature = do-  let kc@CaveKind{..} = cokind dkind-      fitArea pos = inside pos . fromArea . qarea-      findLegend pos = maybe clegendLitTile qlegend-                       $ find (fitArea pos) dplaces-      hasEscape p = Tile.kindHasFeature (TK.Cause $ IK.Escape p)-      ascendable  = Tile.kindHasFeature $ TK.Cause (IK.Ascend 1)-      descendable = Tile.kindHasFeature $ TK.Cause (IK.Ascend (-1))-      nightCond kt = not (Tile.kindHasFeature TK.Clear kt)+buildTileMap :: Kind.COps -> Cave -> Rnd TileMap+buildTileMap cops@Kind.COps{ cotile=Kind.Ops{opick}+                           , cocave=Kind.Ops{okind=cokind} }+             Cave{dkind, dmap, dnight} = do+  let CaveKind{cxsize, cysize, cpassable, cdefTile} = cokind dkind+      nightCond kt = not (Tile.kindHasFeature TK.Walkable kt)                      || (if dnight then id else not)                            (Tile.kindHasFeature TK.Dark kt)-      dcond kt = (cpassable-                  || not (Tile.kindHasFeature TK.Walkable kt))-                 && nightCond kt       pickDefTile =-        fromMaybe (assert `failure` cdefTile) <$> opick cdefTile dcond-      wcond kt = Tile.kindHasFeature TK.Walkable kt-                 && nightCond kt-      mpickWalkable =+        fromMaybe (assert `failure` cdefTile) <$> opick cdefTile nightCond+      wcond kt = Tile.isEasyOpenKind kt && nightCond kt+      mpickPassable =         if cpassable         then Just              $ fromMaybe (assert `failure` cdefTile) <$> opick cdefTile wcond         else Nothing-  cmap <- convertTileMaps cops pickDefTile mpickWalkable cxsize cysize dmap-  -- We keep two-way stairs separately, in the last component.-  let makeStairs :: Bool -> Bool -> Bool-                 -> ( [(Point, Kind.Id TileKind)]-                    , [(Point, Kind.Id TileKind)]-                    , [(Point, Kind.Id TileKind)] )-                 -> Rnd ( [(Point, Kind.Id TileKind)]-                        , [(Point, Kind.Id TileKind)]-                        , [(Point, Kind.Id TileKind)] )-      makeStairs moveUp noAsc noDesc (up, down, upDown) =-        if (if moveUp then noAsc else noDesc) then-          return (up, down, upDown)-        else do-          let cond tk = (if moveUp then ascendable tk else descendable tk)-                        && (not noAsc || not (ascendable tk))-                        && (not noDesc || not (descendable tk))-              stairsCur = up ++ down ++ upDown-              posCur = nub $ sort $ map fst stairsCur-          spos <- placeStairs cops cmap kc posCur-          let legend = findLegend spos-          stairId <- fromMaybe (assert `failure` legend) <$> opick legend cond-          let st = (spos, stairId)-              asc = ascendable $ okind stairId-              desc = descendable $ okind stairId-          return $! case (asc, desc) of-                     (True, False) -> (st : up, down, upDown)-                     (False, True) -> (up, st : down, upDown)-                     (True, True)  -> (up, down, st : upDown)-                     (False, False) -> assert `failure` st-  (stairsUp1, stairsDown1, stairsUpDown1) <--    makeStairs False (ln == maxD) (ln == minD) ([], [], [])-  let !_A = assert (null stairsUp1) ()-  let nstairUpLeft = nstairUp - length stairsUpDown1-  (stairsUp2, stairsDown2, stairsUpDown2) <--    foldM (\sts _ -> makeStairs True (ln == maxD) (ln == minD) sts)-          (stairsUp1, stairsDown1, stairsUpDown1)-          [1 .. nstairUpLeft]-  -- If only a single tile of up-and-down stairs, add one more stairs down.-  (stairsUp, stairsDown, stairsUpDown) <--    if null (stairsUp2 ++ stairsDown2)-    then makeStairs False True (ln == minD)-           (stairsUp2, stairsDown2, stairsUpDown2)-    else return (stairsUp2, stairsDown2, stairsUpDown2)-  let stairsUpAndUpDown = stairsUp ++ stairsUpDown-  let !_A = assert (length stairsUpAndUpDown == nstairUp) ()-  let stairsTotal = stairsUpAndUpDown ++ stairsDown-      posTotal = nub $ sort $ map fst stairsTotal-  epos <- placeStairs cops cmap kc posTotal-  escape <- case escapeFeature of-              Nothing -> return []-              Just True -> do-                let legend = findLegend epos-                upEscape <- fmap (fromMaybe $ assert `failure` legend)-                            $ opick legend $ hasEscape 1-                return [(epos, upEscape)]-              Just False -> do-                let legend = findLegend epos-                downEscape <- fmap (fromMaybe $ assert `failure` legend)-                              $ opick legend $ hasEscape (-1)-                return [(epos, downEscape)]-  let exits = stairsTotal ++ escape-      ltile = cmap PointArray.// exits-      -- We reverse the order in down stairs, to minimize long stair chains.-      lstair = ( map fst $ stairsUp ++ stairsUpDown-               , map fst $ stairsUpDown ++ stairsDown )-  -- traceShow (ln, nstairUp, (stairsUp, stairsDown, stairsUpDown)) skip-  litemNum <- castDice ldepth totalDepth citemNum-  lsecret <- randomR (1, maxBound)  -- 0 means unknown-  return $! levelFromCaveKind cops kc ldepth ltile lstair-                              cactorCoeff cactorFreq litemNum citemFreq-                              lsecret (map fst escape)+      nwcond kt = not (Tile.kindHasFeature TK.Walkable kt) && nightCond kt+  areAllWalkable <- isNothing <$> opick cdefTile nwcond+  convertTileMaps cops areAllWalkable+                  pickDefTile mpickPassable cxsize cysize dmap +-- | Create a level from a cave.+buildLevel :: Kind.COps -> Int -> GroupName CaveKind+           -> Int -> AbsDepth -> [Point]+           -> Rnd (Level, [Point])+buildLevel cops@Kind.COps{cocave=Kind.Ops{okind=okind, opick}}+           ln genName minD totalDepth lstairPrev = do+  dkind <- fromMaybe (assert `failure` genName) <$> opick genName (const True)+  let kc = okind dkind+      -- Simple rule for now: level @ln@ has depth (difficulty) @abs ln@.+      ldepth = AbsDepth $ abs ln+  -- Any stairs coming from above are considered extra stairs+  -- and if they don't exceed @extraStairs@,+  -- the amount is filled up with single downstairs.+  -- If they do exceed @extraStairs@, some of them end here.+  extraStairs <- castDice ldepth totalDepth $ cextraStairs kc+  let (abandonedStairs, remainingStairsDown) =+        if ln == minD then (length lstairPrev, 0)+        else let double = min (length lstairPrev) extraStairs+                 single = max 0 $ extraStairs - double+             in (length lstairPrev - double, single)+      (lstairsSingleUp, lstairsDouble) = splitAt abandonedStairs lstairPrev+      lallUpStairs = lstairsDouble ++ lstairsSingleUp+      freq = toFreq ("buildLevel" <+> tshow ln) $ map swap $ cstairFreq kc+      addSingleDown :: [(Point, GroupName PlaceKind)] -> Int+                    -> Rnd [(Point, GroupName PlaceKind)]+      addSingleDown acc 0 = return acc+      addSingleDown acc k = do+        pos <- placeDownStairs kc $ lallUpStairs ++ map fst acc+        stairGroup <- frequency freq+        addSingleDown ((pos, stairGroup) : acc) (k - 1)+  stairsSingleDown <- addSingleDown [] remainingStairsDown+  let lstairsSingleDown = map fst stairsSingleDown+  fixedStairsDouble <- mapM (\p -> do+    stairGroup <- frequency freq+    return (p, stairGroup)) lstairsDouble+  fixedStairsUp <- mapM (\p -> do+    stairGroup <- frequency freq+    return (p, toGroupName $ tshow stairGroup <+> "up")) lstairsSingleUp+  let fixedStairsDown = map (\(p, t) ->+        (p, toGroupName $ tshow t <+> "down")) stairsSingleDown+      lallStairs = lallUpStairs ++ lstairsSingleDown+  fixedEscape <- case cescapeGroup kc of+                   Nothing -> return []+                   Just escapeGroup -> do+                     epos <- placeDownStairs kc lallStairs+                     return [(epos, escapeGroup)]+  let lescape = map fst fixedEscape+      fixedCenters = EM.fromList $+        fixedEscape ++ fixedStairsDouble ++ fixedStairsUp ++ fixedStairsDown+      posUp Point{..} = Point (px - 1) py+      posDn Point{..} = Point (px + 1) py+      lstair = ( map posUp $ lstairsSingleUp ++ lstairsDouble+               , map posDn $ lstairsDouble ++ lstairsSingleDown )+  dsecret <- randomR (1, maxBound)+  cave <- buildCave cops ldepth totalDepth dsecret dkind fixedCenters+  cmap <- buildTileMap cops cave+  litemNum <- castDice ldepth totalDepth $ citemNum kc+  let lvl = levelFromCaveKind cops kc ldepth cmap lstair litemNum lescape+                              (dnight cave)+  return (lvl, lstairsDouble ++ lstairsSingleDown)++-- | Places yet another staircase (or escape), taking into account only+-- the already existing stairs.+placeDownStairs :: CaveKind -> [Point] -> Rnd Point+placeDownStairs kc@CaveKind{..} ps = do+  let dist cmin p = all (\pos -> chessDist p pos > cmin) ps+      distProj p = all (\pos -> (px pos == px p+                                 || px pos > px p + 5+                                 || px pos < px p - 5)+                                && (py pos == py p+                                    || py pos > py p + 3+                                    || py pos < py p - 3))+                   $ ps ++ bootFixedCenters kc+      minDist = if length ps >= 3 then 0 else cminStairDist+      f p@Point{..} =+        if p `inside` (9, 8, cxsize - 10, cysize - 9)+        then if dist minDist p && distProj p then Just p else Nothing+        else let nx = if | px < 9 -> 4+                         | px > cxsize - 10 -> cxsize - 5+                         | otherwise -> px+                 ny = if | py < 8 -> 3+                         | py > cysize - 9 -> cysize - 4+                         | otherwise -> py+                 np = Point nx ny+             in if dist 0 np && distProj np then Just np else Nothing+  findPoint cxsize cysize f+ -- | Build rudimentary level from a cave kind. levelFromCaveKind :: Kind.COps                   -> CaveKind -> AbsDepth -> TileMap -> ([Point], [Point])-                  -> Int -> Freqs ItemKind -> Int -> Freqs ItemKind -> Int -> [Point]+                  -> Int -> [Point] -> Bool                   -> Level-levelFromCaveKind Kind.COps{cotile}-                  CaveKind{..}-                  ldepth ltile lstair lactorCoeff lactorFreq litemNum litemFreq-                  lsecret lescape =-  let lvl = Level-        { ldepth-        , lprio = EM.empty-        , lfloor = EM.empty-        , lembed = EM.empty  -- is populated inside $MonadServer$-        , ltile-        , lxsize = cxsize-        , lysize = cysize-        , lsmell = EM.empty-        , ldesc = cname-        , lstair-        , lseen = 0-        , lclear = 0  -- calculated below-        , ltime = timeZero-        , lactorCoeff-        , lactorFreq-        , litemNum-        , litemFreq-        , lsecret-        , lhidden = chidden-        , lescape-        }-      f n t | Tile.isExplorable cotile t = n + 1+levelFromCaveKind Kind.COps{coTileSpeedup}+                  CaveKind{ cactorCoeff=lactorCoeff+                          , cactorFreq=lactorFreq+                          , citemFreq=litemFreq+                          , ..+                          }+                  ldepth ltile lstair litemNum lescape lnight =+  let f n t | Tile.isExplorable coTileSpeedup t = n + 1             | otherwise = n-      lclear = PointArray.foldlA f 0 ltile-  in lvl {lclear}--findGenerator :: Kind.COps -> LevelId -> LevelId -> LevelId -> AbsDepth -> Int-              -> (GroupName CaveKind, Maybe Bool)-              -> Rnd Level-findGenerator cops ln minD maxD totalDepth nstairUp-              (genName, escapeFeature) = do-  let Kind.COps{cocave=Kind.Ops{opick}} = cops-  ci <- fromMaybe (assert `failure` genName) <$> opick genName (const True)-  -- A simple rule for now: level at level @ln@ has depth (difficulty) @abs ln@.-  let ldepth = AbsDepth $ abs $ fromEnum ln-  cave <- buildCave cops ldepth totalDepth ci-  buildLevel cops cave ldepth ln minD maxD totalDepth nstairUp escapeFeature+      lclear = PointArray.foldlA' f 0 ltile+  in Level+       { ldepth+       , lfloor = EM.empty+       , lembed = EM.empty  -- is populated inside $MonadServer$+       , lactor = EM.empty+       , ltile+       , lxsize = cxsize+       , lysize = cysize+       , lsmell = EM.empty+       , ldesc = cname+       , lstair+       , lseen = 0+       , lclear+       , ltime = timeZero+       , lactorCoeff+       , lactorFreq+       , litemNum+       , litemFreq+       , lescape+       , lnight+       }  -- | Freshly generated and not yet populated dungeon. data FreshDungeon = FreshDungeon@@ -266,19 +244,16 @@         case (IM.minViewWithKey caves, IM.maxViewWithKey caves) of           (Just ((s, _), _), Just ((e, _), _)) -> (s, e)           _ -> assert `failure` "no caves" `twith` caves-      (minId, maxId) = (toEnum minD, toEnum maxD)       freshTotalDepth = assert (signum minD == signum maxD)                         $ AbsDepth                         $ max 10 $ max (abs minD) (abs maxD)-  let gen :: (Int, [(LevelId, Level)]) -> (Int, (GroupName CaveKind, Maybe Bool))-          -> Rnd (Int, [(LevelId, Level)])-      gen (nstairUp, l) (n, caveTB) = do-        let ln = toEnum n-        lvl <- findGenerator cops ln minId maxId freshTotalDepth nstairUp caveTB-        -- nstairUp for the next level is nstairDown for the current level-        let nstairDown = length $ snd $ lstair lvl-        return (nstairDown, (ln, lvl) : l)-  (nstairUpLast, levels) <- foldM gen (0, []) $ reverse $ IM.assocs caves-  let !_A = assert (nstairUpLast == 0) ()+      buildLvl :: ([(LevelId, Level)], [Point])+               -> (Int, GroupName CaveKind)+               -> Rnd ([(LevelId, Level)], [Point])+      buildLvl (l, ldown) (n, genName) = do+        -- lstairUp for the next level is lstairDown for the current level+        (lvl, ldown2) <- buildLevel cops n genName minD freshTotalDepth ldown+        return ((toEnum n, lvl) : l, ldown2)+  (levels, _) <- foldlM' buildLvl ([], []) $ reverse $ IM.assocs caves   let freshDungeon = EM.fromList levels   return $! FreshDungeon{..}

Game/LambdaHack/Server/DungeonGen/Area.hs view

@@ -1,15 +1,25 @@ -- | Rectangular areas of levels and their basic operations. module Game.LambdaHack.Server.DungeonGen.Area-  ( Area, toArea, fromArea, trivialArea, grid, shrink+  ( Area, toArea, fromArea, trivialArea, isTrivialArea+  , grid, shrink, expand, sumAreas+  , SpecialArea(..)   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Data.Binary+import qualified Data.EnumMap.Strict as EM+import qualified Data.IntSet as IS +import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point+import Game.LambdaHack.Content.PlaceKind (PlaceKind)  -- | The type of areas. The bottom left and the top right points. data Area = Area !X !Y !X !Y-  deriving Show+  deriving (Show, Eq)  -- | Checks if it's an area with at least one field. toArea :: (X, Y, X, Y) -> Maybe Area@@ -23,21 +33,78 @@ trivialArea :: Point -> Area trivialArea (Point x y) = Area x y x y +isTrivialArea :: Area -> Bool+isTrivialArea (Area x0 y0 x1 y1) = x0 == x1 && y0 == y1++data SpecialArea =+    SpecialArea !Area+  | SpecialFixed !Point !(GroupName PlaceKind) !Area+  | SpecialMerged !SpecialArea !Point+  deriving Show+ -- | Divide uniformly a larger area into the given number of smaller areas -- overlapping at the edges.-grid :: (X, Y) -> Area -> [(Point, Area)]-grid (nx, ny) (Area x0 y0 x1 y1) =-  let xd = x1 - x0  -- not +1, because we need overlap-      yd = y1 - y0-  in [ (Point x y, Area (x0 + xd * x `div` nx)-                          (y0 + yd * y `div` ny)-                          (x0 + xd * (x + 1) `div` nx)-                          (y0 + yd * (y + 1) `div` ny))-     | x <- [0..nx-1], y <- [0..ny-1] ]+--+-- When a list of fixed centers (some important points inside)+-- of (non-overlapping) areas is given, incorporate those,+-- with as little disruption, as possible.+grid :: EM.EnumMap Point (GroupName PlaceKind) -> [Point] -> (X, Y) -> Area+     -> ((X, Y), EM.EnumMap Point SpecialArea)+grid fixedCenters boot (nx, ny) (Area x0 y0 x1 y1) =+  let f z0 z1 n prev (c1 : c2 : rest) =+        let len = c2 - c1 + 1+            cn = len * n `div` (z1 - z0 - 1)+        in if cn < 2+           then let mid1 = (c1 + c2) `div` 2+                    mid2 = (c1 + c2) `divUp` 2+                    mid = if mid1 - prev > 4 then mid1 else mid2+                in (prev, mid, Just c1) : f z0 z1 n mid (c2 : rest)+           else (prev, c1 + len `div` (2 * cn), Just c1)+                : [ ( c1 + len * (2 * z - 1) `div` (2 * cn)+                    , c1 + len * (2 * z + 1) `div` (2 * cn)+                    , Nothing )+                  | z <- [1 .. cn - 1] ]+                ++ f z0 z1 n (c1 + len * (2 * cn - 1) `div` (2 * cn))+                     (c2 : rest)+      f _ z1 _ prev [c1] = [(prev, z1, Just c1)]+      f _ _ _ _ [] = assert `failure` fixedCenters+      xcs = IS.toList $ IS.fromList $ map px $ EM.keys fixedCenters ++ boot+      xallCenters = zip [0..] $ f x0 x1 nx x0 xcs+      ycs = IS.toList $ IS.fromList $ map py $ EM.keys fixedCenters ++ boot+      yallCenters = zip [0..] $ f y0 y1 ny y0 ycs+  in ( (length xallCenters, length yallCenters)+     , EM.fromDistinctAscList+         [ ( Point x y+           , case (mcx, mcy) of+               (Just cx, Just cy) ->+                 case EM.lookup (Point cx cy) fixedCenters of+                   Nothing -> SpecialArea area+                   Just placeGroup ->+                     SpecialFixed (Point cx cy) placeGroup area+               _ -> SpecialArea area )+         | (y, (cy0, cy1, mcy)) <- yallCenters+         , (x, (cx0, cx1, mcx)) <- xallCenters+         , let area = Area cx0 cy0 cx1 cy1 ] ) --- | Enlarge (or shrink) the given area on all fours sides by the amount.+-- | Shrink the given area on all fours sides by the amount. shrink :: Area -> Maybe Area shrink (Area x0 y0 x1 y1) = toArea (x0 + 1, y0 + 1, x1 - 1, y1 - 1)++expand :: Area -> Area+expand (Area x0 y0 x1 y1) = Area (x0 - 1) (y0 - 1) (x1 + 1) (y1 + 1)++-- We assume the areas are adjacent.+sumAreas :: Area -> Area -> Area+sumAreas a@(Area x0 y0 x1 y1) a'@(Area x0' y0' x1' y1') =+  if | y1 == y0' -> assert (x0 == x0' && x1 == x1' `blame` (a, a')) $+       Area x0 y0 x1 y1'+     | y0 == y1' -> assert (x0 == x0' && x1 == x1' `blame` (a, a')) $+       Area x0' y0' x1' y1+     | x1 == x0' -> assert (y0 == y0' && y1 == y1' `blame` (a, a')) $+       Area x0 y0 x1' y1+     | x0 == x1' -> assert (y0 == y0' && y1 == y1' `blame` (a, a')) $+       Area x0' y0' x1 y1'+     | otherwise -> assert `failure` (a, a')  instance Binary Area where   put (Area x0 y0 x1 y1) = do

Game/LambdaHack/Server/DungeonGen/AreaRnd.hs view

@@ -1,20 +1,23 @@ -- | Operations on the 'Area' type that involve random numbers. module Game.LambdaHack.Server.DungeonGen.AreaRnd   ( -- * Picking points inside areas-    xyInArea, mkRoom, mkVoidRoom+    xyInArea, mkVoidRoom, mkRoom, mkFixed     -- * Choosing connections   , connectGrid, randomConnection     -- * Plotting corridors-  , Corridor, connectPlaces+  , HV(..), Corridor, connectPlaces   ) where -import Control.Exception.Assert.Sugar-import Data.Maybe-import qualified Data.Set as S+import Prelude () +import Game.LambdaHack.Common.Prelude++import qualified Data.EnumSet as ES+ import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.PlaceKind import Game.LambdaHack.Server.DungeonGen.Area  -- Picking random points inside areas@@ -27,6 +30,14 @@   ry <- randomR (y0, y1)   return $! Point rx ry +-- | Create a void room, i.e., a single point area within the designated area.+mkVoidRoom :: Area -> Rnd Area+mkVoidRoom area = do+  -- Pass corridors closer to the middle of the grid area, if possible.+  let core = fromMaybe area $ shrink area+  pxy <- xyInArea core+  return $! trivialArea pxy+ -- | Create a random room according to given parameters. mkRoom :: (X, Y)    -- ^ minimum size        -> (X, Y)    -- ^ maximum size@@ -34,8 +45,9 @@        -> Rnd Area mkRoom (xm, ym) (xM, yM) area = do   let (x0, y0, x1, y1) = fromArea area-  let !_A = assert (xm <= x1 - x0 + 1 && ym <= y1 - y0 + 1) ()-  let aW = (xm, ym, min xM (x1 - x0 + 1), min yM (y1 - y0 + 1))+      xspan = x1 - x0 + 1+      yspan = y1 - y0 + 1+      aW = (min xm xspan, min ym yspan, min xM xspan, min yM yspan)       areaW = fromMaybe (assert `failure` aW) $ toArea aW   Point xW yW <- xyInArea areaW  -- roll size   let a1 = (x0, y0, max x0 (x1 - xW + 1), max y0 (y1 - yW + 1))@@ -45,48 +57,59 @@       area3 = fromMaybe (assert `failure` a3) $ toArea a3   return $! area3 --- | Create a void room, i.e., a single point area within the designated area.-mkVoidRoom :: Area -> Rnd Area-mkVoidRoom area = do-  -- Pass corridors closer to the middle of the grid area, if possible.-  let core = fromMaybe area $ shrink area-  pxy <- xyInArea core-  return $! trivialArea pxy+-- Doesn't respect minimum sizes, because staircases are specified verbatim,+-- so can't be arbitrarily scaled up.+-- The size may be one more than what maximal size hint requests,+-- but this is safe (limited by area size) and makes up for the rigidity+-- of the fixed room sizes (e.g., that the size is always odd).+mkFixed :: (X, Y)    -- ^ maximum size+        -> Area      -- ^ the containing area, not the room itself+        -> Point     -- ^ the center point+        -> Area+mkFixed (xM, yM) area p@Point{..} =+  let (x0, y0, x1, y1) = fromArea area+      xradius = min ((xM + 1) `div` 2) $ min (px - x0) (x1 - px)+      yradius = min ((yM + 1) `div` 2) $ min (py - y0) (y1 - py)+      a = (px - xradius, py - yradius, px + xradius, py + yradius)+  in fromMaybe (assert `failure` (a, xM, yM, area, p)) $ toArea a  -- Choosing connections between areas in a grid  -- | Pick a subset of connections between adjacent areas within a grid until -- there is only one connected component in the graph of all areas.-connectGrid :: (X, Y) -> Rnd [(Point, Point)]-connectGrid (nx, ny) = do-  let unconnected = S.fromList [ Point x y-                               | x <- [0..nx-1], y <- [0..ny-1] ]+connectGrid :: ES.EnumSet Point -> (X, Y) -> Rnd [(Point, Point)]+connectGrid voidPlaces (nx, ny) = do+  let unconnected = ES.fromDistinctAscList [ Point x y+                                           | y <- [0..ny-1], x <- [0..nx-1] ]   -- Candidates are neighbours that are still unconnected. We start with   -- a random choice.-  rx <- randomR (0, nx-1)-  ry <- randomR (0, ny-1)-  let candidates = S.fromList [Point rx ry]-  connectGrid' (nx, ny) unconnected candidates []+  p <- oneOf $ ES.toList $ unconnected ES.\\ voidPlaces+  let candidates = ES.singleton p+  connectGrid' voidPlaces (nx, ny) unconnected candidates [] -connectGrid' :: (X, Y) -> S.Set Point -> S.Set Point+connectGrid' :: ES.EnumSet Point -> (X, Y)+             -> ES.EnumSet Point -> ES.EnumSet Point              -> [(Point, Point)]              -> Rnd [(Point, Point)]-connectGrid' (nx, ny) unconnected candidates acc-  | S.null candidates = return $! map sortPoint acc+connectGrid' voidPlaces (nx, ny) unconnected candidates !acc+  | unconnected `ES.isSubsetOf` voidPlaces = return acc   | otherwise = do-      c <- oneOf (S.toList candidates)+      let candidatesBest = candidates ES.\\ voidPlaces+      c <- oneOf $ ES.toList $ if ES.null candidatesBest+                               then candidates+                               else candidatesBest       -- potential new candidates:-      let ns = S.fromList $ vicinityCardinal nx ny c-          nu = S.delete c unconnected  -- new unconnected+      let ns = ES.fromList $ vicinityCardinal nx ny c+          nu = ES.delete c unconnected  -- new unconnected           -- (new candidates, potential connections):-          (nc, ds) = S.partition (`S.member` nu) ns-      new <- if S.null ds+          (nc, ds) = ES.partition (`ES.member` nu) ns+      new <- if ES.null ds              then return id              else do-               d <- oneOf (S.toList ds)-               return ((c, d) :)-      connectGrid' (nx, ny) nu-        (S.delete c (candidates `S.union` nc)) (new acc)+               d <- oneOf (ES.toList ds)+               return (sortPoint (c, d) :)+      connectGrid' voidPlaces (nx, ny) nu+        (ES.delete c (candidates `ES.union` nc)) (new acc)  -- | Sort the sequence of two points, in the derived lexicographic order. sortPoint :: (Point, Point) -> (Point, Point)@@ -96,8 +119,7 @@ -- | Pick a single random connection between adjacent areas within a grid. randomConnection :: (X, Y) -> Rnd (Point, Point) randomConnection (nx, ny) =-  assert (nx > 1 && ny > 0 || nx > 0 && ny > 1 `blame` "wrong connection"-                                               `twith` (nx, ny)) $ do+  assert (nx > 1 && ny > 0 || nx > 0 && ny > 1 `blame` (nx, ny)) $ do   rb <- oneOf [False, True]   if rb || ny <= 1     then do@@ -113,73 +135,112 @@  -- | The choice of horizontal and vertical orientation. data HV = Horiz | Vert+  deriving Eq  -- | The coordinates of consecutive fields of a corridor. type Corridor = [Point]  -- | Create a corridor, either horizontal or vertical, with -- a possible intermediate part that is in the opposite direction.+-- There might not always exist a good intermediate point+-- if the places are allowed to be close together+-- and then we let the intermediate part degenerate. mkCorridor :: HV            -- ^ orientation of the starting section-           -> Point       -- ^ starting point-           -> Point       -- ^ ending point+           -> Point         -- ^ starting point+           -> Bool          -- ^ starting is inside @FGround@ or @FFloor@+           -> Point         -- ^ ending point+           -> Bool          -- ^ ending is inside @FGround@ or @FFloor@            -> Area          -- ^ the area containing the intermediate point            -> Rnd Corridor  -- ^ straight sections of the corridor-mkCorridor hv (Point x0 y0) (Point x1 y1) b = do-  Point rx ry <- xyInArea b+mkCorridor hv (Point x0 y0) p0floor (Point x1 y1) p1floor area = do+  Point rxRaw ryRaw <- xyInArea area+  let (sx0, sy0, sx1, sy1) = fromArea area+      -- Avoid corridors that run along @FGround@ or @FFloor@ fence.+      rx = if | rxRaw == sx0 + 1 && p0floor -> sx0+              | rxRaw == sx1 - 1 && p1floor -> sx1+              | otherwise -> rxRaw+      ry = if | ryRaw == sy0 + 1 && p0floor -> sy0+              | ryRaw == sy1 - 1 && p1floor -> sy1+              | otherwise -> ryRaw   return $! map (uncurry Point) $ case hv of     Horiz -> [(x0, y0), (rx, y0), (rx, y1), (x1, y1)]     Vert  -> [(x0, y0), (x0, ry), (x1, ry), (x1, y1)]  -- | Try to connect two interiors of places with a corridor.--- Choose entrances at least 4 or 3 tiles distant from the edges, if the place--- is big enough. Note that with @pfence == FNone@, the area considered+-- Choose entrances some steps away from the edges, if the place+-- is big enough. Note that with @pfence == FNone@, the inner area considered -- is the strict interior of the place, without the outermost tiles.-connectPlaces :: (Area, Area) -> (Area, Area) -> Rnd Corridor-connectPlaces (sa, so) (ta, to) = do-  let (_, _, sx1, sy1) = fromArea sa-      (_, _, sox1, soy1) = fromArea so-      (tx0, ty0, _, _) = fromArea ta-      (tox0, toy0, _, _) = fromArea to-  let !_A = assert (sx1 <= tx0  || sy1 <= ty0  `blame` (sa, ta)) ()-  let !_A = assert (sx1 <= sox1 || sy1 <= soy1 `blame` (sa, so)) ()-  let !_A = assert (tx0 >= tox0 || ty0 >= toy0 `blame` (ta, to)) ()-  let trim area =+--+-- The corridor connects (touches) the inner areas and the turning point+-- of the corridor (if any) is outside of the outer areas+-- and inside the grid areas.+connectPlaces :: (Area, Fence, Area) -> (Area, Fence, Area)+              -> Rnd (Maybe Corridor)+connectPlaces (_, _, sg) (_, _, tg) | sg == tg = return Nothing+connectPlaces s3@(sqarea, spfence, sg) t3@(tqarea, tpfence, tg) = do+  let (sa, so) = borderPlace sqarea spfence+      (ta, to) = borderPlace tqarea tpfence+      trim area =         let (x0, y0, x1, y1) = fromArea area-            trim4 (v0, v1) | v1 - v0 < 6 = (v0, v1)-                           | v1 - v0 < 8 = (v0 + 3, v1 - 3)-                           | otherwise = (v0 + 4, v1 - 4)-            (nx0, nx1) = trim4 (x0, x1)-            (ny0, ny1) = trim4 (y0, y1)-        in fromMaybe (assert `failure` area) $ toArea (nx0, ny0, nx1, ny1)-  Point sx sy <- xyInArea $ trim so-  Point tx ty <- xyInArea $ trim to-  let hva sarea tarea = do-        let (_, _, zsx1, zsy1) = fromArea sarea-            (ztx0, zty0, _, _) = fromArea tarea-            xa = (zsx1+2, min sy ty, ztx0-2, max sy ty)-            ya = (min sx tx, zsy1+2, max sx tx, zty0-2)-            xya = (zsx1+2, zsy1+2, ztx0-2, zty0-2)-        case toArea xya of-          Just xyarea -> fmap (\hv -> (hv, Just xyarea)) (oneOf [Horiz, Vert])-          Nothing ->-            case toArea xa of-              Just xarea -> return (Horiz, Just xarea)-              Nothing -> return (Vert, toArea ya) -- Vertical bias.-  (hvOuter, areaOuter) <- hva so to-  (hv, area) <- case areaOuter of-    Just arenaOuter -> return (hvOuter, arenaOuter)-    Nothing -> do-      -- TODO: let mkCorridor only pick points on the floor fence-      (hvInner, aInner) <- hva sa ta-      let yell = assert `failure` (sa, so, ta, to, areaOuter, aInner)-          areaInner = fromMaybe yell aInner-      return (hvInner, areaInner)-  -- We cross width one places completely with the corridor, for void-  -- rooms and others (e.g., one-tile wall room then becomes a door, etc.).-  let (p0, p1) = case hv of-        Horiz -> (Point sox1 sy, Point tox0 ty)-        Vert  -> (Point sx soy1, Point tx toy0)-  -- The condition imposed on mkCorridor are tricky: there might not always-  -- exist a good intermediate point if the places are allowed to be close-  -- together and then we let the intermediate part degenerate.-  mkCorridor hv p0 p1 area+            dx = case (x1 - x0) `div` 2 of+              0 -> 0+              1 -> 1+              2 -> 1+              3 -> 1+              _ -> 3+            dy = case (y1 - y0) `div` 2 of+              0 -> 0+              1 -> 1+              2 -> 1+              3 -> 1+              _ -> 3+        in fromMaybe (assert `failure` (area, s3, t3))+           $ toArea (x0 + dx, y0 + dy, x1 - dx, y1 - dy)+  Point sx sy <- xyInArea $ trim sa+  Point tx ty <- xyInArea $ trim ta+  -- If the place (e.g., void place) is trivial (1-tile wide, no fence),+  -- overwrite it with corridor. The place may not even be built (e.g., void)+  -- and the overwrite ensures connections through it are not broken.+  let (_, _, sax1Raw, say1Raw) = fromArea sa  -- inner area+      strivial = isTrivialArea sqarea && spfence == FNone+      (sax1, say1) = if strivial+                     then (sax1Raw - 1, say1Raw - 1)+                     else (sax1Raw, say1Raw)+      (tax0Raw, tay0Raw, _, _) = fromArea ta+      ttrivial = isTrivialArea tqarea && tpfence == FNone+      (tax0, tay0) = if ttrivial+                     then (tax0Raw + 1, tay0Raw + 1)+                     else (tax0Raw, tay0Raw)+      (_, _, sox1, soy1) = fromArea so  -- outer area+      (tox0, toy0, _, _) = fromArea to+      (sgx0, sgy0, sgx1, sgy1) = fromArea sg  -- grid area+      (tgx0, tgy0, tgx1, tgy1) = fromArea tg+      (hv, area, p0, p1)+        | sgx1 == tgx0 =+          let x0 = if sgy0 <= ty && ty <= sgy1 then sox1 + 1 else sgx1+              x1 = if tgy0 <= sy && sy <= tgy1 then tox0 - 1 else sgx1+          in case toArea (x0, min sy ty, x1, max sy ty) of+            Just a -> (Horiz, a, Point (sax1 + 1) sy, Point (tax0 - 1) ty)+            Nothing -> assert `failure` (sx, sy, tx, ty, s3, t3)+        | otherwise = assert (sgy1 == tgy0) $+          let y0 = if sgx0 <= tx && tx <= sgx1 then soy1 + 1 else sgy1+              y1 = if tgx0 <= sx && sx <= tgx1 then toy0 - 1 else sgy1+          in case toArea (min sx tx, y0, max sx tx, y1) of+            Just a -> (Vert, a, Point sx (say1 + 1), Point tx (tay0 - 1))+            Nothing -> assert `failure` (sx, sy, tx, ty, s3, t3)+      nin p = not $ p `inside` fromArea sa || p `inside` fromArea ta+      !_A = assert (strivial || ttrivial+                    || allB nin [p0, p1]`blame` (sx, sy, tx, ty, s3, t3)) ()+  cor <- mkCorridor hv p0 (sa == so) p1 (ta == to) area+  let !_A2 = assert (strivial || ttrivial+                     || allB nin cor `blame` (sx, sy, tx, ty, s3, t3)) ()+  return $ Just cor++borderPlace :: Area -> Fence -> (Area, Area)+borderPlace qarea pfence = case pfence of+  FWall -> (qarea, expand qarea)+  FFloor  -> (qarea, qarea)+  FGround -> (qarea, qarea)+  FNone -> case shrink qarea of+    Nothing -> (qarea, qarea)+    Just sr -> (sr, qarea)

Game/LambdaHack/Server/DungeonGen/Cave.hs view

@@ -1,20 +1,19 @@ -- | Generation of caves (not yet inhabited dungeon levels) from cave kinds. module Game.LambdaHack.Server.DungeonGen.Cave-  ( Cave(..), buildCave+  ( Cave(..), bootFixedCenters, buildCave   ) where -import Control.Applicative-import Control.Arrow ((&&&))-import Control.Exception.Assert.Sugar-import Control.Monad+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES import Data.Key (mapWithKeyM)-import Data.List-import qualified Data.Map.Strict as M-import Data.Maybe  import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import qualified Game.LambdaHack.Common.Tile as Tile@@ -29,12 +28,16 @@ -- | The type of caves (not yet inhabited dungeon levels). data Cave = Cave   { dkind   :: !(Kind.Id CaveKind)  -- ^ the kind of the cave+  , dsecret :: !Int                 -- ^ secret tile seed   , dmap    :: !TileMapEM           -- ^ tile kinds in the cave   , dplaces :: ![Place]             -- ^ places generated in the cave   , dnight  :: !Bool                -- ^ whether the cave is dark   }   deriving Show +bootFixedCenters :: CaveKind -> [Point]+bootFixedCenters CaveKind{..} = [Point 4 3, Point (cxsize - 5) (cysize - 4)]+ {- Rogue cave is generated by an algorithm inspired by the original Rogue, as follows:@@ -57,19 +60,21 @@     on the grid is connected, and a few more might be. It is not sufficient     to always connect all adjacent rooms. -}--- TODO: fix identifier naming and split, after the code grows some more -- | Cave generation by an algorithm inspired by the original Rogue, buildCave :: Kind.COps         -- ^ content definitions           -> AbsDepth          -- ^ depth of the level to generate           -> AbsDepth          -- ^ absolute depth+          -> Int               -- ^ secret tile seed           -> Kind.Id CaveKind  -- ^ cave kind to use for generation+          -> EM.EnumMap Point (GroupName PlaceKind)  -- ^ pos of stairs, etc.           -> Rnd Cave buildCave cops@Kind.COps{ cotile=cotile@Kind.Ops{opick}                         , cocave=Kind.Ops{okind}-                        , coplace=Kind.Ops{okind=pokind} }-          ldepth totalDepth dkind = do+                        , coplace=Kind.Ops{okind=pokind}+                        , coTileSpeedup }+          ldepth totalDepth dsecret dkind fixedCenters = do   let kc@CaveKind{..} = okind dkind-  lgrid@(gx, gy) <- castDiceXY ldepth totalDepth cgrid+  lgrid' <- castDiceXY ldepth totalDepth cgrid   -- Make sure that in caves not filled with rock, there is a passage   -- across the cave, even if a single room blocks most of the cave.   -- Also, ensure fancy outer fences are not obstructed by room walls.@@ -77,106 +82,225 @@                  $ toArea (0, 0, cxsize - 1, cysize - 1)       subFullArea = fromMaybe (assert `failure` kc)                     $ toArea (1, 1, cxsize - 2, cysize - 2)-      area | gx * gy == 1-             || couterFenceTile /= "basic outer fence" = subFullArea-           | otherwise = fullArea-      gs = grid lgrid area-  (addedConnects, voidPlaces) <--    if gx * gy > 1 then do-       let fractionOfPlaces r = round $ r * fromIntegral (gx * gy)-           cauxNum = fractionOfPlaces cauxConnects-       addedC <- replicateM cauxNum (randomConnection lgrid)-       let gridArea = fromMaybe (assert `failure` lgrid)-                      $ toArea (0, 0, gx - 1, gy - 1)-           voidNum = fractionOfPlaces cmaxVoid-       voidPl <- replicateM voidNum $ xyInArea gridArea  -- repetitions are OK-       return (addedC, voidPl)-    else return ([], [])-  minPlaceSize <- castDiceXY ldepth totalDepth cminPlaceSize-  maxPlaceSize <- castDiceXY ldepth totalDepth cmaxPlaceSize-  places0 <- mapM (\ (i, r) -> do-                     -- Reserved for corridors and the global fence.-                     let innerArea = fromMaybe (assert `failure` (i, r))-                                     $ shrink r-                     r' <- if i `elem` voidPlaces-                           then Left <$> mkVoidRoom innerArea-                           else Right <$> mkRoom minPlaceSize-                                                    maxPlaceSize innerArea-                     return (i, r')) gs-  fence <- buildFenceRnd cops couterFenceTile subFullArea-  dnight <- chanceDice ldepth totalDepth cnightChance   darkCorTile <- fromMaybe (assert `failure` cdarkCorTile)                  <$> opick cdarkCorTile (const True)   litCorTile <- fromMaybe (assert `failure` clitCorTile)                 <$> opick clitCorTile (const True)-  let pickedCorTile = if dnight then darkCorTile else litCorTile-      addPl (m, pls, qls) (i, Left r) = return (m, pls, (i, Left r) : qls)-      addPl (m, pls, qls) (i, Right r) = do-        (tmap, place) <--          buildPlace cops kc dnight darkCorTile litCorTile ldepth totalDepth r-        return (EM.union tmap m, place : pls, (i, Right (r, place)) : qls)-  (lplaces, dplaces, qplaces0) <- foldM addPl (fence, [], []) places0-  connects <- connectGrid lgrid-  let allConnects = connects `union` addedConnects  -- no duplicates-      qplaces = M.fromList qplaces0-  cs <- mapM (\(p0, p1) -> do-                let shrinkPlace (r, Place{qkind}) =-                      case shrink r of-                        Nothing -> (r, r)  -- FNone place of x and/or y size 1-                        Just sr ->-                          if pfence (pokind qkind) `elem` [FFloor, FGround]-                          then-                            -- Avoid corridors touching the floor fence,-                            -- but let them merge with the fence.-                            case shrink sr of-                              Nothing -> (sr, r)-                              Just mergeArea -> (mergeArea, r)-                          else (sr, sr)-                    shrinkForFence = either (id &&& id) shrinkPlace-                    rr0 = shrinkForFence $ qplaces M.! p0-                    rr1 = shrinkForFence $ qplaces M.! p1-                connectPlaces rr0 rr1) allConnects-  let lcorridors = EM.unions (map (digCorridors pickedCorTile) cs)-      lm = EM.union lplaces lcorridors-  -- Convert wall openings into doors, possibly.-  let f pos (t, cor) = do-        -- Openings have a certain chance to be doors-        -- and doors have a certain chance to be open.-        rd <- chance cdoorChance-        if not rd then  -- opening kept-          if Tile.isLit cotile cor then return cor-          else do-            -- If any adjacent room tile is lit, make the opening lit.-            let roomTileLit p =-                  case EM.lookup p lplaces of-                    Nothing -> False-                    Just tile -> Tile.isLit cotile tile-                vic = vicinity cxsize cysize pos-            if any roomTileLit vic-              then return litCorTile-              else return cor-        else do-          ro <- chance copenChance-          doorClosedId <- Tile.revealAs cotile t-          if not ro then return $! doorClosedId-          else do-            doorOpenId <- Tile.openTo cotile doorClosedId-            return $! doorOpenId-      mergeCor _ pl cor =-        let hidden = Tile.hideAs cotile pl-        in if hidden == pl then Nothing else Just (hidden, cor)-      intersectionCombine combine =-        EM.mergeWithKey combine (const EM.empty) (const EM.empty)-      interCor = intersectionCombine mergeCor lplaces lcorridors-  doorMap <- mapWithKeyM f interCor-  let dmap = EM.union doorMap lm-      cave = Cave-        { dkind-        , dmap-        , dplaces-        , dnight-        }-  return $! cave+  dnight <- chanceDice ldepth totalDepth cnightChance+  let createPlaces lgr' = do+        let area | couterFenceTile /= "basic outer fence" = subFullArea+                 | otherwise = fullArea+            (lgr@(gx, gy), gs) =+              grid fixedCenters (bootFixedCenters kc) lgr' area+        minPlaceSize <- castDiceXY ldepth totalDepth cminPlaceSize+        maxPlaceSize <- castDiceXY ldepth totalDepth cmaxPlaceSize+        let mergeFixed :: EM.EnumMap Point SpecialArea+                       -> (Point, SpecialArea)+                       -> EM.EnumMap Point SpecialArea+            mergeFixed !gs0 (!i, !special) =+              let mergeSpecial ar p2 f =+                    case EM.lookup p2 gs0 of+                      Just (SpecialArea ar2) ->+                        let aSum = sumAreas ar ar2+                            sp = SpecialMerged (f aSum) p2+                        in EM.insert i sp $ EM.delete p2 gs0+                      _ -> gs0+                  mergable :: X -> Y -> Maybe HV+                  mergable x y = case EM.lookup (Point x y) gs0 of+                    Just (SpecialArea ar) ->+                      let (x0, y0, x1, y1) = fromArea ar+                          isFixed p = case gs EM.! p of+                            SpecialFixed{} -> True+                            _ -> False+                      in if | any isFixed+                              $ vicinityCardinal gx gy (Point x y) -> Nothing+                              -- Bias: prefer extending vertically.+                            | y1 - y0 - 1 < snd minPlaceSize -> Just Vert+                            | x1 - x0 - 1 < fst minPlaceSize -> Just Horiz+                            | otherwise -> Nothing+                    _ -> Nothing+              in case special of+                SpecialArea ar -> case mergable (px i) (py i) of+                  Nothing -> gs0+                  Just hv -> case hv of+                    -- Bias; vertical minimal sizes are smaller.+                    Vert | py i - 1 >= 0+                           && mergable (px i) (py i - 1) == Just Vert ->+                           mergeSpecial ar i{py = py i - 1} SpecialArea+                    Vert | py i + 1 < gy+                           && mergable (px i) (py i + 1) == Just Vert ->+                           mergeSpecial ar i{py = py i + 1} SpecialArea+                    Horiz | px i - 1 >= 0+                            && mergable (px i - 1) (py i) == Just Horiz ->+                            mergeSpecial ar i{px = px i - 1} SpecialArea+                    Horiz | px i + 1 < gx+                            && mergable (px i + 1) (py i) == Just Horiz ->+                            mergeSpecial ar i{px = px i + 1} SpecialArea+                    _ -> gs0+                SpecialFixed p placeGroup ar ->+                  let (x0, y0, x1, y1) = fromArea ar+                      d = 3+                      vics = [ i {py = py i - 1}+                             | py p - y0 < d && py i - 1 >= 0 ]+                             ++ [ i {py = py i + 1}+                                | y1 - py p < d && py i + 1 < gy ]+                             ++ [ i {px = px i - 1}+                                | px p - x0 < d + 1 && px i - 1 >= 0 ]+                             ++ [ i {px = px i + 1}+                                | x1 - px p < d + 1 && px i + 1 < gx ]+                  in case vics of+                    [p2] -> mergeSpecial ar p2 (SpecialFixed p placeGroup)+                    _ -> gs0+                SpecialMerged{} -> assert `failure` (gs, gs0, i)+            gs2 = foldl' mergeFixed gs $ EM.assocs gs+        voidPlaces <- do+          let gridArea = fromMaybe (assert `failure` lgr)+                         $ toArea (0, 0, gx - 1, gy - 1)+              voidNum = round $ cmaxVoid * fromIntegral (EM.size gs2)+              isOrdinaryArea p = case p `EM.lookup` gs2 of+                Just SpecialArea{} -> True+                _ -> False+          reps <- replicateM voidNum (xyInArea gridArea)+                    -- repetitions are OK; variance is low anyway+          return $! ES.fromList $ filter isOrdinaryArea reps+        let decidePlace :: Bool+                        -> ( TileMapEM, [Place]+                           , EM.EnumMap Point (Area, Fence, Area) )+                        -> (Point, SpecialArea)+                        -> Rnd ( TileMapEM, [Place]+                               , EM.EnumMap Point (Area, Fence, Area) )+            decidePlace noVoid (!m, !pls, !qls) (!i, !special) =+              case special of+                SpecialArea ar -> do+                  -- Reserved for corridors and the global fence.+                  let innerArea = fromMaybe (assert `failure` (i, ar))+                                  $ shrink ar+                      !_A0 = shrink innerArea+                      !_A1 = assert (isJust _A0 `blame` (innerArea, gs2)) ()+                  if not noVoid && i `ES.member` voidPlaces+                  then do+                    r <- mkVoidRoom innerArea+                    return (m, pls, EM.insert i (r, FNone, ar) qls)+                  else do+                    r <- mkRoom minPlaceSize maxPlaceSize innerArea+                    (tmap, place) <-+                      buildPlace cops kc dnight darkCorTile litCorTile+                                 ldepth totalDepth dsecret r Nothing+                    let fence = pfence $ pokind $ qkind place+                    return ( EM.union tmap m+                           , place : pls+                           , EM.insert i (qarea place, fence, ar) qls )+                SpecialFixed p@Point{..} placeGroup ar -> do+                  -- Reserved for corridors and the global fence.+                  let innerArea = fromMaybe (assert `failure` (i, ar))+                                  $ shrink ar+                      !_A0 = shrink innerArea+                      !_A1 = assert (isJust _A0 `blame` (innerArea, gs2)) ()+                      !_A2 = assert (p `inside` fromArea (fromJust _A0)+                                     `blame` (p, innerArea, fixedCenters)) ()+                      r = mkFixed maxPlaceSize innerArea p+                      !_A3 = assert (isJust (shrink r)+                                     `blame` ( r, p, innerArea, ar+                                             , gs2, qls, fixedCenters )) ()+                  (tmap, place) <-+                    buildPlace cops kc dnight darkCorTile litCorTile+                               ldepth totalDepth dsecret r (Just placeGroup)+                  let fence = pfence $ pokind $ qkind place+                  return ( EM.union tmap m+                         , place : pls+                         , EM.insert i (qarea place, fence, ar) qls )+                SpecialMerged sp p2 -> do+                  (lplaces, dplaces, qplaces) <-+                    decidePlace True (m, pls, qls) (i, sp)+                  return ( lplaces, dplaces+                         , EM.insert p2 (qplaces EM.! i) qplaces )+        places <- foldlM' (decidePlace False) (EM.empty, [], EM.empty)+                  $ EM.assocs gs2+        return (voidPlaces, lgr, places)+  (voidPlaces, lgrid, (lplaces, dplaces, qplaces)) <- createPlaces lgrid'+  let lcorridorsFun lgr = do+        connects <- connectGrid voidPlaces lgr+        addedConnects <- do+          let cauxNum =+                round $ cauxConnects * fromIntegral (fst lgr * snd lgrid)+          cns <- nub . sort <$> replicateM cauxNum (randomConnection lgr)+          -- This allows connections through a single void room,+          -- if a non-void room on both ends.+          let notDeadEnd (p, q) =+                if | p `ES.member` voidPlaces ->+                     q `ES.notMember` voidPlaces && sndInCns p+                   | q `ES.member` voidPlaces -> fstInCns q+                   | otherwise -> True+              sndInCns p = any (\(p0, q0) ->+                q0 == p && p0 `ES.notMember` voidPlaces) cns+              fstInCns q = any (\(p0, q0) ->+                p0 == q && q0 `ES.notMember` voidPlaces) cns+          return $! filter notDeadEnd cns+        let allConnects = connects `union` addedConnects+            connectPos :: (Point, Point) -> Rnd (Maybe Corridor)+            connectPos (p0, p1) =+              connectPlaces (qplaces EM.! p0) (qplaces EM.! p1)+        cs <- catMaybes <$> mapM connectPos allConnects+        let pickedCorTile = if dnight then darkCorTile else litCorTile+        return $! EM.unions (map (digCorridors pickedCorTile) cs)+  lcorridors <- lcorridorsFun lgrid+  let doorMapFun lpl lcor = do+        -- The hacks below are instead of unionWithKeyM, which is costly.+        let mergeCor _ pl cor = if Tile.isWalkable coTileSpeedup pl+                                then Nothing  -- tile already open+                                else Just (Tile.buildAs cotile pl, cor)+            intersectionWithKeyMaybe combine =+              EM.mergeWithKey combine (const EM.empty) (const EM.empty)+            interCor = intersectionWithKeyMaybe mergeCor lpl lcor  -- fast+        mapWithKeyM (pickOpening cops kc lplaces litCorTile dsecret)+                    interCor  -- very small+  doorMap <- doorMapFun lplaces lcorridors+  fence <- buildFenceRnd cops couterFenceTile subFullArea+  -- The obscured tile, e.g., scratched wall, stays on the server forever,+  -- only the suspect variant on client gets replaced by this upon searching.+  let obscure p t = if isChancePos chidden dsecret p && likelySecret p+                    then Tile.obscureAs cotile $ Tile.buildAs cotile t+                    else return t+      likelySecret Point{..} = px > 2 && px < cxsize - 3+                               && py > 2 && py < cysize - 3+      umap = EM.unions [doorMap, lplaces, lcorridors, fence]  -- order matters+  dmap <- mapWithKeyM obscure umap+  return $! Cave {dkind, dsecret, dmap, dplaces, dnight}++pickOpening :: Kind.COps -> CaveKind -> TileMapEM -> Kind.Id TileKind+            -> Int -> Point -> (Kind.Id TileKind, Kind.Id TileKind)+            -> Rnd (Kind.Id TileKind)+pickOpening Kind.COps{cotile, coTileSpeedup}+            CaveKind{cxsize, cysize, cdoorChance, copenChance, chidden}+            lplaces litCorTile dsecret+            pos (hidden, cor) = do+  let nicerCorridor =+        if Tile.isLit coTileSpeedup cor then cor+        else -- If any cardinally adjacent room tile lit, make the opening lit.+             let roomTileLit p =+                   case EM.lookup p lplaces of+                     Nothing -> False+                     Just tile -> Tile.isLit coTileSpeedup tile+                 vic = vicinityCardinal cxsize cysize pos+             in if any roomTileLit vic then litCorTile else cor+  -- Openings have a certain chance to be doors and doors have a certain+  -- chance to be open.+  rd <- chance cdoorChance+  if rd then do+    doorTrappedId <- Tile.revealAs cotile hidden+    -- Not all solid tiles can hide a door, so @doorTrappedId@ may in fact+    -- not be a door at all, hence the check.+    if Tile.isDoor coTileSpeedup doorTrappedId then do  -- door created+      ro <- chance copenChance+      if ro+      then Tile.openTo cotile doorTrappedId+      else if isChancePos chidden dsecret pos+           then return $! doorTrappedId  -- will become hidden+           else do+             doorOpenId <- Tile.openTo cotile doorTrappedId+             Tile.closeTo cotile doorOpenId+    else return $! doorTrappedId  -- assume this is what content enforces+  else return $! nicerCorridor  digCorridors :: Kind.Id TileKind -> Corridor -> TileMapEM digCorridors tile (p1:p2:ps) =

Game/LambdaHack/Server/DungeonGen/Place.hs view

@@ -1,32 +1,33 @@ {-# LANGUAGE RankNTypes #-} -- | Generation of places from place kinds. module Game.LambdaHack.Server.DungeonGen.Place-  ( TileMapEM, Place(..), placeCheck, buildFenceRnd, buildPlace+  ( TileMapEM, Place(..), isChancePos, placeCheck, buildFenceRnd, buildPlace   ) where -import Control.Applicative-import Control.Exception.Assert.Sugar+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Data.Binary+import qualified Data.Bits as Bits import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES-import Data.Maybe import qualified Data.Text as T  import Game.LambdaHack.Common.Frequency import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random+import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Content.CaveKind import Game.LambdaHack.Content.PlaceKind import Game.LambdaHack.Content.TileKind (TileKind) import qualified Game.LambdaHack.Content.TileKind as TK import Game.LambdaHack.Server.DungeonGen.Area --- TODO: use more, rewrite as needed, document each field.--- | The parameters of a place. Most are immutable and set+-- | The parameters of a place. All are immutable and set -- at the time when a place is generated. data Place = Place   { qkind    :: !(Kind.Id PlaceKind)@@ -52,8 +53,8 @@ placeCheck :: Area       -- ^ the area to fill            -> PlaceKind  -- ^ the place kind to construct            -> Bool-placeCheck r PlaceKind{..} =-  case interiorArea pfence r of+placeCheck r pk@PlaceKind{..} =+  case interiorArea pk r of     Nothing -> False     Just area ->       let (x0, y0, x1, y1) = fromArea area@@ -69,19 +70,36 @@                       wholeOverlapped dy dycorner         CStretch   -> largeEnough         CReflect   -> largeEnough-        CVerbatim  -> dx >= dxcorner && dy >= dycorner+        CVerbatim  -> True+        CMirror    -> True  -- | Calculate interior room area according to fence type, based on the -- total area for the room and it's fence. This is used for checking -- if the room fits in the area, for digging up the place and the fence -- and for deciding if the room is dark or lit later in the dungeon--- generation process (e.g., for stairs).-interiorArea :: Fence -> Area -> Maybe Area-interiorArea fence r = case fence of-  FWall   -> shrink r-  FFloor  -> shrink r-  FGround -> shrink r-  FNone   -> Just r+-- generation process.+interiorArea :: PlaceKind -> Area -> Maybe Area+interiorArea kr r =+  let requiredForFence = case pfence kr of+        FWall   -> 1+        FFloor  -> 1+        FGround -> 1+        FNone   -> 0+  in if pcover kr `elem` [CVerbatim, CMirror]+     then let (x0, y0, x1, y1) = fromArea r+              dx = case ptopLeft kr of+                [] -> assert `failure` kr+                l : _ -> T.length l+              dy = length $ ptopLeft kr+              mx = (x1 - x0 + 1 - dx) `div` 2+              my = (y1 - y0 + 1 - dy) `div` 2+          in if mx < requiredForFence || my < requiredForFence+             then Nothing+             else toArea (x0 + mx, y0 + my, x0 + mx + dx - 1, y0 + my + dy - 1)+     else case requiredForFence of+       0 -> Just r+       1 -> shrink r+       _ -> assert `failure` kr  -- | Given a few parameters, roll and construct a 'Place' datastructure -- and fill a cave section acccording to it.@@ -92,22 +110,23 @@            -> Kind.Id TileKind  -- ^ lit fence tile, if fence hollow            -> AbsDepth          -- ^ current level depth            -> AbsDepth          -- ^ absolute depth+           -> Int               -- ^ secret tile seed            -> Area              -- ^ whole area of the place, fence included+           -> Maybe (GroupName PlaceKind)  -- ^ optional fixed place group            -> Rnd (TileMapEM, Place)-buildPlace cops@Kind.COps{ cotile=Kind.Ops{opick=opick}-                         , coplace=Kind.Ops{ofoldrGroup} }+buildPlace cops@Kind.COps{ cotile=Kind.Ops{opick}+                         , coplace=Kind.Ops{ofoldlGroup'} }            CaveKind{..} dnight darkCorTile litCorTile-           ldepth@(AbsDepth ld) totalDepth@(AbsDepth depth) r = do+           ldepth@(AbsDepth ld) totalDepth@(AbsDepth depth) dsecret+           r mplaceGroup = do   qFWall <- fromMaybe (assert `failure` cfillerTile)             <$> opick cfillerTile (const True)-  dark <- chanceDice ldepth totalDepth cdarkChance-  -- TODO: factor out from here and newItem:   let findInterval x1y1 [] = (x1y1, (11, 0))-      findInterval x1y1 ((x, y) : rest) =+      findInterval !x1y1 ((!x, !y) : rest) =         if fromIntegral ld * 10 <= x * fromIntegral depth         then (x1y1, (x, y))         else findInterval (x, y) rest-      linearInterpolation dataset =+      linearInterpolation !dataset =         -- We assume @dataset@ is sorted and between 0 and 10.         let ((x1, y1), (x2, y2)) = findInterval (0, 0) dataset         in ceiling@@ -115,70 +134,105 @@              + fromIntegral (y2 - y1)                * (fromIntegral ld * 10 - x1 * fromIntegral depth)                / ((x2 - x1) * fromIntegral depth)-  let f placeGroup q p pk kind acc =+      f !placeGroup !q !acc !p !pk !kind =         let rarity = linearInterpolation (prarity kind)         in (q * p * rarity, ((pk, kind), placeGroup)) : acc-      g (placeGroup, q) = ofoldrGroup placeGroup (f placeGroup q) []-      placeFreq = concatMap g cplaceFreq+      g (placeGroup, q) = ofoldlGroup' placeGroup (f placeGroup q) []+      pfreq = case mplaceGroup of+        Nothing -> cplaceFreq+        Just placeGroup -> [(placeGroup, 1)]+      placeFreq = concatMap g pfreq       checkedFreq = filter (\(_, ((_, kind), _)) -> placeCheck r kind) placeFreq       freq = toFreq ("buildPlace" <+> tshow (map fst checkedFreq)) checkedFreq   let !_A = assert (not (nullFreq freq) `blame` (placeFreq, checkedFreq, r)) ()   ((qkind, kr), _) <- frequency freq+  dark <- if cpassable && pfence kr `elem` [FFloor, FGround]+          then return dnight+          else chanceDice ldepth totalDepth cdarkChance   let qFFloor = if dark then darkCorTile else litCorTile       qFGround = if dnight then darkCorTile else litCorTile       qlegend = if dark then clegendDarkTile else clegendLitTile       qseen = False-      qarea = fromMaybe (assert `failure` (kr, r)) $ interiorArea (pfence kr) r+      qarea = fromMaybe (assert `failure` (kr, r)) $ interiorArea kr r       place = Place {..}-  override <- ooverride cops (poverride kr)-  legend <- olegend cops qlegend-  legendLit <- olegend cops clegendLitTile-  let xlegend = EM.union override legend-      xlegendLit = EM.union override legendLit-      cmap = tilePlace qarea kr-      fence = case pfence kr of+  (overrideOneIn, override) <- ooverride cops (poverride kr)+  (legendOneIn, legend) <- olegend cops qlegend+  (legendLitOneIn, legendLit) <- olegend cops clegendLitTile+  let xlegend = ( EM.union overrideOneIn legendOneIn+                , EM.union override legend )+      xlegendLit = ( EM.union overrideOneIn legendLitOneIn+                   , EM.union override legendLit )+  cmap <- tilePlace qarea kr+  let fence = case pfence kr of         FWall -> buildFence qFWall qarea         FFloor -> buildFence qFFloor qarea         FGround -> buildFence qFGround qarea         FNone -> EM.empty       (x0, y0, x1, y1) = fromArea qarea       isEdge (Point x y) = x `elem` [x0, x1] || y `elem` [y0, y1]-      digDay xy c | isEdge xy = xlegendLit EM.! c-                  | otherwise = xlegend EM.! c+      digDay xy c | isEdge xy = lookupOneIn xlegendLit xy c+                  | otherwise = lookupOneIn xlegend xy c+      lookupOneIn :: ( EM.EnumMap Char (Int, Kind.Id TileKind)+                     , EM.EnumMap Char (Kind.Id TileKind) )+                  -> Point -> Char+                  -> Kind.Id TileKind+      lookupOneIn (mOneIn, m) xy c = case EM.lookup c mOneIn of+        Just (oneInChance, tk) ->+          if isChancePos oneInChance dsecret xy+          then tk+          else EM.findWithDefault (assert `failure` (c, mOneIn, m)) c m+        Nothing -> EM.findWithDefault (assert `failure` (c, mOneIn, m)) c m       interior = case pfence kr of         FNone | not dnight -> EM.mapWithKey digDay cmap-        _ -> let lookupLegend x =-                   EM.findWithDefault (assert `failure` (qlegend, x)) x xlegend-             in EM.map lookupLegend cmap-      tmap = EM.union interior fence-  return (tmap, place)+        _ -> EM.mapWithKey (lookupOneIn xlegend) cmap+  return (EM.union interior fence, place) +isChancePos :: Int -> Int -> Point -> Bool+isChancePos c dsecret (Point x y) =+  c > 0 && (dsecret `Bits.rotateR` x `Bits.xor` y + x) `mod` c == 0+ -- | Roll a legend of a place plan: a map from plan symbols to tile kinds. olegend :: Kind.COps -> GroupName TileKind-        -> Rnd (EM.EnumMap Char (Kind.Id TileKind))-olegend Kind.COps{cotile=Kind.Ops{ofoldrWithKey, opick}} cgroup =-  let getSymbols _ tk acc =+        -> Rnd ( EM.EnumMap Char (Int, Kind.Id TileKind)+               , EM.EnumMap Char (Kind.Id TileKind) )+olegend Kind.COps{cotile=Kind.Ops{ofoldlWithKey', opick, okind}} cgroup =+  let getSymbols !acc _ !tk =         maybe acc (const $ ES.insert (TK.tsymbol tk) acc)-          (lookup cgroup $ TK.tfreq tk)-      symbols = ofoldrWithKey getSymbols ES.empty-      getLegend s acc = do-        m <- acc+              (lookup cgroup $ TK.tfreq tk)+      symbols = ofoldlWithKey' getSymbols ES.empty+      getLegend s !acc = do+        (mOneIn, m) <- acc+        let p f t = TK.tsymbol t == s && f (Tile.kindHasFeature TK.Spice t)         tk <- fmap (fromMaybe $ assert `failure` (cgroup, s))-              $ opick cgroup $ (== s) . TK.tsymbol-        return $! EM.insert s tk m-      legend = ES.foldr getLegend (return EM.empty) symbols+              $ opick cgroup (p not)+        mtkSpice <- opick cgroup (p id)+        return $! case mtkSpice of+          Nothing -> (mOneIn, EM.insert s tk m)+          Just tkSpice ->+            let n = fromJust (lookup cgroup (TK.tfreq (okind tk)))+                k = fromJust (lookup cgroup (TK.tfreq (okind tkSpice)))+                oneIn = (n + k) `divUp` k+            in (EM.insert s (oneIn, tkSpice) mOneIn, EM.insert s tk m)+      legend = ES.foldr' getLegend (return (EM.empty, EM.empty)) symbols   in legend  ooverride :: Kind.COps -> [(Char, GroupName TileKind)]-          -> Rnd (EM.EnumMap Char (Kind.Id TileKind))-ooverride Kind.COps{cotile=Kind.Ops{opick}} poverride =+          -> Rnd ( EM.EnumMap Char (Int, Kind.Id TileKind)+                 , EM.EnumMap Char (Kind.Id TileKind) )+ooverride Kind.COps{cotile=Kind.Ops{opick, okind}} poverride =   let getLegend (s, cgroup) acc = do-        m <- acc-        tk <- fromMaybe (assert `failure` (cgroup, s))-              <$> opick cgroup (const True)  -- tile symbol ignored-        return $! EM.insert s tk m-      legend = foldr getLegend (return EM.empty) poverride-  in legend+        (mOneIn, m) <- acc+        mtkSpice <- opick cgroup (Tile.kindHasFeature TK.Spice)+        tk <- fromMaybe (assert `failure` (s, cgroup, poverride))+              <$> opick cgroup (not . Tile.kindHasFeature TK.Spice)+        return $! case mtkSpice of+          Nothing -> (mOneIn, EM.insert s tk m)+          Just tkSpice ->+            let n = fromJust (lookup cgroup (TK.tfreq (okind tk)))+                k = fromJust (lookup cgroup (TK.tfreq (okind tkSpice)))+                oneIn = (n + k) `divUp` k+            in (EM.insert s (oneIn, tkSpice) mOneIn, EM.insert s tk m)+  in foldr getLegend (return (EM.empty, EM.empty)) poverride  -- | Construct a fence around an area, with the given tile kind. buildFence :: Kind.Id TileKind -> Area -> TileMapEM@@ -205,12 +259,11 @@   fenceList <- mapM fenceIdRnd pointList   return $! EM.fromList fenceList --- TODO: use Text more instead of [Char]? -- | Create a place by tiling patterns. tilePlace :: Area                           -- ^ the area to fill           -> PlaceKind                      -- ^ the place kind to construct-          -> EM.EnumMap Point Char-tilePlace area pl@PlaceKind{..} =+          -> Rnd (EM.EnumMap Point Char)+tilePlace area pl@PlaceKind{..} = do   let (x0, y0, x1, y1) = fromArea area       xwidth = x1 - x0 + 1       ywidth = y1 - y0 + 1@@ -221,39 +274,45 @@                          `blame` (area, pl))                         (xwidth, ywidth)       fromX (x2, y2) = map (`Point` y2) [x2..]-      fillInterior :: (forall a. Int -> [a] -> [a]) -> [(Point, Char)]-      fillInterior f =+      fillInterior :: (Int -> String -> String)+                   -> (Int -> [String] -> [String])+                   -> [(Point, Char)]+      fillInterior f g =         let tileInterior (y, row) =               let fx = f dx row                   xStart = x0 + ((xwidth - length fx) `div` 2)               in filter ((/= 'X') . snd) $ zip (fromX (xStart, y)) fx             reflected =-              let fy = f dy $ map T.unpack ptopLeft-                  yStart = y0 + ((ywidth - length fy) `div` 2)-              in zip [yStart..] fy+              let gy = g dy $ map T.unpack ptopLeft+                  yStart = y0 + ((ywidth - length gy) `div` 2)+              in zip [yStart..] gy         in concatMap tileInterior reflected       tileReflect :: Int -> [a] -> [a]       tileReflect d pat =         let lstart = take (d `divUp` 2) pat             lend   = take (d `div`   2) pat         in lstart ++ reverse lend-      interior = case pcover of-        CAlternate ->-          let tile :: Int -> [a] -> [a]-              tile _ []  = assert `failure` "nothing to tile" `twith` pl-              tile d pat = take d (cycle $ init pat ++ init (reverse pat))-          in fillInterior tile-        CStretch ->-          let stretch :: Int -> [a] -> [a]-              stretch _ []  = assert `failure` "nothing to stretch" `twith` pl-              stretch d pat = tileReflect d (pat ++ repeat (last pat))-          in fillInterior stretch-        CReflect ->-          let reflect :: Int -> [a] -> [a]-              reflect d pat = tileReflect d (cycle pat)-          in fillInterior reflect-        CVerbatim -> fillInterior $ curry snd-  in EM.fromList interior+  interior <- case pcover of+    CAlternate -> do+      let tile :: Int -> [a] -> [a]+          tile _ []  = assert `failure` "nothing to tile" `twith` pl+          tile d pat = take d (cycle $ init pat ++ init (reverse pat))+      return $! fillInterior tile tile+    CStretch -> do+      let stretch :: Int -> [a] -> [a]+          stretch _ []  = assert `failure` "nothing to stretch" `twith` pl+          stretch d pat = tileReflect d (pat ++ repeat (last pat))+      return $! fillInterior stretch stretch+    CReflect -> do+      let reflect :: Int -> [a] -> [a]+          reflect d pat = tileReflect d (cycle pat)+      return $! fillInterior reflect reflect+    CVerbatim -> return $! fillInterior (flip const) (flip const)+    CMirror -> do+      mirror1 <- oneOf [id, reverse]+      mirror2 <- oneOf [id, reverse]+      return $! fillInterior (\_ l -> mirror1 l) (\_ l -> mirror2 l)+  return $! EM.fromList interior  instance Binary Place where   put Place{..} = do

+ Game/LambdaHack/Server/EndM.hs view

@@ -0,0 +1,86 @@+-- | The main loop of the server, processing human and computer player+-- moves turn by turn.+module Game.LambdaHack.Server.EndM+  ( endOrLoop, dieSer+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.EnumMap.Strict as EM++import Game.LambdaHack.Atomic+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.State+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Server.CommonM+import Game.LambdaHack.Server.HandleEffectM+import Game.LambdaHack.Server.ItemM+import Game.LambdaHack.Server.MonadServer+import Game.LambdaHack.Server.State++-- | Continue or exit or restart the game.+endOrLoop :: (MonadAtomic m, MonadServer m)+          => m () -> (Maybe (GroupName ModeKind) -> m ()) -> m () -> m ()+          -> m ()+endOrLoop loop restart gameExit gameSave = do+  factionD <- getsState sfactionD+  let inGame fact = case gquit fact of+        Nothing -> True+        Just Status{stOutcome=Camping} -> True+        _ -> False+      gameOver = not $ any inGame $ EM.elems factionD+  let getQuitter fact = case gquit fact of+        Just Status{stOutcome=Restart, stNewGame} -> stNewGame+        _ -> Nothing+      quitters = mapMaybe getQuitter $ EM.elems factionD+      restartNeeded = gameOver || not (null quitters)+  let isCamper fact = case gquit fact of+        Just Status{stOutcome=Camping} -> True+        _ -> False+      campers = filter (isCamper . snd) $ EM.assocs factionD+  -- Wipe out the quit flag for the savegame files.+  mapM_ (\(fid, fact) ->+    execUpdAtomic $ UpdQuitFaction fid (gquit fact) Nothing) campers+  swriteSave <- getsServer swriteSave+  when (swriteSave && not restartNeeded) $ do+    modifyServer $ \ser -> ser {swriteSave = False}+    gameSave+  if | restartNeeded -> restart (listToMaybe quitters)+     | not $ null campers -> gameExit  -- and @loop@ is not called+     | otherwise -> loop  -- continue current game++dieSer :: (MonadAtomic m, MonadServer m) => ActorId -> Actor -> m ()+dieSer aid b = do+  unless (bproj b) $ do+    discoKind <- getsServer sdiscoKind+    trunk <- getsState $ getItemBody $ btrunk b+    let KindMean{kmKind} = discoKind EM.! jkindIx trunk+    execUpdAtomic $ UpdRecordKill aid kmKind 1+    -- At this point the actor's body exists and his items are not dropped.+    deduceKilled aid+    electLeader (bfid b) (blid b) aid+    fact <- getsState $ (EM.! bfid b) . sfactionD+    -- Prevent faction's stash from being lost in case they are not spawners.+    -- Projectiles can't drop stash, because they are blind and so the faction+    -- would not see the actor that drops the stash, leading to a crash.+    -- But this is OK; projectiles can't be leaders, so stash dropped earlier.+    when (isNothing $ _gleader fact) $ moveStores False aid CSha CInv+  -- If the actor was a projectile and no effect was triggered by hitting+  -- an enemy, the item still exists and @OnSmash@ effects will be triggered:+  dropAllItems aid b+  b2 <- getsState $ getActorBody aid+  execUpdAtomic $ UpdDestroyActor aid b2 []++-- | Drop all actor's items.+dropAllItems :: (MonadAtomic m, MonadServer m)+             => ActorId -> Actor -> m ()+dropAllItems aid b = do+  mapActorCStore_ CInv (dropCStoreItem False CInv aid b maxBound) b+  mapActorCStore_ CEqp (dropCStoreItem False CEqp aid b maxBound) b

− Game/LambdaHack/Server/EndServer.hs

@@ -1,90 +0,0 @@--- | The main loop of the server, processing human and computer player--- moves turn by turn.-module Game.LambdaHack.Server.EndServer-  ( endOrLoop, dieSer-  ) where--import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.Maybe--import Game.LambdaHack.Atomic-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.State-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Server.CommonServer-import Game.LambdaHack.Server.HandleEffectServer-import Game.LambdaHack.Server.ItemServer-import Game.LambdaHack.Server.MonadServer-import Game.LambdaHack.Server.State---- | Continue or exit or restart the game.-endOrLoop :: (MonadAtomic m, MonadServer m)-          => m () -> (Maybe (GroupName ModeKind) -> m ()) -> m () -> m ()-          -> m ()-endOrLoop loop restart gameExit gameSave = do-  factionD <- getsState sfactionD-  let inGame fact = case gquit fact of-        Nothing -> True-        Just Status{stOutcome=Camping} -> True-        _ -> False-      gameOver = not $ any inGame $ EM.elems factionD-  let getQuitter fact = case gquit fact of-        Just Status{stOutcome=Restart, stNewGame} -> stNewGame-        _ -> Nothing-      quitters = mapMaybe getQuitter $ EM.elems factionD-  let isCamper fact = case gquit fact of-        Just Status{stOutcome=Camping} -> True-        _ -> False-      campers = filter (isCamper . snd) $ EM.assocs factionD-  -- Wipe out the quit flag for the savegame files.-  mapM_ (\(fid, fact) ->-            execUpdAtomic-            $ UpdQuitFaction fid Nothing (gquit fact) Nothing) campers-  bkpSave <- getsServer swriteSave-  when bkpSave $ do-    modifyServer $ \ser -> ser {swriteSave = False}-    gameSave-  case (quitters, campers) of-    (gameMode : _, _) -> restart $ Just gameMode-    _ | gameOver -> restart Nothing-    ([], []) -> loop  -- continue current game-    ([], _ : _) -> gameExit  -- don't call @loop@, that is, quit the game loop--dieSer :: (MonadAtomic m, MonadServer m) => ActorId -> Actor -> Bool -> m ()-dieSer aid b hit =-  -- TODO: clients don't see the death of their last standing actor;-  --       modify Draw.hs and Client.hs to handle that-  if bproj b then do-    dropAllItems aid b hit-    b2 <- getsState $ getActorBody aid-    execUpdAtomic $ UpdDestroyActor aid b2 []-  else do-    discoKind <- getsServer sdiscoKind-    trunk <- getsState $ getItemBody $ btrunk b-    let ikind = discoKind EM.! jkindIx trunk-    execUpdAtomic $ UpdRecordKill aid ikind 1-    electLeader (bfid b) (blid b) aid-    tb <- getsState $ getActorBody aid-    deduceKilled aid tb  -- tb has items not dropped, stash in inv-    fact <- getsState $ (EM.! bfid b) . sfactionD-    -- Prevent faction's stash from being lost in case they are not spawners.-    -- Projectiles can't drop stash, because they are blind and so the faction-    -- would not see the actor that drops the stash, leading to a crash.-    -- But this is OK; projectiles can't be leaders, so stash dropped earlier.-    when (isNothing $ gleader fact) $ moveStores aid CSha CInv-    dropAllItems aid b False-    b2 <- getsState $ getActorBody aid-    execUpdAtomic $ UpdDestroyActor aid b2 []---- | Drop all actor's items.-dropAllItems :: (MonadAtomic m, MonadServer m)-             => ActorId -> Actor -> Bool -> m ()-dropAllItems aid b hit = do-  mapActorCStore_ CInv (dropCStoreItem CInv aid b hit) b-  mapActorCStore_ CEqp (dropCStoreItem CEqp aid b hit) b

Game/LambdaHack/Server/Fov.hs view

@@ -1,245 +1,366 @@-{-# LANGUAGE CPP #-} -- | Field Of View scanning with a variety of algorithms. -- See <https://github.com/LambdaHack/LambdaHack/wiki/Fov-and-los> -- for discussion. module Game.LambdaHack.Server.Fov-  ( dungeonPerception, fidLidPerception-  , PersLit, litInDungeon+  ( -- * Perception cache+    FovValid(..)+  , PerValidFid+  , PerReachable(..)+  , CacheBeforeLucid(..)+  , PerActor+  , PerceptionCache(..)+  , PerCacheLid+  , PerCacheFid+    -- * Data used in FOV computation and cached to speed it up+  , FovShine(..), FovLucid(..), FovLucidLid+  , FovClear(..), FovClearLid, FovLit (..), FovLitLid+    -- * Update of invalidated Fov data+  , perceptionFromPTotal, perActorFromLevel, totalFromPerActor, lucidFromLevel+    -- * Computation of initial perception and caches+  , perFidInDungeon, aspectRecordFromActorServer, boundSightByCalm #ifdef EXPOSE_INTERNAL     -- * Internal operations-  , PerceptionReachable(..), PerceptionDynamicLit(..)+  , cacheBeforeLucidFromActor+  , perceptionCacheFromLevel, perLidFromFaction+  , clearFromLevel, clearInDungeon+  , litFromLevel, litInDungeon, shineFromLevel+  , floorLightSources, lucidFromItems, lucidInDungeon+    -- * The actual Fov algorithm+  , fullscan #endif   ) where -import qualified Data.EnumMap.Lazy as EML+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES-import Data.List-import Data.Maybe+import Data.Int (Int64)+import GHC.Exts (inline)  import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Server.Fov.Common-import qualified Game.LambdaHack.Server.Fov.Digital as Digital-import qualified Game.LambdaHack.Server.Fov.Permissive as Permissive-import qualified Game.LambdaHack.Server.Fov.Shadow as Shadow-import Game.LambdaHack.Server.State+import Game.LambdaHack.Server.FovDigital +-- * Perception cache types++data FovValid a =+    FovValid !a+  | FovInvalid+  deriving (Show, Eq)++-- | Main perception validity map, for all factions.+type PerValidFid = EM.EnumMap FactionId (EM.EnumMap LevelId Bool)+ -- | Visually reachable positions (light passes through them to the actor).--- The list may contain (many) repetitions.-newtype PerceptionReachable = PerceptionReachable-    {preachable :: [Point]}-  deriving Show+-- They need to be intersected with lucid positions to obtain visible positions.+newtype PerReachable = PerReachable {preachable :: ES.EnumSet Point}+  deriving (Show, Eq) --- | All positions lit by dynamic lights on a level. Shared by all factions.--- The list may contain (many) repetitions.-newtype PerceptionDynamicLit = PerceptionDynamicLit-    {pdynamicLit :: [Point]}-  deriving Show+data CacheBeforeLucid = CacheBeforeLucid+  { creachable :: !PerReachable+  , cnocto     :: !PerVisible+  , csmell     :: !PerSmelled+  }+  deriving (Show, Eq) --- | The cache of FOV information for a level, such as sight, smell--- and light radiuses for each actor and bitmaps of clear and lit positions.-type PersLit = EML.EnumMap LevelId ( EM.EnumMap FactionId [(Actor, FovCache3)]-                                   , PointArray.Array Bool-                                   , PointArray.Array Bool )+type PerActor = EM.EnumMap ActorId (FovValid CacheBeforeLucid) --- | Calculate faction's perception of a level.-levelPerception :: [(Actor, FovCache3)]-                -> PointArray.Array Bool -> PointArray.Array Bool-                -> FovMode -> Level-                -> Perception-levelPerception actorEqpBody clearPs litPs fovMode Level{lxsize, lysize} =-  let -- Dying actors included, to let them see their own demise.-      ourR = preachable . reachableFromActor clearPs fovMode-      totalReachable = PerceptionReachable $ concatMap ourR actorEqpBody-      -- All non-projectile actors feel adjacent positions,-      -- even dark (for easy exploration). Projectiles rely on cameras.-      pAndVicinity p = p : vicinity lxsize lysize p-      gatherVicinities = concatMap (pAndVicinity . bpos . fst)-      nocteurs = filter (not . bproj . fst) actorEqpBody-      nocto = gatherVicinities nocteurs-      ptotal = visibleOnLevel totalReachable litPs nocto-      -- TODO: handle smell radius < 2, that is only under the actor-      -- Projectiles can potentially smell, too.-      canSmellAround FovCache3{fovSmell} = fovSmell >= 2-      smellers = filter (canSmellAround . snd) actorEqpBody-      smells = gatherVicinities smellers-      -- No smell stored in walls and under other actors.-      canHoldSmell p = clearPs PointArray.! p-      psmell = PerceptionVisible $ ES.fromList $ filter canHoldSmell smells-  in Perception ptotal psmell+-- We might cache even more effectively in terms of Enum{Set,Map} unions+-- if we recorded for each field how many actors see it (and how many+-- lights lit it). But this is complex and unions of EnumSets are cheaper+-- than the EnumMaps that would be required.+data PerceptionCache = PerceptionCache+  { ptotal   :: !(FovValid CacheBeforeLucid)+  , perActor :: !PerActor+  }+  deriving (Show, Eq) --- | Calculate faction's perception of a level based on the lit tiles cache.-fidLidPerception :: FovMode -> PersLit-                 -> FactionId -> LevelId -> Level-                 -> Perception-fidLidPerception fovMode persLit fid lid lvl =-  let (bodyMap, clearPs, litPs) = persLit EML.! lid-      actorEqpBody = EM.findWithDefault [] fid bodyMap-  in levelPerception actorEqpBody clearPs litPs fovMode lvl+-- | Server cache of perceptions of a single faction,+-- indexed by level identifier.+type PerCacheLid = EM.EnumMap LevelId PerceptionCache --- | Calculate perception of a faction.-factionPerception :: FovMode -> PersLit -> FactionId -> State -> FactionPers-factionPerception fovMode persLit fid s =-  EM.mapWithKey (fidLidPerception fovMode persLit fid) $ sdungeon s+-- | Server cache of perceptions, indexed by faction identifier.+type PerCacheFid = EM.EnumMap FactionId PerCacheLid --- | Calculate the perception of the whole dungeon.-dungeonPerception :: FovMode -> State -> StateServer -> Pers-dungeonPerception fovMode s ser =-  let persLit = litInDungeon fovMode s ser-      f fid _ = factionPerception fovMode persLit fid s-  in EM.mapWithKey f $ sfactionD s+-- * Data used in FOV computation +-- | Map from level positions that currently hold item or actor(s) with shine+-- to the maximum of radiuses of the shining lights.+--+-- Note: @ActorAspect@ and @FovShine@ shoudn't be in @State@,+-- because on client they need to be updated every time an item discovery+-- is made, unlike on the server, where it's much simpler and cheaper.+-- BTW, floor and (many projectile) actors light on a single tile+-- should be additive for @FovShine@ to be incrementally updated.+--+-- @FovShine@ should not even be kept in @StateServer@, because it's cheap+-- to compute, compared to @FovLucid@ and invalidated almost as often+-- (not invalidated only by @UpdAlterTile@).+newtype FovShine = FovShine {fovShine :: EM.EnumMap Point Int}+  deriving (Show, Eq)++-- | Level positions with either ambient light or shining items or actors.+newtype FovLucid = FovLucid {fovLucid :: ES.EnumSet Point}+  deriving (Show, Eq)++type FovLucidLid = EM.EnumMap LevelId (FovValid FovLucid)++-- | Level positions that pass through light and vision.+newtype FovClear = FovClear {fovClear :: PointArray.Array Bool}+  deriving (Show, Eq)++type FovClearLid = EM.EnumMap LevelId FovClear++-- | Level positions with tiles that have ambient light.+newtype FovLit = FovLit {fovLit :: ES.EnumSet Point}+  deriving (Show, Eq)++type FovLitLid = EM.EnumMap LevelId FovLit++-- * Update of invalidated Fov data+ -- | Compute positions visible (reachable and seen) by the party.--- A position can be directly lit by an ambient shine or by a weak, portable--- light source, e.g,, carried by an actor. A reachable and lit position+-- A position is lucid, if it's lit by an ambient light or by a weak, portable+-- light source, e.g,, carried by an actor. A reachable and lucid position -- is visible. Additionally, positions directly adjacent to an actor are -- assumed to be visible to him (through sound, touch, noctovision, whatever).-visibleOnLevel :: PerceptionReachable-               -> PointArray.Array Bool -> [Point]-               -> PerceptionVisible-visibleOnLevel PerceptionReachable{preachable} litPs nocto =-  let isVisible = (litPs PointArray.!)-  in PerceptionVisible $ ES.fromList $ nocto ++ filter isVisible preachable+perceptionFromPTotal :: FovLucid -> CacheBeforeLucid -> Perception+perceptionFromPTotal FovLucid{fovLucid} ptotal =+  let nocto = pvisible $ cnocto ptotal+      reach = preachable $ creachable ptotal+      psight = PerVisible $ nocto `ES.union` (reach `ES.intersection` fovLucid)+      psmell = csmell ptotal+  in Perception{..} +perActorFromLevel :: PerActor -> (ActorId -> Actor) -> ActorAspect -> FovClear+                  -> PerActor+perActorFromLevel perActorOld getActorB actorAspect fovClear =+  -- Dying actors included, to let them see their own demise.+  let f _ fv@FovValid{} = fv+      f aid FovInvalid =+        let ar = actorAspect EM.! aid+            b = getActorB aid+        in FovValid $ cacheBeforeLucidFromActor fovClear b ar+  in EM.mapWithKey f perActorOld++boundSightByCalm :: Int -> Int64 -> Int+boundSightByCalm sight calm =+  min (fromEnum $ calm `div` (5 * oneM)) sight+ -- | Compute positions reachable by the actor. Reachable are all fields -- on a visually unblocked path from the actor position.-reachableFromActor :: PointArray.Array Bool -> FovMode -> (Actor, FovCache3)-                   -> PerceptionReachable-reachableFromActor clearPs fovMode (body, FovCache3{fovSight}) =-  let radius = min (fromIntegral $ bcalm body `div` (5 * oneM)) fovSight-  in PerceptionReachable $ fullscan clearPs fovMode radius (bpos body)+-- Also compute positions seen by noctovision and perceived by smell.+cacheBeforeLucidFromActor :: FovClear -> Actor -> AspectRecord+                          -> CacheBeforeLucid+cacheBeforeLucidFromActor clearPs body AspectRecord{..} =+  let radius = boundSightByCalm aSight (bcalm body)+      creachable = PerReachable $ fullscan clearPs radius (bpos body)+      cnocto = PerVisible $ fullscan clearPs aNocto (bpos body)+      smellRadius = if aSmell >= 2 then 2 else 0+      csmell = PerSmelled $ fullscan clearPs smellRadius (bpos body)+  in CacheBeforeLucid{..} --- | Compute all dynamically lit positions on a level, whether lit by actors--- or floor items. Note that an actor can be blind, in which case he doesn't see--- his own light (but others, from his or other factions, possibly do).-litByItems :: PointArray.Array Bool -> FovMode -> [(Point, Int)]-           -> PerceptionDynamicLit-litByItems clearPs fovMode allItems =-  let litPos :: (Point, Int) -> [Point]-      litPos (p, light) = fullscan clearPs fovMode light p-  in PerceptionDynamicLit $ concatMap litPos allItems+totalFromPerActor :: PerActor -> CacheBeforeLucid+totalFromPerActor perActor =+  let as = map (\a -> case a of+                   FovValid x -> x+                   FovInvalid -> assert `failure` perActor)+           $ EM.elems perActor+  in CacheBeforeLucid+       { creachable = PerReachable+                      $ ES.unions $ map (preachable . creachable) as+       , cnocto = PerVisible+                  $ ES.unions $ map (pvisible . cnocto) as+       , csmell = PerSmelled+                  $ ES.unions $ map (psmelled . csmell) as } --- | Compute all lit positions in the dungeon.-litInDungeon :: FovMode -> State -> StateServer -> PersLit-litInDungeon fovMode s ser =-  let Kind.COps{cotile} = scops s-      processIid3 (FovCache3 sightAcc smellAcc lightAcc) (iid, (k, _)) =-        let FovCache3{..} =-              EM.findWithDefault emptyFovCache3 iid $ sItemFovCache ser-        in FovCache3 (k * fovSight + sightAcc)-                     (k * fovSmell + smellAcc)-                     (k * fovLight + lightAcc)-      processBag3 bag acc = foldl' processIid3 acc $ EM.assocs bag-      itemsInActors :: Level -> EM.EnumMap FactionId [(Actor, FovCache3)]-      itemsInActors lvl =-        let processActor aid =-              let b = getActorBody aid s-                  sslOrgan = processBag3 (borgan b) emptyFovCache3-                  ssl = processBag3 (beqp b) sslOrgan-              in (bfid b, [(b, ssl)])-            asLid = map processActor $ concat $ EM.elems $ lprio lvl-        in EM.fromListWith (++) asLid-      processIid lightAcc (iid, (k, _)) =-        let FovCache3{fovLight} =-              EM.findWithDefault emptyFovCache3 iid $ sItemFovCache ser-        in k * fovLight + lightAcc+-- | Update lights on the level. This is needed every (even enemy)+-- actor move to show thrown torches.+-- We need to update lights even if cmd doesn't change any perception,+-- so that for next cmd that does, but doesn't change lights,+-- and operates on the same level, the lights are up to date.+-- We could make lights lazy to ensure no computation is wasted,+-- but it's rare that cmd changed them, but not the perception+-- (e.g., earthquake in an uninhabited corner of the active arena,+-- but the we'd probably want some feedback, at least sound).+lucidFromLevel :: DiscoveryAspect -> ActorAspect -> FovClearLid -> FovLitLid+               -> State -> LevelId -> Level+               -> FovLucid+lucidFromLevel discoAspect actorAspect fovClearLid fovLitLid s lid lvl =+  let shine = shineFromLevel discoAspect actorAspect s lid lvl+      lucids = lucidFromItems (fovClearLid EM.! lid)+               $ EM.assocs $ fovShine shine+      litTiles = fovLitLid EM.! lid+  in FovLucid $ ES.unions $ fovLit litTiles : map fovLucid lucids++shineFromLevel :: DiscoveryAspect -> ActorAspect -> State -> LevelId -> Level+               -> FovShine+shineFromLevel discoAspect actorAspect s lid lvl =+  let actorLights =+        [ (bpos b, radius)+        | (aid, b) <- inline actorAssocs (const True) lid s+        , let radius = aShine $ actorAspect EM.! aid+        , radius > 0 ]+      floorLights = floorLightSources discoAspect lvl+      allLights = floorLights ++ actorLights+      -- If there is light both on the floor and carried by actor+      -- (or several projectile actors), its radius is the maximum.+  in FovShine $ EM.fromListWith max allLights++floorLightSources :: DiscoveryAspect -> Level -> [(Point, Int)]+floorLightSources discoAspect lvl =+  -- Not enough oxygen to have more than one light lit on a given tile.+  -- Items obscuring or dousing off fire are not cumulative as well.+  let processIid (accLight, accDouse) (iid, _) =+        let AspectRecord{aShine} = discoAspect EM.! iid+        in case compare aShine 0 of+          EQ -> (accLight, accDouse)+          GT -> (max aShine accLight, accDouse)+          LT -> (accLight, min aShine accDouse)       processBag bag acc = foldl' processIid acc $ EM.assocs bag-      lightOnFloor :: Level -> [(Point, Int)]-      lightOnFloor lvl =-        let processPos (p, bag) = (p, processBag bag 0)-        in map processPos $ EM.assocs $ lfloor lvl  -- lembed are hidden-      -- Note that an actor can be blind,-      -- in which case he doesn't see his own light-      -- (but others, from his or other factions, possibly do).-      litOnLevel :: Level -> ( EM.EnumMap FactionId [(Actor, FovCache3)]-                             , PointArray.Array Bool-                             , PointArray.Array Bool )-      litOnLevel lvl@Level{ltile} =-        let bodyMap = itemsInActors lvl-            allBodies = concat $ EM.elems bodyMap-            clearTiles = PointArray.mapA (Tile.isClear cotile) ltile-            blockFromBody (b, _) =-              if bproj b then Nothing else Just (bpos b, False)-            -- TODO: keep it in server state and update when tiles change-            -- and actors are born/move/die. Actually, do this for PersLit.-            blockingActors = mapMaybe blockFromBody allBodies-            clearPs = clearTiles PointArray.// blockingActors-            litTiles = PointArray.mapA (Tile.isLit cotile) ltile-            actorLights = map (\(b, FovCache3{fovLight}) -> (bpos b, fovLight))-                              allBodies-            floorLights = lightOnFloor lvl-            -- If there is light both on the floor and carried by actor,-            -- only the stronger light is taken into account.-            -- This is rare, so no point optimizing away the double computation.-            allLights = floorLights ++ actorLights-            litDynamic = pdynamicLit $ litByItems clearPs fovMode allLights-            litPs = litTiles PointArray.// map (\p -> (p, True)) litDynamic-        in (bodyMap, clearPs, litPs)-      litLvl (lid, lvl) = (lid, litOnLevel lvl)-  in EML.fromDistinctAscList $ map litLvl $ EM.assocs $ sdungeon s+  in [ (p, radius)+     | (p, bag) <- EM.assocs $ lfloor lvl  -- lembed are hidden+     , let (maxLight, maxDouse) = processBag bag (0, 0)+           radius = maxLight + maxDouse+     , radius > 0 ] +-- | Compute all dynamically lit positions on a level, whether lit by actors+-- or shining floor items. Note that an actor can be blind,+-- in which case he doesn't see his own light (but others,+-- from his or other factions, possibly do).+lucidFromItems :: FovClear -> [(Point, Int)] -> [FovLucid]+lucidFromItems clearPs allItems =+  let lucidPos (p, shine) = FovLucid $ fullscan clearPs shine p+  in map lucidPos allItems++-- * Computation of initial perception and caches++-- | Calculate the perception and its caches for the whole dungeon.+perFidInDungeon :: DiscoveryAspect -> State+                -> ( ActorAspect, FovLitLid, FovClearLid, FovLucidLid+                   , PerValidFid, PerCacheFid, PerFid)+perFidInDungeon discoAspect s =+  let actorAspect = actorAspectInDungeon discoAspect s+      fovLitLid = litInDungeon s+      fovClearLid = clearInDungeon s+      fovLucidLid =+        lucidInDungeon discoAspect actorAspect fovClearLid fovLitLid s+      perValidLid = EM.map (const True) (sdungeon s)+      perValidFid = EM.map (const perValidLid) (sfactionD s)+      f fid _ = perLidFromFaction actorAspect fovLucidLid fovClearLid fid s+      em = EM.mapWithKey f $ sfactionD s+  in ( actorAspect, fovLitLid, fovClearLid, fovLucidLid+     , perValidFid, EM.map snd em, EM.map fst em)++aspectRecordFromActorServer :: DiscoveryAspect -> Actor -> AspectRecord+aspectRecordFromActorServer discoAspect b =+  let processIid (iid, (k, _)) = (discoAspect EM.! iid, k)+      processBag ass = sumAspectRecord $ map processIid ass+  in processBag $ EM.assocs (borgan b) ++ EM.assocs (beqp b)++actorAspectInDungeon :: DiscoveryAspect -> State -> ActorAspect+actorAspectInDungeon discoAspect s =+  EM.map (aspectRecordFromActorServer discoAspect) $ sactorD s++litFromLevel :: Kind.COps -> Level -> FovLit+litFromLevel Kind.COps{coTileSpeedup} Level{ltile} =+  let litSet p t set = if Tile.isLit coTileSpeedup t then p : set else set+  in FovLit $ ES.fromDistinctAscList $ PointArray.ifoldrA' litSet [] ltile++litInDungeon :: State -> FovLitLid+litInDungeon s = EM.map (litFromLevel (scops s)) $ sdungeon s++clearFromLevel :: Kind.COps -> Level -> FovClear+clearFromLevel Kind.COps{coTileSpeedup} Level{ltile} =+  FovClear $ PointArray.mapA (Tile.isClear coTileSpeedup) ltile++clearInDungeon :: State -> FovClearLid+clearInDungeon s = EM.map (clearFromLevel (scops s)) $ sdungeon s++lucidInDungeon :: DiscoveryAspect -> ActorAspect -> FovClearLid -> FovLitLid+               -> State+               -> FovLucidLid+lucidInDungeon discoAspect actorAspect fovClearLid fovLitLid s =+  EM.mapWithKey+    (\lid lvl -> FovValid $+       lucidFromLevel discoAspect actorAspect fovClearLid fovLitLid s lid lvl)+    $ sdungeon s++-- | Calculate perception of a faction.+perLidFromFaction :: ActorAspect -> FovLucidLid -> FovClearLid+                  -> FactionId -> State+                  -> (PerLid, PerCacheLid)+perLidFromFaction actorAspect fovLucidLid fovClearLid fid s =+  let em = EM.mapWithKey (\lid _ ->+             perceptionCacheFromLevel actorAspect fovClearLid fid lid s)+             (sdungeon s)+      fovLucid lid = case EM.lookup lid fovLucidLid of+        Just (FovValid fl) -> fl+        _ -> assert `failure` (lid, fovLucidLid)+      getValid (FovValid pc) = pc+      getValid FovInvalid = assert `failure` fid+  in ( EM.mapWithKey (\lid pc ->+         perceptionFromPTotal (fovLucid lid) (getValid (ptotal pc))) em+     , em )++perceptionCacheFromLevel :: ActorAspect -> FovClearLid+                         -> FactionId -> LevelId -> State+                         -> PerceptionCache+perceptionCacheFromLevel actorAspect fovClearLid fid lid s =+  let fovClear = fovClearLid EM.! lid+      lvlBodies = inline actorAssocs (== fid) lid s+      f (aid, b) =+        let ar@AspectRecord{..} = actorAspect EM.! aid+        in if aSight <= 0 && aNocto <= 0 && aSmell <= 0  -- dumb missiles+           then Nothing+           else Just (aid, FovValid $ cacheBeforeLucidFromActor fovClear b ar)+      lvlCaches = mapMaybe f lvlBodies+      perActor = EM.fromDistinctAscList lvlCaches+      total = totalFromPerActor perActor+  in PerceptionCache{ptotal = FovValid total, perActor}++-- * The actual Fov algorithm++type Matrix = (Int, Int, Int, Int)+ -- | Perform a full scan for a given position. Returns the positions -- that are currently in the field of view. The Field of View -- algorithm to use is passed in the second argument. -- The actor's own position is considred reachable by him.-fullscan :: PointArray.Array Bool  -- ^ the array with non-clear points-         -> FovMode    -- ^ scanning mode-         -> Int        -- ^ scanning radius-         -> Point      -- ^ position of the spectator-         -> [Point]-fullscan clearPs fovMode radius spectatorPos-  | radius <= 0 = []-  | radius == 1 = [spectatorPos]-  | otherwise =-    spectatorPos : case fovMode of-      Shadow ->-        concatMap (\tr -> map tr (Shadow.scan (isCl . tr) 1 (0, 1))) tr8-      Permissive ->-        concatMap (\tr -> map tr (Permissive.scan (isCl . tr))) tr4-      Digital ->-        concatMap (\tr -> map tr (Digital.scan (radius - 1) (isCl . tr))) tr4+fullscan :: FovClear  -- ^ the array with clear points+         -> Int       -- ^ scanning radius+         -> Point     -- ^ position of the spectator+         -> ES.EnumSet Point+fullscan FovClear{fovClear} radius spectatorPos =+  if | radius <= 0 -> ES.empty+     | radius == 1 -> ES.singleton spectatorPos+     | radius == 2 -> inline squareUnsafeSet spectatorPos+     | otherwise ->+         mapTr (1, 0, 0, -1)   -- quadrant I+       $ mapTr (0, 1, 1, 0)    -- II (counter-clockwise)+       $ mapTr (-1, 0, 0, 1)   -- III+       $ mapTr (0, -1, -1, 0)  -- IV+       $ ES.singleton spectatorPos  where-  isCl :: Point -> Bool-  {-# INLINE isCl #-}-  isCl = (clearPs PointArray.!)+  mapTr :: Matrix -> ES.EnumSet Point -> ES.EnumSet Point+  mapTr m@(!_, !_, !_, !_) es = scan es (radius - 1) fovClear (trV m)    -- This function is cheap, so no problem it's called twice-  -- for each point: once with @isCl@, once via @concatMap@.-  trV :: X -> Y -> Point+  -- for some points: once for @isClear@, once in @outside@.+  trV :: Matrix -> Bump -> Point   {-# INLINE trV #-}-  trV x y = shift spectatorPos $ Vector x y--  -- | The translation, rotation and symmetry functions for octants.-  tr8 :: [(Distance, Progress) -> Point]-  {-# INLINE tr8 #-}-  tr8 =-    [ \(p, d) -> trV   p    d-    , \(p, d) -> trV (-p)   d-    , \(p, d) -> trV   p  (-d)-    , \(p, d) -> trV (-p) (-d)-    , \(p, d) -> trV   d    p-    , \(p, d) -> trV (-d)   p-    , \(p, d) -> trV   d  (-p)-    , \(p, d) -> trV (-d) (-p)-    ]--  -- | The translation and rotation functions for quadrants.-  tr4 :: [Bump -> Point]-  {-# INLINE tr4 #-}-  tr4 =-    [ \B{..} -> trV   bx  (-by)  -- quadrant I-    , \B{..} -> trV   by    bx   -- II (we rotate counter-clockwise)-    , \B{..} -> trV (-bx)   by   -- III-    , \B{..} -> trV (-by) (-bx)  -- IV-    ]+  trV (x1, y1, x2, y2) B{..} =+    shift spectatorPos $ Vector (x1 * bx + y1 * by) (x2 * bx + y2 * by)

− Game/LambdaHack/Server/Fov/Common.hs

@@ -1,73 +0,0 @@--- | Common definitions for the Field of View algorithms.--- See <https://github.com/LambdaHack/LambdaHack/wiki/Fov-and-los>--- for some more context and references.-module Game.LambdaHack.Server.Fov.Common-  ( -- * Current scan parameters-    Distance, Progress-    -- * Scanning coordinate system-  , Bump(..)-    -- * Geometry in system @Bump@-  , Line(..), ConvexHull, Edge, EdgeInterval-    -- * Assorted minor operations-  , maximal, steeper, addHull-  ) where--import Data.List---- | Distance from the (0, 0) point where FOV originates.-type Distance = Int--- | Progress along an arc with a constant distance from (0, 0).-type Progress = Int---- | Rotated and translated coordinates of 2D points, so that the points fit--- in a single quadrant area (e, g., quadrant I for Permissive FOV, hence both--- coordinates positive; adjacent diagonal halves of quadrant I and II--- for Digital FOV, hence y positive).--- The special coordinates are written using the standard mathematical--- coordinate setup, where quadrant I, with x and y positive,--- is on the upper right.-data Bump = B-  { bx :: !Int-  , by :: !Int-  }-  deriving Show---- | Straight line between points.-data Line = Line !Bump !Bump-  deriving Show---- | Convex hull represented as a list of points.-type ConvexHull   = [Bump]--- | An edge (comprising of a line and a convex hull)--- of the area to be scanned.-type Edge         = (Line, ConvexHull)--- | The area left to be scanned, delimited by edges.-type EdgeInterval = (Edge, Edge)---- | Maximal element of a non-empty list. Prefers elements from the rear,--- which is essential for PFOV, to avoid ill-defined lines.-maximal :: (a -> a -> Bool) -> [a] -> a-{-# INLINE maximal #-}-maximal gte = foldl1' (\acc e -> if gte e acc then e else acc)---- | Check if the line from the second point to the first is more steep--- than the line from the third point to the first. This is related--- to the formal notion of gradient (or angle), but hacked wrt signs--- to work fast in this particular setup. Returns True for ill-defined lines.-steeper :: Bump -> Bump -> Bump -> Bool-{-# INLINE steeper #-}-steeper (B xf yf) (B x1 y1) (B x2 y2) =-  (yf - y1)*(xf - x2) >= (yf - y2)*(xf - x1)---- | Extends a convex hull of bumps with a new bump. Nothing needs to be done--- if the new bump already lies within the hull. The first argument is--- typically `steeper`, optionally negated, applied to the second argument.-addHull :: (Bump -> Bump -> Bool)  -- ^ a comparison function-        -> Bump                    -- ^ a new bump to consider-        -> ConvexHull  -- ^ a convex hull of bumps represented as a list-        -> ConvexHull-{-# INLINE addHull #-}-addHull gte new = (new :) . go- where-  go (a:b:cs) | gte a b = go (b:cs)-  go l = l

− Game/LambdaHack/Server/Fov/Digital.hs

@@ -1,174 +0,0 @@-{-# LANGUAGE CPP #-}--- | DFOV (Digital Field of View) implemented according to specification at <http://roguebasin.roguelikedevelopment.org/index.php?title=Digital_field_of_view_implementation>.--- This fast version of the algorithm, based on "PFOV", has AFAIK--- never been described nor implemented before.-module Game.LambdaHack.Server.Fov.Digital-  ( scan-#ifdef EXPOSE_INTERNAL-    -- * Internal operations-  , dline, dsteeper, intersect, _debugSteeper, _debugLine-#endif-  ) where--import Control.Exception.Assert.Sugar--import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Server.Fov.Common---- | Calculates the list of tiles, in @Bump@ coordinates, visible from (0, 0),--- within the given sight range.-scan :: Distance        -- ^ visiblity distance-     -> (Bump -> Bool)  -- ^ clear tile predicate-     -> [Bump]-{-# INLINE scan #-}-scan r isClear = assert (r > 0 `blame` r) $-  -- The scanned area is a square, which is a sphere in the chessboard metric.-  dscan 1 ( (Line (B 1 0) (B (-r) r), [B 0 0])-          , (Line (B 0 0) (B (r+1) r), [B 1 0]) )- where-  dscan :: Distance -> EdgeInterval -> [Bump]-  dscan d ( s0@(sl{-shallow line-}, sHull0)-          , e@(el{-steep line-}, eHull) ) =--    let !ps0 = let (n, k) = intersect sl d  -- minimal progress to consider-               in n `div` k-        !pe = let (n, k) = intersect el d   -- maximal progress to consider-                -- Corners obstruct view, so the steep line, constructed-                -- from corners, is itself not a part of the view,-                -- so if its intersection with the line of diagonals is only-                -- at a corner, choose the diamond leading to a smaller view.-              in -1 + n `divUp` k-        inside = [B p d | p <- [ps0..pe]]-        outside-          | d >= r = []-          | isClear (B ps0 d) = mscanVisible s0 (ps0+1)  -- start visible-          | otherwise = mscanShadowed (ps0+1)            -- start in shadow--        -- We're in a visible interval.-        mscanVisible :: Edge -> Progress -> [Bump]-        {-# INLINE mscanVisible #-}-        mscanVisible s = go-         where-          go ps | ps > pe = dscan (d+1) (s, e)       -- reached end, scan next-                | not $ isClear steepBump =          -- entering shadow-                    mscanShadowed (ps+1)-                    ++ dscan (d+1) (s, (dline nep steepBump, neHull))-                | otherwise = go (ps+1)  -- continue in visible area-           where-            steepBump = B ps d-            gte :: Bump -> Bump -> Bool-            {-# INLINE gte #-}-            gte = dsteeper steepBump-            nep = maximal gte (snd s)-            neHull = addHull gte steepBump eHull--        -- We're in a shadowed interval.-        mscanShadowed :: Progress -> [Bump]-        mscanShadowed ps-          | ps > pe = []                       -- reached end while in shadow-          | isClear shallowBump =              -- moving out of shadow-              mscanVisible (dline nsp shallowBump, nsHull) (ps+1)-          | otherwise = mscanShadowed (ps+1)   -- continue in shadow-         where-          shallowBump = B ps d-          gte :: Bump -> Bump -> Bool-          {-# INLINE gte #-}-          gte = flip $ dsteeper shallowBump-          nsp = maximal gte eHull-          nsHull = addHull gte shallowBump sHull0--    in assert (r >= d && d >= 0 && pe >= ps0 `blame` (r,d,s0,e,ps0,pe)) $-       inside ++ outside---- | Create a line from two points. Debug: check if well-defined.-dline :: Bump -> Bump -> Line-{-# INLINE dline #-}-dline p1 p2 =-  let line = Line p1 p2-  in-#ifdef WITH_EXPENSIVE_ASSERTIONS-    assert (uncurry blame $ _debugLine line)-#endif-      line---- | Compare steepness of @(p1, f)@ and @(p2, f)@.--- Debug: Verify that the results of 2 independent checks are equal.-dsteeper :: Bump -> Bump -> Bump -> Bool-{-# INLINE dsteeper #-}-dsteeper f p1 p2 =-#ifdef WITH_EXPENSIVE_ASSERTIONS-  assert (res == _debugSteeper f p1 p2)-#endif-    res- where res = steeper f p1 p2---- | The X coordinate, represented as a fraction, of the intersection of--- a given line and the line of diagonals of diamonds at distance--- @d@ from (0, 0).-intersect :: Line -> Distance -> (Int, Int)-{-# INLINE intersect #-}-intersect (Line (B x y) (B xf yf)) d =-#ifdef WITH_EXPENSIVE_ASSERTIONS-  assert (allB (>= 0) [y, yf])-#endif-    ((d - y)*(xf - x) + x*(yf - y), yf - y)-{--Derivation of the formula:-The intersection point (xt, yt) satisfies the following equalities:-yt = d-(yt - y) (xf - x) = (xt - x) (yf - y)-hence-(yt - y) (xf - x) = (xt - x) (yf - y)-(d - y) (xf - x) = (xt - x) (yf - y)-(d - y) (xf - x) + x (yf - y) = xt (yf - y)-xt = ((d - y) (xf - x) + x (yf - y)) / (yf - y)--General remarks:-A diamond is denoted by its left corner. Hero at (0, 0).-Order of processing in the first quadrant rotated by 45 degrees is- 45678-  123-   @-so the first processed diamond is at (-1, 1). The order is similar-as for the restrictive shadow casting algorithm and reversed wrt PFOV.-The line in the curent state of mscan is called the shallow line,-but it's the one that delimits the view from the left, while the steep-line is on the right, opposite to PFOV. We start scanning from the left.--The Point coordinates are cartesian. The Bump coordinates are cartesian,-translated so that the hero is at (0, 0) and rotated so that he always-looks at the first (rotated 45 degrees) quadrant. The (Progress, Distance)-cordinates coincide with the Bump coordinates, unlike in PFOV.--}---- | Debug functions for DFOV:---- | Debug: calculate steeper for DFOV in another way and compare results.-_debugSteeper :: Bump -> Bump -> Bump -> Bool-{-# INLINE _debugSteeper #-}-_debugSteeper f@(B _xf yf) p1@(B _x1 y1) p2@(B _x2 y2) =-  assert (allB (>= 0) [yf, y1, y2]) $-  let (n1, k1) = intersect (Line p1 f) 0-      (n2, k2) = intersect (Line p2 f) 0-  in n1 * k2 >= k1 * n2---- | Debug: check if a view border line for DFOV is legal.-_debugLine :: Line -> (Bool, String)-{-# INLINE _debugLine #-}-_debugLine line@(Line (B x1 y1) (B x2 y2))-  | not (allB (>= 0) [y1, y2]) =-      (False, "negative coordinates: " ++ show line)-  | y1 == y2 && x1 == x2 =-      (False, "ill-defined line: " ++ show line)-  | y1 == y2 =-      (False, "horizontal line: " ++ show line)-  | crossL0 =-      (False, "crosses the X axis below 0: " ++ show line)-  | crossG1 =-      (False, "crosses the X axis above 1: " ++ show line)-  | otherwise = (True, "")- where-  (n, k)  = line `intersect` 0-  (q, r)  = if k == 0 then (0, 0) else n `divMod` k-  crossL0 = q < 0  -- q truncated toward negative infinity-  crossG1 = q >= 1 && (q > 1 || r /= 0)

− Game/LambdaHack/Server/Fov/Permissive.hs

@@ -1,156 +0,0 @@--- | PFOV (Permissive Field of View) clean-room reimplemented based on the algorithm described in <http://roguebasin.roguelikedevelopment.org/index.php?title=Precise_Permissive_Field_of_View>,--- though the general structure is more influenced by recursive shadow casting,--- as implemented in Shadow.hs. In the result, this algorithm is much faster--- than the original algorithm on dense maps, since it does not scan--- areas blocked by shadows.-module Game.LambdaHack.Server.Fov.Permissive-  ( scan, dline, dsteeper, intersect, debugSteeper, debugLine-  ) where--import Control.Exception.Assert.Sugar--import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Server.Fov.Common---- TODO: Scanning squares on horizontal lines in octants, not squares--- on diagonals in quadrants, may be much faster and a bit simpler.--- Right now we build new view on each end of each visible wall tile--- and this is necessary only for straight, thin, diagonal walls.---- | Calculates the list of tiles, in @Bump@ coordinates, visible from (0, 0).-scan :: (Bump -> Bool)  -- ^ clear tile predicate-     -> [Bump]-scan isClear =-  dscan 1 ( (Line (B 0 1) (B 999 0), [B 1 0])-          , (Line (B 1 0) (B 0 999), [B 0 1]) )- where-  dscan :: Distance -> EdgeInterval -> [Bump]-  dscan d ( s0@(sl{-shallow line-}, sHull0)-          , e@(el{-steep line-}, eHull) ) =-    assert (d >= 0 && pe + 1 >= ps0 && ps0 >= 0-            `blame` (d,s0,e,ps0,pe)) $-    if illegal then [] else inside ++ outside-   where-    (ns, ks) = sl `intersect` d-    (ne, ke) = el `intersect` d-    -- Corners are translucent, so they are invisible, so if intersection-    -- is at a corner, choose pe that creates the smaller view.-    (ps0, pe) = (ns `div` ks, ne `divUp` ke - 1)  -- progress interval to check-    -- A single ray from an extremity produces non-permissive digital lines.-    illegal  = let (n, k) = intersect sl 0-               in ns*ke == ne*ks && (n `elem` [0, k])-    pd2bump     (p, di) = B (di - p) p-    bottomRight (p, di) = B (di - p + 1) p--    inside = [pd2bump (p, d) | p <- [ps0..pe]]-    outside-      | isClear (pd2bump (ps0, d)) = mscanVisible s0 ps0  -- start visible-      | ps0 == ns `divUp` ks = mscanVisible s0 ps0        -- start in a corner-      | otherwise = mscanShadowed (ps0+1)                 -- start in mid-wall--    -- We're in a visible interval.-    mscanVisible :: Edge -> Progress -> [Bump]-    mscanVisible s@(_, sHull) ps-      | ps > pe = dscan (d+1) (s, e)           -- reached end, scan next-      | not $ isClear (pd2bump (ps, d)) =      -- enter shadow, steep bump-          let steepBump = bottomRight (ps, d)-              gte = flip $ dsteeper steepBump-              -- sHull may contain steepBump, but maximal will ignore it-              nep = maximal gte sHull-              neHull = addHull gte steepBump eHull-          in mscanShadowed (ps+1)-             ++ dscan (d+1) (s, (dline nep steepBump, neHull))-      | otherwise = mscanVisible s (ps+1)      -- continue in visible area--    -- we're in a shadowed interval.-    mscanShadowed :: Progress -> [Bump]-    mscanShadowed ps-      | ps > ne `div` ke = []                  -- reached absolute end-      | otherwise =                            -- out of shadow, shallow bump-          -- the ray can just pass through a corner of diagonal walls-          -- and the recursive call verifies that at the same ps coordinate-          let shallowBump = bottomRight (ps, d)-              gte = dsteeper shallowBump-              nsp = maximal gte eHull-              nsHull = addHull gte shallowBump sHull0-          in mscanVisible (dline nsp shallowBump, nsHull) ps---- | Create a line from two points. Debug: check if well-defined.-dline :: Bump -> Bump -> Line-dline p1 p2 =-  let line = Line p1 p2-  in assert (uncurry blame $ debugLine line) line---- | Compare steepness of @(p1, f)@ and @(p2, f)@.--- Debug: Verify that the results of 2 independent checks are equal.-dsteeper :: Bump -> Bump -> Bump -> Bool-dsteeper f p1 p2 =-  assert (res == debugSteeper f p1 p2) res- where res = steeper f p1 p2---- | The Y coordinate, represented as a fraction, of the intersection of--- a given line and the line of diagonals of squares at distance--- @d@ from (0, 0).-intersect :: Line -> Distance -> (Int, Int)-intersect (Line (B x y) (B xf yf)) d =-  assert (allB (>= 0) [x, y, xf, yf])-    ((1 + d)*(yf - y) + y*xf - x*yf, (xf - x) + (yf - y))-{--Derivation of the formula:-The intersection point (xt, yt) satisfies the following equalities:-xt = 1 + d - yt-(yt - y) (xf - x) = (xt - x) (yf - y)-hence-(yt - y) (xf - x) = (xt - x) (yf - y)-yt (xf - x) - y xf = xt (yf - y) - x yf-yt (xf - x) - y xf = (1 + d) (yf - y) - yt (yf - y) - x yf-yt (xf - x) + yt (yf - y) = (1 + d) (yf - y) - x yf + y xf-yt = ((1 + d) (yf - y) + y xf - x yf) / (xf - x + yf - y)--General remarks:-A square is denoted by its bottom-left corner. Hero at (0, 0).-Order of processing in the first quadrant is-9-58-247-@136-so the first processed square is at (0, 1). The order is reversed-wrt the restrictive shadow casting algorithm. The line in the curent state-of mscan is not the steep line, but the shallow line,-and we start scanning from the bottom right.--The Point coordinates are cartesian. The Bump coordinates are cartesian,-translated so that the hero is at (0, 0) and rotated so that he always-looks at the first quadrant. The (Progress, Distance) cordinates-are mangled and not used for geometry.--}---- | Debug functions for PFOV:---- | Debug: calculate steeper for PFOV in another way and compare results.-debugSteeper :: Bump -> Bump -> Bump -> Bool-debugSteeper f@(B xf yf) p1@(B x1 y1) p2@(B x2 y2) =-  assert (allB (>= 0) [xf, yf, x1, y1, x2, y2]) $-  let (n1, k1) = intersect (Line p1 f) 0-      (n2, k2) = intersect (Line p2 f) 0-  in n1 * k2 <= k1 * n2---- | Debug: checks postconditions of borderLine.-debugLine :: Line -> (Bool, String)-debugLine line@(Line (B x1 y1) (B x2 y2))-  | not (allB (>= 0) [x1, y1, x2, y2]) =-      (False, "negative coordinates: " ++ show line)-  | y1 == y2 && x1 == x2 =-      (False, "ill-defined line: " ++ show line)-  | x2 - x1 == - (y2 - y1) =-      (False, "diagonal line: " ++ show line)-  | crossL0 =-      (False, "crosses diagonal below 0: " ++ show line)-  | crossG1 =-      (False, "crosses diagonal above 1: " ++ show line)-  | otherwise = (True, "")- where-  (n, k)  = line `intersect` 0-  (q, r)  = if k == 0 then (0, 0) else n `divMod` k-  crossL0 = q < 0  -- q truncated toward negative infinity-  crossG1 = q >= 1 && (q > 1 || r /= 0)

− Game/LambdaHack/Server/Fov/Shadow.hs

@@ -1,111 +0,0 @@--- | A restrictive variant of Recursive Shadow Casting FOV with infinite range.--- It's not designed for dungeons with diagonal walls and so here--- they block visibility, though they don't block movement.--- The main advantage of the algorithm is that it's very simple and fast.-module Game.LambdaHack.Server.Fov.Shadow (SBump, Interval, scan) where--import Control.Exception.Assert.Sugar-import Data.Ratio--import Game.LambdaHack.Server.Fov.Common--{--Field Of View----------------The algorithm used is a variant of Shadow Casting. We first compute-fields that are reachable (have unobstructed line of sight) from the hero's-position. Later, in Perception.hs, from this information we compute-the fields that are visible (not hidden in darkness, etc.).--As input to the algorithm, we require information about fields that-block light. As output, we get information on the reachability of all fields.-We assume that the hero is located at position (0, 0)-and we only consider fields (line, row) where line >= 0 and 0 <= row <= line.-This is just about one eighth of the whole hero's surroundings,-but the other parts can be computed in the same fashion by mirroring-or rotating the given algorithm accordingly.--      fov (blocks, maxline) =-         shadow := \empty_set-         reachable (0, 0) := True-         for l \in [ 1 .. maxline ] do-            for r \in [ 0 .. l ] do-              reachable (l, r) := ( \exists a. a \in interval (l, r) \and-                                    a \not_in shadow)-              if blocks (l, r) then-                 shadow := shadow \union interval (l, r)-              end if-            end for-         end for-         return reachable--      interval (l, r) = return [ angle (l + 0.5, r - 0.5),-                                 angle (l - 0.5, r + 0.5) ]-      angle (l, r) = return atan (r / l)--The algorithm traverses the fields line by line, row by row.-At every moment, we keep in shadow the intervals which are in shadow,-measured by their angle. A square is reachable when any point-in it is not in shadow --- the algorithm is permissive in this respect.-We could also require that a certain fraction of the field is reachable,-or a specific point. Our choice has certain consequences. For instance,-a single blocking field throws a shadow, but the fields immediately behind-the blocking field are still visible.--We can compute the interval of angles corresponding to one square field-by computing the angle of the line passing the upper left corner-and the angle of the line passing the lower right corner.-This is what interval and angle do. If a field is blocking, the interval-for the square is added to the shadow set.--}---- | Rotated and translated coordinates of 2D points, so that they fit--- in the same single octant area.-type SBump = (Progress, Distance)---- | The area left to be scanned, delimited by fractions of the original arc.--- Interval @(0, 1)@ means the whole 45 degrees arc of the processed octant--- is to be scanned.-type Interval = (Rational, Rational)---- TODO: if ever used, apply static argument transformation to isClear.--- | Calculates the list of tiles, in @SBump@ coordinates, visible from (0, 0).-scan :: (SBump -> Bool)  -- ^ clear tile predicate-     -> Distance         -- ^ the current distance from (0, 0)-     -> Interval         -- ^ the current interval to scan-     -> [SBump]-scan isClear d (s0, e) =-  let ps = downBias (s0 * fromIntegral d)   -- minimal progress to consider-      pe = upBias (e * fromIntegral d)      -- maximal progress to consider-      inside = [(p, d) | p <- [ps..pe]]-      outside-        | isClear (ps, d) = mscan (Just s0) ps pe  -- start in light-        | otherwise = mscan Nothing ps pe          -- start in shadow-  in assert (d >= 0 && e >= 0 && s0 >= 0 && pe >= ps && ps >= 0-             `blame` (d,s0,e,ps,pe)) $-     inside ++ outside- where-  -- The current state of a scan is kept in @Maybe Rational@.-  -- If it's the @Just@ case, we're in a visible interval. If @Nothing@,-  -- we're in a shadowed interval.-  mscan :: Maybe Rational -> Progress -> Progress -> [SBump]-  mscan (Just s) ps pe-    | s >= e = []                           -- empty interval-    | ps > pe  = scan isClear (d+1) (s, e)  -- reached end, scan next-    | not $ isClear (ps, d) =               -- entering shadow-        let ne = (fromIntegral ps - (1%2)) / (fromIntegral d + (1%2))-        in mscan Nothing (ps+1) pe ++ scan isClear (d+1) (s, ne)-    | otherwise = mscan (Just s) (ps+1) pe  -- continue in light--  mscan Nothing ps pe-    | ps > pe = []                          -- reached end while in shadow-    | isClear (ps, d) =                     -- moving out of shadow-        let ns = (fromIntegral ps - (1%2)) / (fromIntegral d - (1%2))-        in mscan (Just ns) (ps+1) pe-    | otherwise = mscan Nothing (ps+1) pe   -- continue in shadow---downBias, upBias :: (Integral a, Integral b) => Ratio a -> b-downBias x = round (x - 1 % (denominator x * 3))-upBias   x = round (x + 1 % (denominator x * 3))

+ Game/LambdaHack/Server/FovDigital.hs view

@@ -0,0 +1,254 @@+-- | DFOV (Digital Field of View) implemented according to specification at <http://roguebasin.roguelikedevelopment.org/index.php?title=Digital_field_of_view_implementation>.+-- This fast version of the algorithm, based on "PFOV", has AFAIK+-- never been described nor implemented before.+module Game.LambdaHack.Server.FovDigital+  ( scan+    -- * Scanning coordinate system+  , Bump(..)+    -- * Assorted minor operations+#ifdef EXPOSE_INTERNAL+    -- * Current scan parameters+  , Distance, Progress+    -- * Geometry in system @Bump@+  , Line(..), ConvexHull, Edge, EdgeInterval+    -- * Internal operations+  , steeper, addHull+  , dline, dsteeper, intersect, _debugSteeper, _debugLine+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude hiding (intersect)++import qualified Data.EnumSet as ES++import Game.LambdaHack.Common.Point hiding (inside)+import qualified Game.LambdaHack.Common.PointArray as PointArray++-- | Distance from the (0, 0) point where FOV originates.+type Distance = Int+-- | Progress along an arc with a constant distance from (0, 0).+type Progress = Int++-- | Rotated and translated coordinates of 2D points, so that the points fit+-- in a single quadrant area (e, g., quadrant I for Permissive FOV, hence both+-- coordinates positive; adjacent diagonal halves of quadrant I and II+-- for Digital FOV, hence y positive).+-- The special coordinates are written using the standard mathematical+-- coordinate setup, where quadrant I, with x and y positive,+-- is on the upper right.+data Bump = B+  { bx :: !Int+  , by :: !Int+  }+  deriving Show++-- | Straight line between points.+data Line = Line !Bump !Bump+  deriving Show++-- | Convex hull represented as a list of points.+type ConvexHull   = [Bump]+-- | An edge (comprising of a line and a convex hull)+-- of the area to be scanned.+type Edge         = (Line, ConvexHull)+-- | The area left to be scanned, delimited by edges.+type EdgeInterval = (Edge, Edge)++-- | Calculates the list of tiles, in @Bump@ coordinates, visible from (0, 0),+-- within the given sight range.+scan :: ES.EnumSet Point+     -> Distance         -- ^ visiblity distance+     -> PointArray.Array Bool+     -> (Bump -> Point)  -- ^ coordinate transformation+     -> ES.EnumSet Point+{-# INLINE scan #-}+scan accScan r fovClear tr = assert (r > 0 `blame` r) $+  -- The scanned area is a square, which is a sphere in the chessboard metric.+  dscan accScan 1 ( (Line (B 1 0) (B (-r) r), [B 0 0])+                  , (Line (B 0 0) (B (r+1) r), [B 1 0]) )+ where+  isClear :: Point -> Bool+  isClear = (fovClear PointArray.!)++  dscan :: ES.EnumSet Point -> Distance -> EdgeInterval -> ES.EnumSet Point+  dscan !accDscan !d ( s0@(!sl{-shallow line-}, !sHull)+                     , e0@(!el{-steep line-}, !eHull) ) =++    let !ps0 = let (n, k) = intersect sl d  -- minimal progress to consider+               in n `div` k+        !pe = let (n, k) = intersect el d   -- maximal progress to consider+                -- Corners obstruct view, so the steep line, constructed+                -- from corners, is itself not a part of the view,+                -- so if its intersection with the line of diagonals is only+                -- at a corner, choose the diamond leading to a smaller view.+              in -1 + n `divUp` k+        outside =+          if d < r+          then let !trBump = bump ps0+                   !accBump = ES.insert trBump accDscan+               in if isClear trBump+                  then mscanVisible accBump s0 (ps0+1)  -- start visible+                  else mscanShadowed accBump (ps0+1)    -- start in shadow+          else foldl' (\acc ps -> ES.insert (bump ps) acc) accDscan [ps0..pe]++        bump px = tr $ B px d++        -- We're in a visible interval.+        mscanVisible :: ES.EnumSet Point -> Edge -> Progress -> ES.EnumSet Point+        mscanVisible !acc !s !ps =+          if ps <= pe+          then let !trBump = bump ps+                   !accBump = ES.insert trBump acc+               in if isClear trBump  -- not entering shadow+                  then mscanVisible accBump s (ps+1)+                  else let {-# INLINE steepBump #-}+                           steepBump = B ps d+                           cmp :: Bump -> Bump -> Ordering+                           {-# INLINE cmp #-}+                           cmp = flip $ dsteeper steepBump+                           nep = maximumBy cmp (snd s)+                           neHull = addHull cmp steepBump eHull+                           ne = (dline nep steepBump, neHull)+                           accNew = dscan accBump (d+1) (s, ne)+                       in mscanShadowed accNew (ps+1)+          else dscan acc (d+1) (s, e0)  -- reached end, scan next++        -- We're in a shadowed interval.+        mscanShadowed :: ES.EnumSet Point -> Progress -> ES.EnumSet Point+        mscanShadowed !acc !ps =+          if ps <= pe+          then let !trBump = bump ps+                   !accBump = ES.insert trBump acc+               in if not $ isClear trBump  -- not moving out of shadow+                  then mscanShadowed accBump (ps+1)+                  else let {-# INLINE shallowBump #-}+                           shallowBump = B ps d+                           cmp :: Bump -> Bump -> Ordering+                           {-# INLINE cmp #-}+                           cmp = dsteeper shallowBump+                           nsp = maximumBy cmp eHull+                           nsHull = addHull cmp shallowBump sHull+                           ns = (dline nsp shallowBump, nsHull)+                       in mscanVisible accBump ns (ps+1)+          else acc  -- reached end while in shadow++    in assert (r >= d && d >= 0 && pe >= ps0 `blame` (r,d,s0,e0,ps0,pe))+         outside++-- | Check if the line from the second point to the first is more steep+-- than the line from the third point to the first. This is related+-- to the formal notion of gradient (or angle), but hacked wrt signs+-- to work fast in this particular setup. Returns True for ill-defined lines.+steeper :: Bump -> Bump -> Bump -> Ordering+{-# INLINE steeper #-}+steeper (B xf yf) (B x1 y1) (B x2 y2) =+  compare ((yf - y2)*(xf - x1)) ((yf - y1)*(xf - x2))++-- | Extends a convex hull of bumps with a new bump. Nothing needs to be done+-- if the new bump already lies within the hull. The first argument is+-- typically `steeper`, optionally negated, applied to the second argument.+addHull :: (Bump -> Bump -> Ordering)  -- ^ a comparison function+        -> Bump                        -- ^ a new bump to consider+        -> ConvexHull  -- ^ a convex hull of bumps represented as a list+        -> ConvexHull+{-# INLINE addHull #-}+addHull cmp new = (new :) . go+ where+  go (a:b:cs) | cmp b a /= GT = go (b:cs)+  go l = l++-- | Create a line from two points. Debug: check if well-defined.+dline :: Bump -> Bump -> Line+{-# INLINE dline #-}+dline p1 p2 =+  let line = Line p1 p2+  in+#ifdef WITH_EXPENSIVE_ASSERTIONS+    assert (uncurry blame $ _debugLine line)+#endif+      line++-- | Compare steepness of @(p1, f)@ and @(p2, f)@.+-- Debug: Verify that the results of 2 independent checks are equal.+dsteeper :: Bump -> Bump -> Bump -> Ordering+{-# INLINE dsteeper #-}+dsteeper = \f p1 p2 ->+  let res = steeper f p1 p2+  in+#ifdef WITH_EXPENSIVE_ASSERTIONS+     assert (res == _debugSteeper f p1 p2)+#endif+     res++-- | The X coordinate, represented as a fraction, of the intersection of+-- a given line and the line of diagonals of diamonds at distance+-- @d@ from (0, 0).+intersect :: Line -> Distance -> (Int, Int)+{-# INLINE intersect #-}+intersect (Line (B x y) (B xf yf)) d =+#ifdef WITH_EXPENSIVE_ASSERTIONS+  assert (allB (>= 0) [y, yf])+#endif+    ((d - y)*(xf - x) + x*(yf - y), yf - y)+{-+Derivation of the formula:+The intersection point (xt, yt) satisfies the following equalities:+yt = d+(yt - y) (xf - x) = (xt - x) (yf - y)+hence+(yt - y) (xf - x) = (xt - x) (yf - y)+(d - y) (xf - x) = (xt - x) (yf - y)+(d - y) (xf - x) + x (yf - y) = xt (yf - y)+xt = ((d - y) (xf - x) + x (yf - y)) / (yf - y)++General remarks:+A diamond is denoted by its left corner. Hero at (0, 0).+Order of processing in the first quadrant rotated by 45 degrees is+ 45678+  123+   @+so the first processed diamond is at (-1, 1). The order is similar+as for the restrictive shadow casting algorithm and reversed wrt PFOV.+The line in the curent state of mscan is called the shallow line,+but it's the one that delimits the view from the left, while the steep+line is on the right, opposite to PFOV. We start scanning from the left.++The Point coordinates are cartesian. The Bump coordinates are cartesian,+translated so that the hero is at (0, 0) and rotated so that he always+looks at the first (rotated 45 degrees) quadrant. The (Progress, Distance)+cordinates coincide with the Bump coordinates, unlike in PFOV.+-}++-- | Debug functions for DFOV:++-- | Debug: calculate steeper for DFOV in another way and compare results.+_debugSteeper :: Bump -> Bump -> Bump -> Ordering+{-# INLINE _debugSteeper #-}+_debugSteeper f@(B _xf yf) p1@(B _x1 y1) p2@(B _x2 y2) =+  assert (allB (>= 0) [yf, y1, y2]) $+  let (n1, k1) = intersect (Line p1 f) 0+      (n2, k2) = intersect (Line p2 f) 0+  in compare (k1 * n2) (n1 * k2)++-- | Debug: check if a view border line for DFOV is legal.+_debugLine :: Line -> (Bool, String)+{-# INLINE _debugLine #-}+_debugLine line@(Line (B x1 y1) (B x2 y2))+  | not (allB (>= 0) [y1, y2]) =+      (False, "negative coordinates: " ++ show line)+  | y1 == y2 && x1 == x2 =+      (False, "ill-defined line: " ++ show line)+  | y1 == y2 =+      (False, "horizontal line: " ++ show line)+  | crossL0 =+      (False, "crosses the X axis below 0: " ++ show line)+  | crossG1 =+      (False, "crosses the X axis above 1: " ++ show line)+  | otherwise = (True, "")+ where+  (n, k)  = line `intersect` 0+  (q, r)  = if k == 0 then (0, 0) else n `divMod` k+  crossL0 = q < 0  -- q truncated toward negative infinity+  crossG1 = q >= 1 && (q > 1 || r /= 0)

+ Game/LambdaHack/Server/HandleAtomicM.hs view

@@ -0,0 +1,300 @@+-- | Handle atomic commands before they are executed to change State+-- and sent to clients.+module Game.LambdaHack.Server.HandleAtomicM+  ( cmdAtomicSemSer+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , addItemToActor, updateSclear, updateSlit+  , invalidateLucidLid, invalidateLucidAid+  , actorHasShine, itemAffectsShineRadius, itemAffectsPerRadius+  , addPerActor, addPerActorAny, deletePerActor, deletePerActorAny+  , invalidatePerActor, reconsiderPerActor, invalidatePerLid+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES++import Game.LambdaHack.Atomic+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Content.TileKind (TileKind)+import Game.LambdaHack.Server.Fov+import Game.LambdaHack.Server.MonadServer+import Game.LambdaHack.Server.State++-- | Effect of atomic actions on server state is calculated+-- with the global state from before the command is executed.+cmdAtomicSemSer :: MonadServer m => UpdAtomic -> m ()+cmdAtomicSemSer cmd = case cmd of+  UpdCreateActor aid b _ -> do+    discoAspect <- getsServer sdiscoAspect+    let aspectRecord = aspectRecordFromActorServer discoAspect b+        f = EM.insert aid aspectRecord+    modifyServer $ \ser -> ser {sactorAspect = f $ sactorAspect ser}+    actorAspect <- getsServer sactorAspect+    -- We don't have the body in the State yet, hence no @invalidateLucidAid@.+    when (actorHasShine actorAspect aid) $ invalidateLucidLid $ blid b+    addPerActor aid b+  UpdDestroyActor aid b _ -> do+    deletePerActor aid b+    actorAspectOld <- getsServer sactorAspect+    when (actorHasShine actorAspectOld aid) $ invalidateLucidLid $ blid b+    modifyServer $ \ser -> ser {sactorAspect = EM.delete aid $ sactorAspect ser}+    modifyServer $ \ser ->+      ser {sactorTime = EM.adjust (EM.adjust (EM.delete aid) (blid b)) (bfid b)+                        (sactorTime ser)}+  UpdCreateItem iid _ _ (CFloor lid _) -> do+    discoAspect <- getsServer sdiscoAspect+    when (itemAffectsShineRadius discoAspect iid []) $ invalidateLucidLid lid+  UpdCreateItem iid _ (k, _) (CActor aid store) -> do+    discoAspect <- getsServer sdiscoAspect+    when (itemAffectsShineRadius discoAspect iid [store]) $+      invalidateLucidAid aid+    when (store `elem` [CEqp, COrgan]) $ do+      addItemToActor iid k aid+      when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid+  UpdDestroyItem iid _ _ (CFloor lid _) -> do+    discoAspect <- getsServer sdiscoAspect+    when (itemAffectsShineRadius discoAspect iid []) $ invalidateLucidLid lid+  UpdDestroyItem iid _ (k, _) (CActor aid store) -> do+    discoAspect <- getsServer sdiscoAspect+    when (itemAffectsShineRadius discoAspect iid [store]) $+      invalidateLucidAid aid+    when (store `elem` [CEqp, COrgan]) $ do+      addItemToActor iid (-k) aid+      when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid+  UpdSpotActor aid b _ -> do+    -- On server, it does't affect aspects, but does affect lucid (Ascend).+    actorAspect <- getsServer sactorAspect+    -- We don't have the body in the State yet, hence no @invalidateLucidAid@.+    when (actorHasShine actorAspect aid) $ invalidateLucidLid $ blid b+    addPerActor aid b+  UpdLoseActor aid b _ -> do+    -- On server, it does't affect aspects, but does affect lucid (Ascend).+    deletePerActor aid b+    actorAspectOld <- getsServer sactorAspect+    when (actorHasShine actorAspectOld aid) $ invalidateLucidLid $ blid b+    modifyServer $ \ser ->+      ser {sactorTime = EM.adjust (EM.adjust (EM.delete aid) (blid b)) (bfid b)+                        (sactorTime ser)}+  UpdSpotItem _ iid _ _ (CFloor lid _) -> do+    discoAspect <- getsServer sdiscoAspect+    when (itemAffectsShineRadius discoAspect iid []) $ invalidateLucidLid lid+  UpdSpotItem _ iid _ (k, _) (CActor aid store) -> do+    discoAspect <- getsServer sdiscoAspect+    when (itemAffectsShineRadius discoAspect iid [store]) $+      invalidateLucidAid aid+    when (store `elem` [CEqp, COrgan]) $ do+      addItemToActor iid k aid+      when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid+  UpdLoseItem _ iid _ _ (CFloor lid _) -> do+    discoAspect <- getsServer sdiscoAspect+    when (itemAffectsShineRadius discoAspect iid []) $ invalidateLucidLid lid+  UpdLoseItem _ iid _ (k, _) (CActor aid store) -> do+    discoAspect <- getsServer sdiscoAspect+    when (itemAffectsShineRadius discoAspect iid [store]) $+      invalidateLucidAid aid+    when (store `elem` [CEqp, COrgan]) $ do+      addItemToActor iid (-k) aid+      when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid+  UpdMoveActor aid _ _ -> do+    actorAspect <- getsServer sactorAspect+    when (actorHasShine actorAspect aid) $ invalidateLucidAid aid+    invalidatePerActor aid+  UpdDisplaceActor aid1 aid2 -> do+    actorAspect <- getsServer sactorAspect+    when (actorHasShine actorAspect aid1 || actorHasShine actorAspect aid2) $+      invalidateLucidAid aid1  -- the same lid as aid2+    invalidatePerActor aid1+    invalidatePerActor aid2+  UpdMoveItem iid k aid s1 s2 -> do+    discoAspect <- getsServer sdiscoAspect+    let itemAffectsPer = itemAffectsPerRadius discoAspect iid+        invalidatePer = when itemAffectsPer $ reconsiderPerActor aid+        itemAffectsShine = itemAffectsShineRadius discoAspect iid [s1, s2]+        invalidateLucid = when itemAffectsShine $ invalidateLucidAid aid+    case s1 of+      CEqp -> case s2 of+        COrgan -> return ()+        _ -> do+          addItemToActor iid (-k) aid+          invalidatePer+          invalidateLucid+      COrgan -> case s2 of+        CEqp -> return ()+        _ -> do+          addItemToActor iid (-k) aid+          invalidatePer+          invalidateLucid+      _ -> do+        when (s2 `elem` [CEqp, COrgan]) $ do+          addItemToActor iid k aid+          invalidatePer+        invalidateLucid  -- from itemAffects, s2 provides light or s1 is CGround+  UpdRefillCalm aid n -> do+    actorAspect <- getsServer sactorAspect+    body <- getsState $ getActorBody aid+    let AspectRecord{aSight} = actorAspect EM.! aid+        radiusOld = boundSightByCalm aSight (bcalm body)+        radiusNew = boundSightByCalm aSight (bcalm body + n)+    when (radiusOld /= radiusNew) $ invalidatePerActor aid+  UpdLeadFaction{} -> invalidateArenas+  UpdRecordKill{} -> invalidateArenas+  UpdAlterTile lid pos fromTile toTile -> do+    clearChanged <- updateSclear lid pos fromTile toTile+    litChanged <- updateSlit lid pos fromTile toTile+    when (clearChanged || litChanged) $ invalidateLucidLid lid+    when clearChanged $ invalidatePerLid lid+  _ -> return ()++invalidateArenas :: MonadServer m => m ()+invalidateArenas = modifyServer $ \ser -> ser {svalidArenas = False}++addItemToActor :: MonadServer m => ItemId -> Int -> ActorId -> m ()+addItemToActor iid k aid = do+  discoAspect <- getsServer sdiscoAspect+  let arItem = discoAspect EM.! iid+      g arActor = sumAspectRecord [(arActor, 1), (arItem, k)]+      f = EM.adjust g aid+  modifyServer $ \ser -> ser {sactorAspect = f $ sactorAspect ser}++updateSclear :: MonadServer m+             => LevelId -> Point -> Kind.Id TileKind -> Kind.Id TileKind -> m Bool+updateSclear lid pos fromTile toTile = do+  Kind.COps{coTileSpeedup} <- getsState scops+  let fromClear = Tile.isClear coTileSpeedup fromTile+      toClear = Tile.isClear coTileSpeedup toTile+  if fromClear == toClear then return False else do+    let f FovClear{fovClear} =+          FovClear $ fovClear PointArray.// [(pos, toClear)]+    modifyServer $ \ser ->+      ser {sfovClearLid = EM.adjust f lid $ sfovClearLid ser}+    return True++updateSlit :: MonadServer m+           => LevelId -> Point -> Kind.Id TileKind -> Kind.Id TileKind -> m Bool+updateSlit lid pos fromTile toTile = do+  Kind.COps{coTileSpeedup} <- getsState scops+  let fromLit = Tile.isLit coTileSpeedup fromTile+      toLit = Tile.isLit coTileSpeedup toTile+  if fromLit == toLit then return False else do+    let f (FovLit set) =+          FovLit $ if toLit then ES.insert pos set else ES.delete pos set+    modifyServer $ \ser -> ser {sfovLitLid = EM.adjust f lid $ sfovLitLid ser}+    return True++invalidateLucidLid :: MonadServer m => LevelId -> m ()+invalidateLucidLid lid =+  modifyServer $ \ser ->+    ser { sfovLucidLid = EM.insert lid FovInvalid $ sfovLucidLid ser+        , sperValidFid = EM.map (EM.insert lid False) $ sperValidFid ser }++invalidateLucidAid :: MonadServer m => ActorId  -> m ()+invalidateLucidAid aid = do+  lid <- getsState $ blid . getActorBody aid+  invalidateLucidLid lid++actorHasShine :: ActorAspect -> ActorId -> Bool+actorHasShine actorAspect aid = case EM.lookup aid actorAspect of+  Just AspectRecord{aShine} -> aShine > 0+  Nothing -> assert `failure` aid++itemAffectsShineRadius :: DiscoveryAspect -> ItemId -> [CStore] -> Bool+itemAffectsShineRadius discoAspect iid stores =+  (null stores || not (null $ intersect stores [CEqp, COrgan, CGround]))+  && case EM.lookup iid discoAspect of+    Just AspectRecord{aShine} -> aShine /= 0+    Nothing -> assert `failure` iid++itemAffectsPerRadius :: DiscoveryAspect -> ItemId -> Bool+itemAffectsPerRadius discoAspect iid =+  case EM.lookup iid discoAspect of+    Just AspectRecord{aSight, aSmell, aNocto} ->+      aSight /= 0 || aSmell /= 0 || aNocto /= 0+    Nothing -> assert `failure` iid++addPerActor :: MonadServer m => ActorId -> Actor -> m ()+addPerActor aid b = do+  actorAspect <- getsServer sactorAspect+  let AspectRecord{..} = actorAspect EM.! aid+  unless (aSight <= 0 && aNocto <= 0 && aSmell <= 0) $ addPerActorAny aid b++addPerActorAny :: MonadServer m => ActorId -> Actor -> m ()+addPerActorAny aid b = do+  let fid = bfid b+      lid = blid b+      f PerceptionCache{perActor} = PerceptionCache+        { ptotal = FovInvalid+        , perActor = EM.insert aid FovInvalid perActor }+  modifyServer $ \ser ->+    ser { sperCacheFid = EM.adjust (EM.adjust f lid) fid $ sperCacheFid ser+        , sperValidFid = EM.adjust (EM.insert lid False) fid+                         $ sperValidFid ser }++deletePerActor :: MonadServer m => ActorId -> Actor -> m ()+deletePerActor aid b = do+  actorAspect <- getsServer sactorAspect+  let AspectRecord{..} = actorAspect EM.! aid+  unless (aSight <= 0 && aNocto <= 0 && aSmell <= 0) $ deletePerActorAny aid b++deletePerActorAny :: MonadServer m => ActorId -> Actor -> m ()+deletePerActorAny aid b = do+  let fid = bfid b+      lid = blid b+      f PerceptionCache{perActor} = PerceptionCache+        { ptotal = FovInvalid+        , perActor = EM.delete aid perActor }+  modifyServer $ \ser ->+    ser { sperCacheFid = EM.adjust (EM.adjust f lid) fid $ sperCacheFid ser+        , sperValidFid = EM.adjust (EM.insert lid False) fid+                         $ sperValidFid ser }++invalidatePerActor :: MonadServer m => ActorId -> m ()+invalidatePerActor aid = do+  actorAspect <- getsServer sactorAspect+  let AspectRecord{..} = actorAspect EM.! aid+  unless (aSight <= 0 && aNocto <= 0 && aSmell <= 0) $ do+    b <- getsState $ getActorBody aid+    addPerActorAny aid b++reconsiderPerActor :: MonadServer m => ActorId -> m ()+reconsiderPerActor aid = do+  b <- getsState $ getActorBody aid+  actorAspect <- getsServer sactorAspect+  let AspectRecord{..} = actorAspect EM.! aid+  if aSight <= 0 && aNocto <= 0 && aSmell <= 0+  then do+    perCacheFid <- getsServer sperCacheFid+    when (EM.member aid $ perActor ((perCacheFid EM.! bfid b) EM.! blid b)) $+      deletePerActorAny aid b+  else addPerActorAny aid b++invalidatePerLid :: MonadServer m => LevelId -> m ()+invalidatePerLid lid = do+  let f pc@PerceptionCache{perActor}+        | EM.null perActor = pc+        | otherwise = PerceptionCache+          { ptotal = FovInvalid+          , perActor = EM.map (const FovInvalid) perActor }+  modifyServer $ \ser ->+    let perCacheFidNew = EM.map (EM.adjust f lid) $ sperCacheFid ser+        g fid valid |+          ptotal ((perCacheFidNew EM.! fid) EM.! lid) == FovInvalid =+          EM.insert lid False valid+        g _ valid = valid+    in ser { sperCacheFid = perCacheFidNew+           , sperValidFid = EM.mapWithKey g $ sperValidFid ser }

+ Game/LambdaHack/Server/HandleEffectM.hs view

@@ -0,0 +1,1331 @@+{-# LANGUAGE TupleSections #-}+-- | Handle effects (most often caused by requests sent by clients).+module Game.LambdaHack.Server.HandleEffectM+  ( applyItem, meleeEffectAndDestroy, effectAndDestroy, itemEffectEmbedded+  , dropCStoreItem, dominateFidSfx, pickDroppable, cutCalm+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Data.Bits (xor)+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.HashMap.Strict as HM+import Data.Key (mapWithKeyM_)++import Game.LambdaHack.Atomic+import qualified Game.LambdaHack.Common.Ability as Ability+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import qualified Game.LambdaHack.Common.Dice as Dice+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.Perception+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Content.ItemKind as IK+import Game.LambdaHack.Content.ModeKind+import qualified Game.LambdaHack.Content.TileKind as TK+import Game.LambdaHack.Server.CommonM+import Game.LambdaHack.Server.ItemM+import Game.LambdaHack.Server.MonadServer+import Game.LambdaHack.Server.PeriodicM+import Game.LambdaHack.Server.State++-- + Semantics of effects++applyItem :: (MonadAtomic m, MonadServer m)+          => ActorId -> ItemId -> CStore -> m ()+applyItem aid iid cstore = do+  execSfxAtomic $ SfxApply aid iid cstore+  let c = CActor aid cstore+  meleeEffectAndDestroy aid aid iid c++applyMeleeDamage :: (MonadAtomic m, MonadServer m)+                 => ActorId -> ActorId -> ItemId -> m Bool+applyMeleeDamage source target iid = do+  itemBase <- getsState $ getItemBody iid+  if jdamage itemBase <= 0 then return False else do  -- speedup+    sb <- getsState $ getActorBody source+    tb <- getsState $ getActorBody target+    actorAspect <- getsServer sactorAspect+    hurtMult <- getsState $ armorHurtBonus actorAspect source target+    dmg <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) $ jdamage itemBase+    let ar = actorAspect EM.! target+        hpMax = aMaxHP ar+        rawDeltaHP = fromIntegral hurtMult * xM dmg `divUp` 100+        speedDeltaHP = case btrajectory sb of+          Just (_, speed) -> - modifyDamageBySpeed rawDeltaHP speed+          Nothing -> - rawDeltaHP+        -- Any amount of damage is serious, because next turn a stronger+        -- projectile or melee weapon may be used and also it accumulates.+        serious = speedDeltaHP < 0 && source /= target && not (bproj tb)+        deltaHP | serious = -- if HP overfull, at least cut back to max HP+                            min speedDeltaHP (xM hpMax - bhp tb)+                | otherwise = speedDeltaHP+    if deltaHP < 0 then do  -- damage the target, never heal+      execUpdAtomic $ UpdRefillHP target deltaHP+      when serious $ cutCalm target+      return True+    else return False++-- Here melee damage is applied. This is necessary so that the same+-- AI benefit calculation may be used for flinging and for applying items.+meleeEffectAndDestroy :: (MonadAtomic m, MonadServer m)+                       => ActorId -> ActorId -> ItemId -> Container -> m ()+meleeEffectAndDestroy source target iid c = do+  meleePerformed <- applyMeleeDamage source target iid+  bag <- getsState $ getContainerBag c+  case iid `EM.lookup` bag of+    Nothing -> assert `failure` (source, target, iid, c)+    Just kit -> do+      itemToF <- itemToFullServer+      let itemFull = itemToF iid kit+      case itemDisco itemFull of+        Just ItemDisco {itemKind=IK.ItemKind{IK.ieffects}} ->+          effectAndDestroy meleePerformed source target iid c False ieffects+                           itemFull+        _ -> assert `failure` (source, target, iid, c)++effectAndDestroy :: (MonadAtomic m, MonadServer m)+                 => Bool -> ActorId -> ActorId -> ItemId -> Container -> Bool+                 -> [IK.Effect] -> ItemFull+                 -> m ()+effectAndDestroy meleePerformed _ _ iid container periodic []+                 itemFull@ItemFull{..} =+  -- No identification occurs if effects are null. This case is also a speedup.+  if meleePerformed then do  -- melee may cause item destruction+    let (imperishable, kit) = imperishableKit [] periodic itemTimer itemFull+    unless imperishable $+      execUpdAtomic $ UpdLoseItem False iid itemBase kit container+  else return ()+effectAndDestroy meleePerformed source target iid container periodic effs+                 itemFull@ItemFull{..} = do+  let timeout = case itemDisco of+        Just ItemDisco{itemAspect=Just ar} -> aTimeout ar+        _ -> assert `failure` itemDisco+  lid <- getsState $ lidFromC container+  localTime <- getsState $ getLocalTime lid+  let it1 = let timeoutTurns = timeDeltaScale (Delta timeTurn) timeout+                charging startT = timeShift startT timeoutTurns > localTime+            in filter charging itemTimer+      len = length it1+      recharged = len < itemK+      it2 = if timeout /= 0 && recharged then localTime : it1 else itemTimer+      !_A = assert (len <= itemK `blame` (source, target, iid, container)) ()+  -- We use up the charge even if eventualy every effect fizzles. Tough luck.+  -- At least we don't destroy the item in such case. Also, we ID it regardless.+  unless (itemTimer == it2) $+    execUpdAtomic $ UpdTimeItem iid container itemTimer it2+  -- If the activation is not periodic, trigger at least the effects+  -- that are not recharging and so don't depend on @recharged@.+  -- Also, if the item was meleed with, let it get destroyed, if perishable,+  -- and let it get identified, even if no effect was eventually triggered.+  -- Otherwise don't even id the item --- no risk of destruction, no id.+  when (not periodic || recharged || meleePerformed) $ do+    -- We have to destroy the item before the effect affects the item+    -- or the actor holding it or standing on it (later on we could+    -- lose track of the item and wouldn't be able to destroy it) .+    -- This is OK, because we don't remove the item type from various+    -- item dictionaries, just an individual copy from the container,+    -- so, e.g., the item can be identified after it's removed.+    let (imperishable, kit) = imperishableKit effs periodic it2 itemFull+    unless imperishable $+      execUpdAtomic $ UpdLoseItem False iid itemBase kit container+    -- At this point, the item is potentially no longer in container @c@,+    -- so we don't pass @c@ along.+    triggeredEffect <-+      itemEffectDisco source target iid container recharged periodic effs+    let triggered = triggeredEffect || meleePerformed+    -- If none of item's effects was performed, we try to recreate the item.+    -- Regardless, we don't rewind the time, because some info is gained+    -- (that the item does not exhibit any effects in the given context).+    unless (triggered || imperishable) $+      execUpdAtomic $ UpdSpotItem False iid itemBase kit container++imperishableKit :: [IK.Effect] -> Bool -> ItemTimer -> ItemFull+                -> (Bool, ItemQuant)+imperishableKit effs periodic it2 ItemFull{..} =+  let permanent = let tmpEffect :: IK.Effect -> Bool+                      tmpEffect IK.Temporary{} = True+                      tmpEffect (IK.Recharging IK.Temporary{}) = True+                      tmpEffect (IK.OnSmash IK.Temporary{}) = True+                      tmpEffect _ = False+                  in not $ any tmpEffect effs+      fragile = IK.Fragile `elem` jfeature itemBase+      durable = IK.Durable `elem` jfeature itemBase+      imperishable = durable && not fragile || periodic && permanent+      kit = if permanent || periodic then (1, take 1 it2) else (itemK, it2)+  in (imperishable, kit)++-- One item of each @iid@ is triggered at once. If there are more copies,+-- they are left to be triggered next time.+itemEffectEmbedded :: (MonadAtomic m, MonadServer m)+                   => ActorId -> Point -> ItemBag -> m ()+itemEffectEmbedded aid tpos bag = do+  sb <- getsState $ getActorBody aid+  let c = CEmbed (blid sb) tpos+      f iid = do+        -- No block against tile, hence unconditional.+        execSfxAtomic $ SfxTrigger aid tpos+        meleeEffectAndDestroy aid aid iid c+  mapM_ f $ EM.keys bag++-- | The source actor affects the target actor, with a given item.+-- If any of the effects fires up, the item gets identified. This function+-- is mutually recursive with @effect@ and so it's a part of @Effect@+-- semantics.+--+-- Note that if we activate a durable item, e.g., armor, from the ground,+-- it will get identified, which is perfectly fine, until we wanto to add+-- sticky armor that can't be easily taken off (and, e.g., has some maluses).+itemEffectDisco :: (MonadAtomic m, MonadServer m)+                => ActorId -> ActorId -> ItemId -> Container -> Bool -> Bool+                -> [IK.Effect]+                -> m Bool+itemEffectDisco source target iid c recharged periodic effs = do+  discoKind <- getsServer sdiscoKind+  item <- getsState $ getItemBody iid+  case EM.lookup (jkindIx item) discoKind of+    Just KindMean{kmKind} -> do+      seed <- getsServer $ (EM.! iid) . sitemSeedD+      execUpdAtomic $ UpdDiscover c iid kmKind seed+      itemEffect source target iid c recharged periodic effs+    _ -> assert `failure` (source, target, iid, item)++itemEffect :: (MonadAtomic m, MonadServer m)+           => ActorId -> ActorId -> ItemId -> Container -> Bool -> Bool+           -> [IK.Effect]+           -> m Bool+itemEffect source target iid c recharged periodic effects = do+  trs <- mapM (effectSem source target iid c recharged periodic) effects+  let triggered = or trs+  sb <- getsState $ getActorBody source+  -- Announce no effect, which is rare and wastes time, so noteworthy.+  unless (triggered  -- some effect triggered, so feedback comes from them+          || periodic  -- don't spam from fizzled periodic effects+          || bproj sb  -- don't spam, projectiles can be very numerous+          || all (not . IK.forApplyEffect) effects) $+    execSfxAtomic $ SfxMsgFid (bfid sb) SfxFizzles+  return triggered++-- | The source actor affects the target actor, with a given effect and power.+-- Both actors are on the current level and can be the same actor.+-- The item may or may not still be in the container.+-- The boolean result indicates if the effect actually fired up,+-- as opposed to fizzled.+effectSem :: (MonadAtomic m, MonadServer m)+          => ActorId -> ActorId -> ItemId -> Container -> Bool -> Bool+          -> IK.Effect+          -> m Bool+effectSem source target iid c recharged periodic effect = do+  let recursiveCall = effectSem source target iid c recharged periodic+  sb <- getsState $ getActorBody source+  pos <- getsState $ posFromC c+  -- @execSfx@ usually comes last in effect semantics, but not always+  -- and we are likely to introduce more variety.+  let execSfx = execSfxAtomic $ SfxEffect (bfid sb) target effect 0+  case effect of+    IK.ELabel _ -> return False+    IK.EqpSlot _ -> return False+    IK.Burn nDm -> effectBurn nDm source target+    IK.Explode t -> effectExplode execSfx t target+    IK.RefillHP p -> effectRefillHP p source target+    IK.RefillCalm p -> effectRefillCalm execSfx p source target+    IK.Dominate -> effectDominate recursiveCall source target+    IK.Impress -> effectImpress recursiveCall execSfx source target+    IK.Summon grp p -> effectSummon execSfx grp p iid source target periodic+    IK.Ascend p -> effectAscend recursiveCall execSfx p source target pos+    IK.Escape{} -> effectEscape source target+    IK.Paralyze p -> effectParalyze execSfx p target+    IK.InsertMove p -> effectInsertMove execSfx p target+    IK.Teleport p -> effectTeleport execSfx p source target+    IK.CreateItem store grp tim -> effectCreateItem Nothing target store grp tim+    IK.DropItem n k store grp -> effectDropItem execSfx n k store grp target+    IK.PolyItem -> effectPolyItem execSfx source target+    IK.Identify -> effectIdentify execSfx iid source target+    IK.Detect radius -> effectDetect execSfx radius target+    IK.DetectActor radius -> effectDetectActor execSfx radius target+    IK.DetectItem radius -> effectDetectItem execSfx radius target+    IK.DetectExit radius -> effectDetectExit execSfx radius target+    IK.DetectHidden radius -> effectDetectHidden execSfx radius target pos+    IK.SendFlying tmod ->+      effectSendFlying execSfx tmod source target Nothing+    IK.PushActor tmod ->+      effectSendFlying execSfx tmod source target (Just True)+    IK.PullActor tmod ->+      effectSendFlying execSfx tmod source target (Just False)+    IK.DropBestWeapon -> effectDropBestWeapon execSfx target+    IK.ActivateInv symbol -> effectActivateInv execSfx target symbol+    IK.ApplyPerfume -> effectApplyPerfume execSfx target+    IK.OneOf l -> effectOneOf recursiveCall l+    IK.OnSmash _ -> return False  -- ignored under normal circumstances+    IK.Recharging e -> effectRecharging recursiveCall e recharged+    IK.Temporary _ -> effectTemporary execSfx source iid c+    IK.Unique -> return False+    IK.Periodic -> return False++-- + Individual semantic functions for effects++-- ** Burn++-- Damage from fire. Not affected by armor.+effectBurn :: (MonadAtomic m, MonadServer m)+           => Dice.Dice -> ActorId -> ActorId+           -> m Bool+effectBurn nDm source target = do+  tb <- getsState $ getActorBody target+  actorAspect <- getsServer sactorAspect+  let ar = actorAspect EM.! target+      hpMax = aMaxHP ar+  n <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm+  let rawDeltaHP = - (fromIntegral $ xM n)+      -- We ignore minor burns.+      serious = not (bproj tb) && source /= target && n > 1+      deltaHP | serious = -- if HP overfull, at least cut back to max HP+                          min rawDeltaHP (xM hpMax - bhp tb)+              | otherwise = rawDeltaHP+  if deltaHP == 0+  then return False+  else do+    sb <- getsState $ getActorBody source+    -- Display the effect.+    let reportedEffect = IK.Burn $ Dice.intToDice n+    execSfxAtomic $ SfxEffect (bfid sb) target reportedEffect deltaHP+    -- Damage the target.+    execUpdAtomic $ UpdRefillHP target deltaHP+    when serious $ cutCalm target+    return True++-- ** Explode++effectExplode :: (MonadAtomic m, MonadServer m)+              => m () -> GroupName ItemKind -> ActorId -> m Bool+effectExplode execSfx cgroup target = do+  execSfx+  tb <- getsState $ getActorBody target+  let itemFreq = [(cgroup, 1)]+      -- Explosion particles are placed among organs of the victim:+      container = CActor target COrgan+  m2 <- rollAndRegisterItem (blid tb) itemFreq container False Nothing+  let (iid, (ItemFull{itemBase, itemK}, _)) =+        fromMaybe (assert `failure` cgroup) m2+      Point x y = bpos tb+      semirandom = fromEnum (jkindIx itemBase)+      projectN k100 (n, _) = do+        -- We pick a point at the border, not inside, to have a uniform+        -- distribution for the points the line goes through at each distance+        -- from the source. Otherwise, e.g., the points on cardinal+        -- and diagonal lines from the source would be more common.+        let veryrandom = k100 `xor` (semirandom + n)+            fuzz = 5 + veryrandom `mod` 5+            k | itemK >= 8 && n < 4 = 0  -- speed up if only a handful remains+              | n < 16 && n >= 12 = 12+              | n < 12 && n >= 8 = 8+              | n < 8 && n >= 4 = 4+              | otherwise = min n 16  -- fire in groups of 16 including old duds+            psAll =+              [ Point (x - 12) (y + 12)+              , Point (x + 12) (y + 12)+              , Point (x - 12) (y - 12)+              , Point (x + 12) (y - 12)+              , Point (x - 12) y+              , Point (x + 12) y+              , Point x (y + 12)+              , Point x (y - 12)+              , Point (x - 12) $ y + fuzz+              , Point (x + 12) $ y + fuzz+              , Point (x - 12) $ y - fuzz+              , Point (x + 12) $ y - fuzz+              , flip Point (y - 12) $ x + fuzz+              , flip Point (y + 12) $ x + fuzz+              , flip Point (y - 12) $ x - fuzz+              , flip Point (y + 12) $ x - fuzz+              ]+            ps = take k psAll+        forM_ ps $ \tpxy -> do+          let req = ReqProject tpxy veryrandom iid COrgan+          mfail <- projectFail target tpxy veryrandom iid COrgan True+          case mfail of+            Nothing -> return ()+            Just ProjectBlockTerrain -> return ()+            Just ProjectBlockActor | not $ bproj tb -> return ()+            Just failMsg -> execFailure target req failMsg+      tryFlying 0 = return ()+      tryFlying k100 = do+        -- Explosion particles are placed among organs of the victim:+        bag2 <- getsState $ borgan . getActorBody target+        let mn2 = EM.lookup iid bag2+        case mn2 of+          Nothing -> return ()+          Just n2 -> do+            projectN k100 n2+            tryFlying $ k100 - 1+  -- Particles that fail to take off, bounce off obstacles up to 100 times+  -- in total, trying to fly in different directions.+  tryFlying 100+  bag3 <- getsState $ borgan . getActorBody target+  let mn3 = EM.lookup iid bag3+  -- Give up and destroy the remaining particles, if any.+  maybe (return ()) (\kit -> execUpdAtomic+                             $ UpdLoseItem False iid itemBase kit container) mn3+  return True  -- we neglect verifying that at least one projectile got off++-- ** RefillHP++-- Unaffected by armor.+effectRefillHP :: (MonadAtomic m, MonadServer m)+               => Int -> ActorId -> ActorId -> m Bool+effectRefillHP power source target = do+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  actorAspect <- getsServer sactorAspect+  let ar = actorAspect EM.! target+      hpMax = aMaxHP ar+      -- We ignore light poison and similar -1HP per turn annoyances.+      serious = not (bproj tb) && source /= target && abs power > 1+      deltaHP | power < 0 && serious =  -- if overfull, at least cut back to max+                  min (xM power) (xM hpMax - bhp tb)+              | otherwise = min (xM power) (max 0 $ xM 999 - bhp tb)+                                                         -- UI limitation+  curChalSer <- getsServer $ scurChalSer . sdebugSer+  fact <- getsState $ (EM.! bfid tb) . sfactionD+  if | cfish curChalSer && power > 0+       && fhasUI (gplayer fact) && bfid sb /= bfid tb -> do+       execSfxAtomic $ SfxMsgFid (bfid tb) SfxColdFish+       return False+     | deltaHP == 0 -> return False+     | otherwise -> do+       execSfxAtomic $ SfxEffect (bfid sb) target (IK.RefillHP power) deltaHP+       execUpdAtomic $ UpdRefillHP target deltaHP+       when (deltaHP < 0 && serious) $ cutCalm target+       return True++cutCalm :: (MonadAtomic m, MonadServer m) => ActorId -> m ()+cutCalm target = do+  tb <- getsState $ getActorBody target+  actorAspect <- getsServer sactorAspect+  let ar = actorAspect EM.! target+      upperBound = if hpTooLow tb ar+                   then 0  -- to trigger domination, etc.+                   else xM $ aMaxCalm ar+      deltaCalm = min minusM1 (upperBound - bcalm tb)+  -- HP loss decreases Calm by at least @minusM1@ to avoid "hears something",+  -- which is emitted when decreasing Calm by @minusM@.+  udpateCalm target deltaCalm++-- ** RefillCalm++effectRefillCalm ::  (MonadAtomic m, MonadServer m)+                 => m () -> Int -> ActorId -> ActorId -> m Bool+effectRefillCalm execSfx power source target = do+  tb <- getsState $ getActorBody target+  actorAspect <- getsServer sactorAspect+  let ar = actorAspect EM.! target+      calmMax = aMaxCalm ar+      serious = not (bproj tb) && source /= target && power > 1+      deltaCalm | power < 0 && serious =  -- if overfull, at least cut to max+                    min (xM power) (xM calmMax - bcalm tb)+                | otherwise = min (xM power) (max 0 $ xM 999 - bcalm tb)+                                                           -- UI limitation+  if deltaCalm == 0 then return False+  else do+    execSfx+    udpateCalm target deltaCalm+    return True++-- ** Dominate++effectDominate :: (MonadAtomic m, MonadServer m)+               => (IK.Effect -> m Bool)+               -> ActorId -> ActorId+               -> m Bool+effectDominate recursiveCall source target = do+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  if | bproj tb -> return False+     | bfid tb == bfid sb ->+       -- Dominate is rather on projectiles than on items, so alternate effect+       -- is useful to avoid boredom if domination can't happen.+       recursiveCall IK.Impress+     | otherwise -> dominateFidSfx (bfid sb) target++dominateFidSfx :: (MonadAtomic m, MonadServer m)+               => FactionId -> ActorId -> m Bool+dominateFidSfx fid target = do+  tb <- getsState $ getActorBody target+  -- Actors that don't move freely can't be dominated, for otherwise,+  -- when they are the last survivors, they could get stuck+  -- and the game wouldn't end.+  actorAspect <- getsServer sactorAspect+  let ar = actorAspect EM.! target+      actorMaxSk = aSkills ar+      -- Check that the actor can move, also between levels and through doors.+      -- Otherwise, it's too awkward for human player to control.+      canMove = EM.findWithDefault 0 Ability.AbMove actorMaxSk > 0+                && EM.findWithDefault 0 Ability.AbAlter actorMaxSk+                   >= fromEnum TK.talterForStairs+  if canMove && not (bproj tb) then do+    let execSfx = execSfxAtomic $ SfxEffect fid target IK.Dominate 0+    execSfx  -- if actor ours, possibly the last occasion to see him+    gameOver <- dominateFid fid target+    unless gameOver  -- avoid spam+      execSfx  -- see the actor as theirs, unless position not visible+    return True+  else+    return False++dominateFid :: (MonadAtomic m, MonadServer m) => FactionId -> ActorId -> m Bool+dominateFid fid target = do+  Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops+  tb0 <- getsState $ getActorBody target+  -- At this point the actor's body exists and his items are not dropped.+  deduceKilled target+  electLeader (bfid tb0) (blid tb0) target+  fact <- getsState $ (EM.! bfid tb0) . sfactionD+  -- Prevent the faction's stash from being lost in case they are not spawners.+  when (isNothing $ _gleader fact) $ moveStores False target CSha CInv+  tb <- getsState $ getActorBody target+  ais <- getsState $ getCarriedAssocs tb+  actorAspect <- getsServer sactorAspect+  getItem <- getsState $ flip getItemBody+  discoKind <- getsServer sdiscoKind+  let ar = actorAspect EM.! target+      isImpression iid = case EM.lookup (jkindIx $ getItem iid) discoKind of+        Just KindMean{kmKind} ->+          maybe False (> 0) $ lookup "impressed" $ IK.ifreq (okind kmKind)+        Nothing -> assert `failure` iid+      dropAllImpressions = EM.filterWithKey (\iid _ -> not $ isImpression iid)+      borganNoImpression = dropAllImpressions $ borgan tb+  btime <-+    getsServer $ (EM.! target) . (EM.! blid tb) . (EM.! bfid tb) . sactorTime+  execUpdAtomic $ UpdLoseActor target tb ais+  let bNew = tb { bfid = fid+                , bcalm = max (xM 10) $ xM (aMaxCalm ar) `div` 2+                , bhp = min (xM $ aMaxHP ar) $ bhp tb + xM 10+                , borgan = borganNoImpression}+  aisNew <- getsState $ getCarriedAssocs bNew+  execUpdAtomic $ UpdSpotActor target bNew aisNew+  modifyServer $ \ser ->+    ser {sactorTime = updateActorTime fid (blid tb) target btime+                      $ sactorTime ser}+  factionD <- getsState sfactionD+  let inGame fact2 = case gquit fact2 of+        Nothing -> True+        Just Status{stOutcome=Camping} -> True+        _ -> False+      gameOver = not $ any inGame $ EM.elems factionD+  if gameOver+  then return True  -- avoid spam+  else do+    -- Add some nostalgia for the old faction.+    void $ effectCreateItem (Just (bfid tb, 10)) target COrgan+                            "impressed" IK.TimerNone+    let discoverSeed (iid, cstore) = do+          seed <- getsServer $ (EM.! iid) . sitemSeedD+          let c = CActor target cstore+          execUpdAtomic $ UpdDiscoverSeed c iid seed+        aic = getCarriedIidCStore tb+    mapM_ discoverSeed aic+    -- Focus on the dominated actor, by making him a leader.+    supplantLeader fid target+    return False++-- ** Impress++effectImpress :: (MonadAtomic m, MonadServer m)+              => (IK.Effect -> m Bool) -> m () -> ActorId -> ActorId -> m Bool+effectImpress recursiveCall execSfx source target = do+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  if | bproj tb -> return False+     | bfid tb == bfid sb -> do+       -- Unimpress wrt others, but only once.+       res <- recursiveCall $ IK.DropItem 1 1 COrgan "impressed"+       when res execSfx+       return res+     | otherwise -> do+       execSfx+       effectCreateItem (Just (bfid sb, 1)) target COrgan+                        "impressed" IK.TimerNone++-- ** Summon++-- Note that the Calm expended doesn't depend on the number of actors summoned.+effectSummon :: (MonadAtomic m, MonadServer m)+             => m () -> GroupName ItemKind -> Dice.Dice -> ItemId+             -> ActorId -> ActorId -> Bool+             -> m Bool+effectSummon execSfx grp nDm iid source target periodic = do+  -- Obvious effect, nothing announced.+  Kind.COps{coTileSpeedup} <- getsState scops+  power <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  actorAspect <- getsServer sactorAspect+  item <- getsState $ getItemBody iid+  let sar = actorAspect EM.! source+      tar = actorAspect EM.! target+      durable = IK.Durable `elem` jfeature item+      deltaCalm = - xM 30+  -- Verify Calm only at periodic activations or if the item is durable.+  -- Otherwise summon uses up the item, which prevents summoning getting+  -- out of hand. I don't verify Calm otherwise, to prevent an exploit+  -- via draining one's calm on purpose when an item with good activation+  -- has a nasty summoning side-effect (the exploit still works on durables).+  if (periodic || durable) && not (bproj sb)+     && (bcalm sb < - deltaCalm || not (calmEnough sb sar)) then do+    unless (bproj sb) $+      execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxSummonLackCalm source+    return False+  else do+    execSfx+    unless (bproj sb) $ udpateCalm source deltaCalm+    let validTile t = not $ Tile.isNoActor coTileSpeedup t+    ps <- getsState $ nearbyFreePoints validTile (bpos tb) (blid tb)+    localTime <- getsState $ getLocalTime (blid tb)+    -- Make sure summoned actors start acting after the victim.+    let actorTurn = ticksPerMeter $ bspeed tb tar+        targetTime = timeShift localTime actorTurn+        afterTime = timeShift targetTime $ Delta timeClip+    bs <- forM (take power ps) $ \p -> do+      maid <- addAnyActor [(grp, 1)] (blid tb) afterTime (Just p)+      case maid of+        Nothing -> return False  -- not enough space in dungeon?+        Just aid -> do+          b <- getsState $ getActorBody aid+          mleader <- getsState $ _gleader . (EM.! bfid b) . sfactionD+          when (isNothing mleader) $ supplantLeader (bfid b) aid+          return True+    return $! or bs++-- ** Ascend++-- Note that projectiles can be teleported, too, for extra fun.+effectAscend :: (MonadAtomic m, MonadServer m)+             => (IK.Effect -> m Bool)+             -> m () -> Bool -> ActorId -> ActorId -> Point+             -> m Bool+effectAscend recursiveCall execSfx up source target pos = do+  b1 <- getsState $ getActorBody target+  let lid1 = blid b1+  (lid2, pos2) <- getsState $ whereTo lid1 pos (Just up) . sdungeon+  sb <- getsState $ getActorBody source+  if | braced b1 -> do+       execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxBracedImmune target+       return False+     | lid2 == lid1 && pos2 == pos -> do+       execSfxAtomic $ SfxMsgFid (bfid sb) SfxLevelNoMore+       -- We keep it useful even in shallow dungeons.+       recursiveCall $ IK.Teleport 30  -- powerful teleport+     | otherwise -> do+       execSfx+       btime_bOld <- getsServer $ (EM.! target) . (EM.! lid1)+                       . (EM.! bfid b1) . sactorTime+       pos3 <- findStairExit (bfid sb) up lid2 pos2+       let switch1 = void $ switchLevels1 (target, b1)+           switch2 = do+             -- Make the initiator of the stair move the leader,+             -- to let him clear the stairs for others to follow.+             let mlead = Just target+             -- Move the actor to where the inhabitants were, if any.+             switchLevels2 lid2 pos3 (target, b1) btime_bOld mlead+       -- The actor will be added to the new level,+       -- but there can be other actors at his new position.+       inhabitants <- getsState $ posToAssocs pos3 lid2+       case inhabitants of+         [] -> do+           switch1+           switch2+         (_, b2) : _ -> do+           -- Alert about the switch.+           -- Only tell one player, even if many actors, because then+           -- they are projectiles, so not too important.+           execSfxAtomic $ SfxMsgFid (bfid b2) SfxLevelPushed+           -- Move the actor out of the way.+           switch1+           -- Move the inhabitants out of the way and to where the actor was.+           let moveInh inh = do+                 -- Preserve the old leader, since the actor is pushed,+                 -- so possibly has nothing worhwhile to do on the new level+                 -- (and could try to switch back, if made a leader,+                 -- leading to a loop).+                 btime_inh <-+                   getsServer $ (EM.! fst inh) . (EM.! lid2)+                                . (EM.! bfid (snd inh)) . sactorTime+                 inhMLead <- switchLevels1 inh+                 switchLevels2 lid1 (bpos b1) inh btime_inh inhMLead+           mapM_ moveInh inhabitants+           -- Move the actor to his destination.+           switch2+       return True++findStairExit :: MonadStateRead m+              => FactionId -> Bool -> LevelId -> Point -> m Point+findStairExit side moveUp lid pos = do+  Kind.COps{coTileSpeedup} <- getsState scops+  fact <- getsState $ (EM.! side) . sfactionD+  lvl <- getLevel lid+  let defLanding = uncurry Vector $ if moveUp then (-1, 0) else (1, 0)+      (mvs2, mvs1) = break (== defLanding) moves+      mvs = mvs1 ++ mvs2+      ps = filter (Tile.isWalkable coTileSpeedup . (lvl `at`))+           $ map (shift pos) mvs+      posOcc :: State -> Int -> Point -> Bool+      posOcc s k p = case posToAssocs p lid s of+        [] -> k == 0+        (_, b) : _ | bproj b -> k == 3+        (_, b) : _ | isAtWar fact (bfid b) -> k == 1  -- non-proj foe+        _ -> k == 2  -- moving a non-projectile friend+  unocc <- getsState posOcc+  case concatMap (\k -> filter (unocc k) ps) [0..3] of+    [] -> assert `failure` ps+    posRes : _ -> return posRes++switchLevels1 :: MonadAtomic m => (ActorId, Actor) -> m (Maybe ActorId)+switchLevels1 (aid, bOld) = do+  let side = bfid bOld+  mleader <- getsState $ _gleader . (EM.! side) . sfactionD+  -- Prevent leader pointing to a non-existing actor.+  mlead <-+    if not (bproj bOld) && isJust mleader then do+      execUpdAtomic $ UpdLeadFaction side mleader Nothing+      return mleader+        -- outside of a client we don't know the real tgt of aid, hence fst+    else return Nothing+  -- Remove the actor from the old level.+  -- Onlookers see somebody disappear suddenly.+  -- @UpdDestroyActor@ is too loud, so use @UpdLoseActor@ instead.+  ais <- getsState $ getCarriedAssocs bOld+  execUpdAtomic $ UpdLoseActor aid bOld ais+  return mlead++switchLevels2 ::(MonadAtomic m, MonadServer m)+              => LevelId -> Point -> (ActorId, Actor) -> Time -> Maybe ActorId+              -> m ()+switchLevels2 lidNew posNew (aid, bOld) btime_bOld mlead = do+  let lidOld = blid bOld+      side = bfid bOld+  let !_A = assert (lidNew /= lidOld `blame` "stairs looped" `twith` lidNew) ()+  -- Sync the actor time with the level time.+  timeOld <- getsState $ getLocalTime lidOld+  timeLastActive <- getsState $ getLocalTime lidNew+  -- This time calculation may cause a double move of a foe of the same+  -- speed, but this is OK --- the foe didn't have a chance to move+  -- before, because the arena went inactive, so he moves now one more time.+  let delta = timeLastActive `timeDeltaToFrom` timeOld+      shiftByDelta = (`timeShift` delta)+      computeNewTimeout :: ItemQuant -> ItemQuant+      computeNewTimeout (k, it) = (k, map shiftByDelta it)+      setTimeout :: ItemBag -> ItemBag+      setTimeout = EM.map computeNewTimeout+      bNew = bOld { blid = lidNew+                  , bpos = posNew+                  , boldpos = Just posNew  -- new level, new direction+                  , borgan = setTimeout $ borgan bOld+                  , beqp = setTimeout $ beqp bOld }+  -- Materialize the actor at the new location.+  -- Onlookers see somebody appear suddenly. The actor himself+  -- sees new surroundings and has to reset his perception.+  ais <- getsState $ getCarriedAssocs bOld+  execUpdAtomic $ UpdCreateActor aid bNew ais+  let btime = shiftByDelta btime_bOld+  modifyServer $ \ser ->+    ser {sactorTime = updateActorTime (bfid bNew) lidNew aid btime $ sactorTime ser}+  case mlead of+    Nothing -> return ()+    Just leader -> supplantLeader side leader++-- ** Escape++-- | The faction leaves the dungeon.+effectEscape :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m Bool+effectEscape source target = do+  -- Obvious effect, nothing announced.+  sb <- getsState $ getActorBody source+  b <- getsState $ getActorBody target+  let fid = bfid b+  fact <- getsState $ (EM.! fid) . sfactionD+  if | bproj b ->+       return False+     | not (fcanEscape $ gplayer fact) -> do+       execSfxAtomic $ SfxMsgFid (bfid sb) SfxEscapeImpossible+       return False+     | otherwise -> do+       deduceQuits (bfid b) $ Status Escape (fromEnum $ blid b) Nothing+       return True++-- ** Paralyze++-- | Advance target actor time by this many time clips. Not by actor moves,+-- to hurt fast actors more.+effectParalyze :: (MonadAtomic m, MonadServer m)+               => m () -> Dice.Dice -> ActorId -> m Bool+effectParalyze execSfx nDm target = do+  p <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm+  b <- getsState $ getActorBody target+  if bproj b || bhp b <= 0+    then return False+    else do+      execSfx+      let t = timeDeltaScale (Delta timeClip) p+      modifyServer $ \ser ->+        ser {sactorTime = ageActor (bfid b) (blid b) target t $ sactorTime ser}+      return True++-- ** InsertMove++-- | Give target actor the given number of extra moves. Don't give+-- an absolute amount of time units, to benefit slow actors more.+effectInsertMove :: (MonadAtomic m, MonadServer m)+                 => m () -> Dice.Dice -> ActorId -> m Bool+effectInsertMove execSfx nDm target = do+  execSfx+  p <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm+  b <- getsState $ getActorBody target+  actorAspect <- getsServer sactorAspect+  let ar = actorAspect EM.! target+  let actorTurn = ticksPerMeter $ bspeed b ar+      t = timeDeltaScale actorTurn (-p)+  modifyServer $ \ser ->+    ser {sactorTime = ageActor (bfid b) (blid b) target t $ sactorTime ser}+  return True++-- ** Teleport++-- | Teleport the target actor.+-- Note that projectiles can be teleported, too, for extra fun.+effectTeleport :: (MonadAtomic m, MonadServer m)+               => m () -> Dice.Dice -> ActorId -> ActorId -> m Bool+effectTeleport execSfx nDm source target = do+  Kind.COps{coTileSpeedup} <- getsState scops+  range <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm+  sb <- getsState $ getActorBody source+  b <- getsState $ getActorBody target+  Level{ltile} <- getLevel (blid b)+  let spos = bpos b+      dMinMax delta pos =+        let d = chessDist spos pos+        in d >= range - delta && d <= range + delta+      dist delta pos _ = dMinMax delta pos+  lvl <- getLevel (blid b)+  tpos <- rndToAction $ findPosTry 200 ltile+    (\p t -> Tile.isWalkable coTileSpeedup t+             && (not (dMinMax 9 p)  -- don't loop, very rare+                 || not (Tile.isNoActor coTileSpeedup t)+                    && null (posToAidsLvl p lvl)))+    [ dist 1+    , dist $ 1 + range `div` 9+    , dist $ 1 + range `div` 7+    , dist $ 1 + range `div` 5+    , dist 5+    , dist 7+    , dist 9+    ]+  if | braced b -> do+       execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxBracedImmune target+       return False+     | not (dMinMax 9 tpos) -> do  -- very rare+       execSfxAtomic $ SfxMsgFid (bfid sb) SfxTransImpossible+       return False+     | otherwise -> do+       execSfx+       execUpdAtomic $ UpdMoveActor target spos tpos+       return True++-- ** CreateItem++effectCreateItem :: (MonadAtomic m, MonadServer m)+                 => Maybe (FactionId, Int) -> ActorId -> CStore+                 -> GroupName ItemKind -> IK.TimerDice+                 -> m Bool+effectCreateItem mfidSource target store grp tim = do+  tb <- getsState $ getActorBody target+  delta <- case tim of+    IK.TimerNone -> return $ Delta timeZero+    IK.TimerGameTurn nDm -> do+      k <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm+      let !_A = assert (k >= 0) ()+      return $! timeDeltaScale (Delta timeTurn) k+    IK.TimerActorTurn nDm -> do+      k <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm+      let !_A = assert (k >= 0) ()+      actorAspect <- getsServer sactorAspect+      let ar = actorAspect EM.! target+          actorTurn = ticksPerMeter $ bspeed tb ar+      return $! timeDeltaScale actorTurn k+  let c = CActor target store+  bagBefore <- getsState $ getBodyStoreBag tb store+  let litemFreq = [(grp, 1)]+  -- Power depth of new items unaffected by number of spawned actors.+  m5 <- rollItem 0 (blid tb) litemFreq+  let (itemKnownRaw, itemFullRaw, _, seed, _) =+        fromMaybe (assert `failure` (blid tb, litemFreq, c)) m5+      (itemKnown, itemFull) = case mfidSource of+        Just (fidSource, k) ->+          let (kindIx, ar, damage, _) = itemKnownRaw+              jfid = Just fidSource+          in ( (kindIx, ar, damage, jfid)+             , itemFullRaw { itemBase = (itemBase itemFullRaw) {jfid}+                           , itemK = k })+        Nothing -> (itemKnownRaw, itemFullRaw)+  itemRev <- getsServer sitemRev+  let mquant = case HM.lookup itemKnown itemRev of+        Nothing -> Nothing+        Just iid -> (iid,) <$> iid `EM.lookup` bagBefore+  case mquant of+    Just (iid, (1, afterIt@(timer : rest))) | tim /= IK.TimerNone -> do+      -- Already has such an item, so only increase the timer by the amount.+      let newIt = timer `timeShift` delta : rest+      when (afterIt /= newIt) $+        execUpdAtomic $ UpdTimeItem iid c afterIt newIt+    _ -> do+      -- Multiple such items, so it's a periodic poison, etc., so just stack,+      -- or no such items at all, so create some.+      iid <- registerItem itemFull itemKnown seed c True+      unless (tim == IK.TimerNone) $ do+        tb2 <- getsState $ getActorBody target+        bagAfter <- getsState $ getBodyStoreBag tb2 store+        localTime <- getsState $ getLocalTime (blid tb)+        let newTimer = localTime `timeShift` delta+            (afterK, afterIt) =+              fromMaybe (assert `failure` (iid, bagAfter, c))+                        (iid `EM.lookup` bagAfter)+            newIt = replicate afterK newTimer+        when (afterIt /= newIt) $+          execUpdAtomic $ UpdTimeItem iid c afterIt newIt+  return True++-- ** DropItem++-- | Make the target actor drop all items in a store from the given group+-- (not just a random single item, or cluttering equipment with rubbish+-- would be beneficial).+effectDropItem :: (MonadAtomic m, MonadServer m)+               => m () -> Int ->Int ->  CStore -> GroupName ItemKind -> ActorId+               -> m Bool+effectDropItem execSfx ngroup kcopy store grp target = do+  b <- getsState $ getActorBody target+  is <- allGroupItems store grp target+  if null is then return False+  else do+    unless (store == COrgan) execSfx+    mapM_ (uncurry (dropCStoreItem True store target b kcopy)) $ take ngroup is+    return True++allGroupItems :: (MonadAtomic m, MonadServer m)+              => CStore -> GroupName ItemKind -> ActorId+              -> m [(ItemId, ItemQuant)]+allGroupItems store grp target = do+  Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops+  discoKind <- getsServer sdiscoKind+  b <- getsState $ getActorBody target+  let hasGroup (iid, _) = do+        item <- getsState $ getItemBody iid+        case EM.lookup (jkindIx item) discoKind of+          Just KindMean{kmKind} ->+            return $! maybe False (> 0) $ lookup grp $ IK.ifreq (okind kmKind)+          Nothing ->+            assert `failure` (target, grp, iid, item)+  assocsCStore <- getsState $ EM.assocs . getBodyStoreBag b store+  filterM hasGroup assocsCStore++-- | Drop a single actor's item. Note that if there are multiple copies,+-- at most one explodes to avoid excessive carnage and UI clutter+-- (let's say, the multiple explosions interfere with each other or perhaps+-- larger quantities of explosives tend to be packaged more safely).+dropCStoreItem :: (MonadAtomic m, MonadServer m)+               => Bool -> CStore -> ActorId -> Actor -> Int+               -> ItemId -> ItemQuant+               -> m ()+dropCStoreItem verbose store aid b kMax iid kit@(k, _) = do+  item <- getsState $ getItemBody iid+  let c = CActor aid store+      fragile = IK.Fragile `elem` jfeature item+      durable = IK.Durable `elem` jfeature item+      isDestroyed = bproj b && (bhp b <= 0 && not durable || fragile)+                    || fragile && durable  -- hack for tmp organs+  if isDestroyed then do+    itemToF <- itemToFullServer+    let itemFull = itemToF iid kit+        effs = strengthOnSmash itemFull+    -- Activate even if effects null, to destroy the item.+    effectAndDestroy False aid aid iid c False effs itemFull+  else do+    cDrop <- pickDroppable aid b+    mvCmd <- generalMoveItem verbose iid (min kMax k) (CActor aid store) cDrop+    mapM_ execUpdAtomic mvCmd++pickDroppable :: MonadStateRead m => ActorId -> Actor -> m Container+pickDroppable aid b = do+  Kind.COps{coTileSpeedup} <- getsState scops+  lvl <- getLevel (blid b)+  let validTile t = not $ Tile.isNoItem coTileSpeedup t+  if validTile $ lvl `at` bpos b+  then return $! CActor aid CGround+  else do+    ps <- getsState $ nearbyFreePoints validTile (bpos b) (blid b)+    return $! case ps of+      [] -> CActor aid CGround  -- fallback; still correct, though not ideal+      pos : _ -> CFloor (blid b) pos++-- ** PolyItem++effectPolyItem :: (MonadAtomic m, MonadServer m)+               => m () -> ActorId -> ActorId -> m Bool+effectPolyItem execSfx source target = do+  sb <- getsState $ getActorBody source+  let cstore = CGround+  allAssocs <- fullAssocsServer target [cstore]+  case allAssocs of+    [] -> do+      execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxPurposeNothing cstore+      return False+    (iid, itemFull@ItemFull{..}) : _ -> case itemDisco of+      Just ItemDisco{itemKind, itemKindId} -> do+        let maxCount = Dice.maxDice $ IK.icount itemKind+        if | itemK < maxCount -> do+             execSfxAtomic $ SfxMsgFid (bfid sb)+                           $ SfxPurposeTooFew maxCount itemK+             return False+           | IK.Unique `elem` IK.ieffects itemKind -> do+             execSfxAtomic $ SfxMsgFid (bfid sb) SfxPurposeUnique+             return False+           | otherwise -> do+             let c = CActor target cstore+                 kit = (maxCount, take maxCount itemTimer)+             execSfx+             identifyIid iid c itemKindId+             execUpdAtomic $ UpdDestroyItem iid itemBase kit c+             effectCreateItem Nothing target cstore "useful" IK.TimerNone+      _ -> assert `failure` (target, iid, itemFull)++-- ** Identify++effectIdentify :: (MonadAtomic m, MonadServer m)+               => m () -> ItemId -> ActorId -> ActorId -> m Bool+effectIdentify execSfx iidId source target = do+  sb <- getsState $ getActorBody source+  let tryFull store as = case as of+        [] -> do+          execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxIdentifyNothing store+          return False+        (iid, _) : rest | iid == iidId -> tryFull store rest  -- don't id itself+        (iid, ItemFull{itemDisco=Just ItemDisco{..}}) : rest -> do+          -- We avoid identifying trivial items, but they may also be right+          -- in the middle of bonus ranges, to if no other option, id them;+          -- client will ignore them if really trivial.+          let ided = IK.Identified `elem` IK.ifeature itemKind+              statsObvious = Just itemAspectMean == itemAspect+          if ided && statsObvious && not (null rest)+            then tryFull store rest+            else do+              let c = CActor target store+              execSfx+              identifyIid iid c itemKindId+              return True+        _ -> assert `failure` (store, as)+      tryStore stores = case stores of+        [] -> return False+        store : rest -> do+          allAssocs <- fullAssocsServer target [store]+          go <- tryFull store allAssocs+          if go then return True else tryStore rest+  tryStore [CGround]++identifyIid :: (MonadAtomic m, MonadServer m)+            => ItemId -> Container -> Kind.Id ItemKind -> m ()+identifyIid iid c itemKindId = do+  seed <- getsServer $ (EM.! iid) . sitemSeedD+  execUpdAtomic $ UpdDiscover c iid itemKindId seed++-- ** Detect++effectDetect :: (MonadAtomic m, MonadServer m)+             => m () -> Int -> ActorId -> m Bool+effectDetect = effectDetectX (const True) (const $ return False)++effectDetectX :: (MonadAtomic m, MonadServer m)+              => (Point -> Bool) -> ([Point] -> m Bool)+              -> m () -> Int -> ActorId -> m Bool+effectDetectX predicate action execSfx radius target = do+  b <- getsState $ getActorBody target+  Level{lxsize, lysize} <- getLevel $ blid b+  sperFidOld <- getsServer sperFid+  let perOld = sperFidOld EM.! bfid b EM.! blid b+      Point x0 y0 = bpos b+      perList = filter predicate+        [ Point x y+        | y <- [max 0 (y0 - radius) .. min (lysize - 1) (y0 + radius)]+        , x <- [max 0 (x0 - radius) .. min (lxsize - 1) (x0 + radius)]+        ]+      extraPer = emptyPer {psight = PerVisible $ ES.fromDistinctAscList perList}+      inPer = diffPer extraPer perOld+  perModified <- if nullPer inPer then return False else do+    -- Perception is modified on the server and sent to the client+    -- together with all the revealed info.+    let perNew = addPer inPer perOld+        fper = EM.adjust (EM.insert (blid b) perNew) (bfid b)+    modifyServer $ \ser -> ser {sperFid = fper $ sperFid ser}+    execSendPer (bfid b) (blid b) emptyPer inPer perNew+    return True+  pointsModified <- action perList+  if perModified || pointsModified then do+    execSfx+    -- Perception is reverted. This is necessary to ensure save and restore+    -- doesn't change game state.+    when perModified $ do+      modifyServer $ \ser -> ser {sperFid = sperFidOld}+      execSendPer (bfid b) (blid b) inPer emptyPer perOld+  else+    execSfxAtomic $ SfxMsgFid (bfid b) SfxVoidDetection+  return True  -- even if nothing spotted, in itself it's still useful data++-- ** DetectActor++effectDetectActor :: (MonadAtomic m, MonadServer m)+                  => m () -> Int -> ActorId -> m Bool+effectDetectActor execSfx radius target = do+  b <- getsState $ getActorBody target+  Level{lactor} <- getLevel $ blid b+  effectDetectX (`EM.member` lactor) (const $ return False)+                execSfx radius target++-- ** DetectItem++effectDetectItem :: (MonadAtomic m, MonadServer m)+                 => m () -> Int -> ActorId -> m Bool+effectDetectItem execSfx radius target = do+  b <- getsState $ getActorBody target+  Level{lfloor} <- getLevel $ blid b+  effectDetectX (`EM.member` lfloor) (const $ return False)+                execSfx radius target++-- ** DetectExit++effectDetectExit :: (MonadAtomic m, MonadServer m)+                 => m () -> Int -> ActorId -> m Bool+effectDetectExit execSfx radius target = do+  b <- getsState $ getActorBody target+  Level{lstair=(ls1, ls2), lescape} <- getLevel $ blid b+  effectDetectX (`elem` ls1 ++ ls2 ++ lescape) (const $ return False)+                execSfx radius target++-- ** DetectHidden++effectDetectHidden :: (MonadAtomic m, MonadServer m)+                   => m () -> Int -> ActorId -> Point -> m Bool+effectDetectHidden execSfx radius target pos = do+  Kind.COps{coTileSpeedup} <- getsState scops+  b <- getsState $ getActorBody target+  lvl <- getLevel $ blid b+  let predicate p = Tile.isHideAs coTileSpeedup $ lvl `at` p+      action l = do+        let f p = when (p /= pos)+                  $ execUpdAtomic $ UpdSearchTile target p $ lvl `at` p+        mapM_ f l+        return $! not $ null l+  effectDetectX predicate action execSfx radius target++-- ** SendFlying++-- | Shend the target actor flying like a projectile. The arguments correspond+-- to @ToThrow@ and @Linger@ properties of items. If the actors are adjacent,+-- the vector is directed outwards, if no, inwards, if it's the same actor,+-- boldpos is used, if it can't, a random outward vector of length 10+-- is picked.+effectSendFlying :: (MonadAtomic m, MonadServer m)+                 => m () -> IK.ThrowMod+                 -> ActorId -> ActorId -> Maybe Bool+                 -> m Bool+effectSendFlying execSfx IK.ThrowMod{..} source target modePush = do+  v <- sendFlyingVector source target modePush+  Kind.COps{coTileSpeedup} <- getsState scops+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  lvl@Level{lxsize, lysize} <- getLevel (blid tb)+  let eps = 0+      fpos = bpos tb `shift` v+  if braced tb then do+    execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxBracedImmune target+    return False+  else case bla lxsize lysize eps (bpos tb) fpos of+    Nothing -> assert `failure` (fpos, tb)+    Just [] -> assert `failure` "projecting from the edge of level"+                      `twith` (fpos, tb)+    Just (pos : rest) -> do+      let t = lvl `at` pos+      if not $ Tile.isWalkable coTileSpeedup t+        then return False  -- supported by a wall+        else do+          weightAssocs <- fullAssocsServer target [CInv, CEqp, COrgan]+          let weight = sum $ map (jweight . itemBase . snd) weightAssocs+              path = bpos tb : pos : rest+              (trajectory, (speed, _)) =+                computeTrajectory weight throwVelocity throwLinger path+              ts = Just (trajectory, speed)+          if null trajectory || btrajectory tb == ts+             || throwVelocity <= 0 || throwLinger <= 0+            then return False  -- e.g., actor is too heavy; OK+            else do+              execSfx+              execUpdAtomic $ UpdTrajectory target (btrajectory tb) ts+              -- Give the actor one extra turn and also let the push start ASAP.+              -- So, if the push lasts one (his) turn, he will not lose+              -- any turn of movement (but he may need to retrace the push).+              actorAspect <- getsServer sactorAspect+              let ar = actorAspect EM.! target+                  actorTurn = ticksPerMeter $ bspeed tb ar+                  delta = timeDeltaScale actorTurn (-1)+              modifyServer $ \ser ->+                ser {sactorTime = ageActor (bfid tb) (blid tb) target delta+                                  $ sactorTime ser}+              return True++sendFlyingVector :: (MonadAtomic m, MonadServer m)+                 => ActorId -> ActorId -> Maybe Bool -> m Vector+sendFlyingVector source target modePush = do+  sb <- getsState $ getActorBody source+  let boldpos_sb = fromMaybe originPoint (boldpos sb)+  if source == target then+    if boldpos_sb == bpos sb then rndToAction $ do+      z <- randomR (-10, 10)+      oneOf [Vector 10 z, Vector (-10) z, Vector z 10, Vector z (-10)]+    else+      return $! vectorToFrom (bpos sb) boldpos_sb+  else do+    tb <- getsState $ getActorBody target+    let (sp, tp) = if adjacent (bpos sb) (bpos tb)+                   then let pos = if chessDist boldpos_sb (bpos tb)+                                     > chessDist (bpos sb) (bpos tb)+                                  then boldpos_sb  -- avoid cardinal dir+                                  else bpos sb+                        in (pos, bpos tb)+                   else (bpos sb, bpos tb)+        pushV = vectorToFrom tp sp+        pullV = vectorToFrom sp tp+    return $! case modePush of+                Just True -> pushV+                Just False -> pullV+                Nothing | adjacent (bpos sb) (bpos tb) -> pushV+                Nothing -> pullV++-- ** DropBestWeapon++-- | Make the target actor drop his best weapon (stack).+effectDropBestWeapon :: (MonadAtomic m, MonadServer m)+                     => m () -> ActorId -> m Bool+effectDropBestWeapon execSfx target = do+  tb <- getsState $ getActorBody target+  localTime <- getsState $ getLocalTime (blid tb)+  allAssocsRaw <- fullAssocsServer target [CEqp]+  let allAssocs = filter (isMelee . itemBase . snd) allAssocsRaw+  case strongestMelee Nothing localTime allAssocs of+    (_, (iid, _)) : _ -> do+      execSfx+      let kit = beqp tb EM.! iid+      dropCStoreItem True CEqp target tb 1 iid kit  -- not the whole stack+      return True+    [] ->+      return False++-- ** ActivateInv++-- | Activate all items with the given symbol+-- in the target actor's equipment (there's no variant that activates+-- a random one, to avoid the incentive for carrying garbage).+-- Only one item of each stack is activated (and possibly consumed).+effectActivateInv :: (MonadAtomic m, MonadServer m)+                  => m () -> ActorId -> Char -> m Bool+effectActivateInv execSfx target symbol =+  effectTransformEqp execSfx target symbol CInv $ \iid _ ->+    applyItem target iid CInv++effectTransformEqp :: forall m. MonadAtomic m+                   => m () -> ActorId -> Char -> CStore+                   -> (ItemId -> ItemQuant -> m ())+                   -> m Bool+effectTransformEqp execSfx target symbol cstore m = do+  b <- getsState $ getActorBody target+  let hasSymbol (iid, _) = do+        item <- getsState $ getItemBody iid+        return $! jsymbol item == symbol+  assocsCStore <- getsState $ EM.assocs . getBodyStoreBag b cstore+  is <- if symbol == ' '+        then return assocsCStore+        else filterM hasSymbol assocsCStore+  if null is+    then return False+    else do+      execSfx+      mapM_ (uncurry m) is+      return True++-- ** ApplyPerfume++effectApplyPerfume :: MonadAtomic m+                   => m () -> ActorId -> m Bool+effectApplyPerfume execSfx target = do+  execSfx+  tb <- getsState $ getActorBody target+  Level{lsmell} <- getLevel $ blid tb+  let f p fromSm =+        execUpdAtomic $ UpdAlterSmell (blid tb) p fromSm timeZero+  mapWithKeyM_ f lsmell+  return True++-- ** OneOf++effectOneOf :: (MonadAtomic m, MonadServer m)+            => (IK.Effect -> m Bool)+            -> [IK.Effect]+            -> m Bool+effectOneOf recursiveCall l = do+  let call1 = do+        ef <- rndToAction $ oneOf l+        recursiveCall ef+      call99 = replicate 99 call1+      f callNext result = do+        b <- result+        if b then return True else callNext+  foldr f (return False) call99++-- ** Recharging++effectRecharging :: MonadAtomic m+                 => (IK.Effect -> m Bool)+                 -> IK.Effect -> Bool+                 -> m Bool+effectRecharging recursiveCall e recharged =+  if recharged+  then recursiveCall e+  else return False++-- ** Temporary++effectTemporary :: MonadAtomic m+                => m () -> ActorId -> ItemId -> Container -> m Bool+effectTemporary execSfx source iid c =+  case c of+    CActor _ COrgan -> do+      b <- getsState $ getActorBody source+      case iid `EM.lookup` borgan b of+        Just _ -> return ()  -- still some copies left of a multi-copy tmp organ+        Nothing -> execSfx  -- last copy just destroyed+      return True+    _ -> do+      execSfx+      return False  -- just a message

− Game/LambdaHack/Server/HandleEffectServer.hs

@@ -1,1115 +0,0 @@-{-# LANGUAGE TupleSections #-}--- | Handle effects (most often caused by requests sent by clients).-module Game.LambdaHack.Server.HandleEffectServer-  ( applyItem, itemEffectAndDestroy, effectAndDestroy, itemEffectCause-  , dropCStoreItem, armorHurtBonus-  ) where--import Control.Applicative-import Control.Exception.Assert.Sugar-import Control.Monad-import Data.Bits (xor)-import qualified Data.EnumMap.Strict as EM-import qualified Data.HashMap.Strict as HM-import Data.Key (mapWithKeyM_)-import Data.List-import Data.Maybe-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Atomic-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Dice as Dice-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemDescription-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ItemKind (ItemKind)-import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.ModeKind-import qualified Game.LambdaHack.Content.TileKind as TK-import Game.LambdaHack.Server.CommonServer-import Game.LambdaHack.Server.ItemServer-import Game.LambdaHack.Server.MonadServer-import Game.LambdaHack.Server.PeriodicServer-import Game.LambdaHack.Server.StartServer-import Game.LambdaHack.Server.State---- + Semantics of effects--applyItem :: (MonadAtomic m, MonadServer m)-          => ActorId -> ItemId -> CStore -> m ()-applyItem aid iid cstore = do-  execSfxAtomic $ SfxApply aid iid cstore-  let c = CActor aid cstore-  itemEffectAndDestroy aid aid iid c--itemEffectAndDestroy :: (MonadAtomic m, MonadServer m)-                     => ActorId -> ActorId -> ItemId -> Container-                     -> m ()-itemEffectAndDestroy source target iid c = do-  discoEffect <- getsServer sdiscoEffect-  case EM.lookup iid discoEffect of-    Just ItemAspectEffect{jeffects, jaspects} -> do-      bag <- getsState $ getCBag c-      case iid `EM.lookup` bag of-        Nothing -> assert `failure` (source, target, iid, c)-        Just kit ->-          effectAndDestroy source target iid c False jeffects jaspects kit-    _ -> assert `failure` (source, target, iid, c)--effectAndDestroy :: (MonadAtomic m, MonadServer m)-                 => ActorId -> ActorId -> ItemId -> Container -> Bool-                 -> [IK.Effect] -> [IK.Aspect Int] -> ItemQuant-                 -> m ()-effectAndDestroy source target iid c periodic effs aspects kitK@(k, it) = do-  let mtimeout = let timeoutAspect :: IK.Aspect a -> Bool-                     timeoutAspect IK.Timeout{} = True-                     timeoutAspect _ = False-                 in find timeoutAspect aspects-  lid <- getsState $ lidFromC c-  localTime <- getsState $ getLocalTime lid-  let it1 = case mtimeout of-        Just (IK.Timeout timeout) ->-          let timeoutTurns = timeDeltaScale (Delta timeTurn) timeout-              charging startT = timeShift startT timeoutTurns > localTime-          in filter charging it-        _ -> []-      len = length it1-      recharged = len < k-  let !_A = assert (len <= k `blame` (kitK, source, target, iid, c)) ()-  -- If there is no Timeout, but there are Recharging,-  -- then such effects are disabled whenever the item is affected-  -- by a Discharge attack (TODO).-  it2 <- case mtimeout of-    Just (IK.Timeout _) | recharged ->-      return $ localTime : it1-    _ ->-      -- TODO: if has timeout and not recharged, report failure-      return it1-  -- We use up the charge even if eventualy every effect fizzles. Tough luck.-  -- At least we don't destroy the item in such case. Also, we ID it regardless.-  it3 <- if it /= it2 && mtimeout /= Just (IK.Timeout 0) then do-           execUpdAtomic $ UpdTimeItem iid c it it2-           return it2-         else return it-  -- If the activation is not periodic, trigger at least the effects-  -- that are not recharging and so don't depend on @recharged@.-  when (not periodic || recharged) $ do-    -- We have to destroy the item before the effect affects the item-    -- or the actor holding it or standing on it (later on we could-    -- lose track of the item and wouldn't be able to destroy it) .-    -- This is OK, because we don't remove the item type from various-    -- item dictionaries, just an individual copy from the container,-    -- so, e.g., the item can be identified after it's removed.-    let mtmp = let tmpEffect :: IK.Effect -> Bool-                   tmpEffect IK.Temporary{} = True-                   tmpEffect (IK.Recharging IK.Temporary{}) = True-                   tmpEffect (IK.OnSmash IK.Temporary{}) = True-                   tmpEffect _ = False-               in find tmpEffect effs-    item <- getsState $ getItemBody iid-    let durable = IK.Durable `elem` jfeature item-        imperishable = durable || periodic && isNothing mtmp-        kit = if isNothing mtmp || periodic then (1, take 1 it3) else (k, it3)-    unless imperishable $-      execUpdAtomic $ UpdLoseItem iid item kit c-    -- At this point, the item is potentially no longer in container @c@,-    -- so we don't pass @c@ along.-    triggered <- itemEffectDisco source target iid c recharged periodic effs-    -- If none of item's effects was performed, we try to recreate the item.-    -- Regardless, we don't rewind the time, because some info is gained-    -- (that the item does not exhibit any effects in the given context).-    unless (triggered || imperishable) $-      execUpdAtomic $ UpdSpotItem iid item kit c--itemEffectCause :: (MonadAtomic m, MonadServer m)-                => ActorId -> Point -> IK.Effect-                -> m Bool-itemEffectCause aid tpos ef = do-  sb <- getsState $ getActorBody aid-  let c = CEmbed (blid sb) tpos-  bag <- getsState $ getCBag c-  case EM.assocs bag of-    [(iid, kit)] -> do-      -- No block against tile, hence unconditional.-      discoEffect <- getsServer sdiscoEffect-      let aspects = case EM.lookup iid discoEffect of-            Just ItemAspectEffect{jaspects} -> jaspects-            _ -> assert `failure` (aid, tpos, ef, iid)-      execSfxAtomic $ SfxTrigger aid tpos $ TK.Cause ef-      effectAndDestroy aid aid iid c False [ef] aspects kit-      return True-    ab -> assert `failure` (aid, tpos, ab)---- | The source actor affects the target actor, with a given item.--- If any of the effects fires up, the item gets identified. This function--- is mutually recursive with @effect@ and so it's a part of @Effect@--- semantics.-itemEffectDisco :: (MonadAtomic m, MonadServer m)-                => ActorId -> ActorId -> ItemId -> Container -> Bool -> Bool-                -> [IK.Effect]-                -> m Bool-itemEffectDisco source target iid c recharged periodic effs = do-  discoKind <- getsServer sdiscoKind-  item <- getsState $ getItemBody iid-  case EM.lookup (jkindIx item) discoKind of-    Just itemKindId -> do-      seed <- getsServer $ (EM.! iid) . sitemSeedD-      Level{ldepth} <- getLevel $ jlid item-      -- TODO: we leak first depth the item was created at on the server-      execUpdAtomic $ UpdDiscover c iid itemKindId seed ldepth-      itemEffect source target iid recharged periodic effs-    _ -> assert `failure` (source, target, iid, item)--itemEffect :: (MonadAtomic m, MonadServer m)-           => ActorId -> ActorId -> ItemId -> Bool -> Bool-           -> [IK.Effect]-           -> m Bool-itemEffect source target iid recharged periodic effects = do-  trs <- mapM (effectSem source target iid recharged) effects-  let triggered = or trs-  sb <- getsState $ getActorBody source-  -- Announce no effect, which is rare and wastes time, so noteworthy.-  unless (triggered  -- some effect triggered, so feedback comes from them-          || periodic  -- don't spam from fizzled periodic effects-          || bproj sb) $  -- don't spam, projectiles can be very numerous-    if null effects-    then execSfxAtomic $ SfxMsgFid (bfid sb) "Nothing happens."-    else execSfxAtomic $ SfxMsgFid (bfid sb) "It flashes and fizzles."-  return triggered---- | The source actor affects the target actor, with a given effect and power.--- Both actors are on the current level and can be the same actor.--- The item may or may not still be in the container.--- The boolean result indicates if the effect actually fired up,--- as opposed to fizzled.-effectSem :: (MonadAtomic m, MonadServer m)-          => ActorId -> ActorId -> ItemId -> Bool -> IK.Effect-          -> m Bool-effectSem source target iid recharged effect = do-  let recursiveCall = effectSem source target iid recharged-  sb <- getsState $ getActorBody source-  -- @execSfx@ usually comes last in effect semantics, but not always-  -- and we are likely to introduce more variety.-  let execSfx = execSfxAtomic $ SfxEffect (bfid sb) target effect-  case effect of-    IK.NoEffect _ -> return False-    IK.Hurt nDm -> effectHurt nDm source target IK.RefillHP-    IK.Burn nDm -> effectBurn nDm source target-    IK.Explode t -> effectExplode execSfx t target-    IK.RefillHP p -> effectRefillHP False execSfx p source target-    IK.OverfillHP p -> effectRefillHP True execSfx p source target-    IK.RefillCalm p -> effectRefillCalm False execSfx p source target-    IK.OverfillCalm p -> effectRefillCalm True execSfx p source target-    IK.Dominate -> effectDominate recursiveCall source target-    IK.Impress -> effectImpress source target-    IK.CallFriend p -> effectCallFriend execSfx p source target-    IK.Summon freqs p -> effectSummon execSfx freqs p source target-    IK.Ascend p -> effectAscend recursiveCall execSfx p source target-    IK.Escape{} -> effectEscape source target-    IK.Paralyze p -> effectParalyze execSfx p target-    IK.InsertMove p -> effectInsertMove execSfx p target-    IK.Teleport p -> effectTeleport execSfx p source target-    IK.CreateItem store grp tim -> effectCreateItem target store grp tim-    IK.DropItem store grp hit -> effectDropItem execSfx store grp hit target-    IK.PolyItem -> effectPolyItem execSfx source target-    IK.Identify -> effectIdentify execSfx iid source target-    IK.SendFlying tmod ->-      effectSendFlying execSfx tmod source target Nothing-    IK.PushActor tmod ->-      effectSendFlying execSfx tmod source target (Just True)-    IK.PullActor tmod ->-      effectSendFlying execSfx tmod source target (Just False)-    IK.DropBestWeapon -> effectDropBestWeapon execSfx target-    IK.ActivateInv symbol -> effectActivateInv execSfx target symbol-    IK.ApplyPerfume -> effectApplyPerfume execSfx target-    IK.OneOf l -> effectOneOf recursiveCall l-    IK.OnSmash _ -> return False  -- ignored under normal circumstances-    IK.Recharging e -> effectRecharging recursiveCall e recharged-    IK.Temporary _ -> effectTemporary execSfx source iid---- + Individual semantic functions for effects---- ** Hurt---- Modified by armor. Can, exceptionally, add HP.-effectHurt :: (MonadAtomic m, MonadServer m)-           => Dice.Dice -> ActorId -> ActorId -> (Int -> IK.Effect)-           -> m Bool-effectHurt nDm source target verboseEffectConstructor = do-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  hpMax <- sumOrganEqpServer IK.EqpSlotAddMaxHP target-  n <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm-  hurtBonus <- armorHurtBonus source target-  let mult = 100 + hurtBonus-      rawDeltaHP = - (max oneM  -- at least 1 HP taken-                          (fromIntegral mult * xM n `divUp` 100))-      serious = source /= target && not (bproj tb)-      deltaHP | serious = -- if HP overfull, at least cut back to max HP-                          min rawDeltaHP (xM hpMax - bhp tb)-              | otherwise = rawDeltaHP-      deltaDiv = fromIntegral $ deltaHP `divUp` oneM-  -- Damage the target.-  execUpdAtomic $ UpdRefillHP target deltaHP-  when serious $ halveCalm target-  execSfxAtomic $ SfxEffect (bfid sb) target $-    if source == target-    then verboseEffectConstructor deltaDiv-           -- no SfxStrike, so treat as any heal/wound-    else IK.Hurt (Dice.intToDice (- deltaDiv))-           -- SfxStrike already sent, avoid spam-  return True--armorHurtBonus :: (MonadAtomic m, MonadServer m)-               => ActorId -> ActorId-               -> m Int-armorHurtBonus source target = do-  sactiveItems <- activeItemsServer source-  tactiveItems <- activeItemsServer target-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  let itemBonus =-        if bproj sb-        then sumSlotNoFilter IK.EqpSlotAddHurtRanged sactiveItems-             - sumSlotNoFilter IK.EqpSlotAddArmorRanged tactiveItems-        else sumSlotNoFilter IK.EqpSlotAddHurtMelee sactiveItems-             - sumSlotNoFilter IK.EqpSlotAddArmorMelee tactiveItems-      block = braced tb-  return $! itemBonus - if block then 50 else 0--halveCalm :: (MonadAtomic m, MonadServer m) => ActorId -> m ()-halveCalm target = do-  tb <- getsState $ getActorBody target-  activeItems <- activeItemsServer target-  let calmMax = sumSlotNoFilter IK.EqpSlotAddMaxCalm activeItems-      upperBound = if hpTooLow tb activeItems-                   then 0  -- to trigger domination, etc.-                   else max (xM calmMax) (bcalm tb) `div` 2-      deltaCalm = min minusTwoM (upperBound - bcalm tb)-  -- HP loss decreases Calm by at least minusTwoM, to overcome Calm regen,-  -- when far from shooting foe and to avoid "hears something",-  -- which is emitted for decrease @minusM@.-  udpateCalm target deltaCalm---- ** Burn---- Damage from both impact and fire. Modified by armor.-effectBurn :: (MonadAtomic m, MonadServer m)-           => Dice.Dice -> ActorId -> ActorId-           -> m Bool-effectBurn nDm source target =-  effectHurt nDm source target (\p -> IK.Burn $ Dice.intToDice (-p))---- ** Explode--effectExplode :: (MonadAtomic m, MonadServer m)-              => m () -> GroupName ItemKind -> ActorId -> m Bool-effectExplode execSfx cgroup target = do-  tb <- getsState $ getActorBody target-  let itemFreq = [(cgroup, 1)]-      container = CActor target CEqp-  m2 <- rollAndRegisterItem (blid tb) itemFreq container False Nothing-  let (iid, (ItemFull{..}, _)) = fromMaybe (assert `failure` cgroup) m2-      Point x y = bpos tb-      projectN k100 (n, _) = do-        -- We pick a point at the border, not inside, to have a uniform-        -- distribution for the points the line goes through at each distance-        -- from the source. Otherwise, e.g., the points on cardinal-        -- and diagonal lines from the source would be more common.-        let fuzz = 2 + (k100 `xor` (itemK * n)) `mod` 9-            k | itemK >= 8 && n < 8 = 0-              | n < 8 && n >= 4 = 4-              | otherwise = n-            psAll =-              [ Point (x - 12) $ y + fuzz-              , Point (x + 12) $ y - fuzz-              , Point (x - 12) $ y - fuzz-              , Point (x + 12) $ y + fuzz-              , flip Point (y - 12) $ x + fuzz-              , flip Point (y + 12) $ x - fuzz-              , flip Point (y - 12) $ x - fuzz-              , flip Point (y + 12) $ x + fuzz-              ]-            -- Keep full symmetry, but only if enough projectiles. Fall back-            -- to random, on average, symmetry.-            ps = take k $-              if k >= 4 then psAll-              else drop ((n + x + y + fromEnum iid * 7) `mod` 16)-                   $ cycle $ psAll ++ reverse psAll-        forM_ ps $ \tpxy -> do-          let req = ReqProject tpxy k100 iid CEqp-          mfail <- projectFail target tpxy k100 iid CEqp True-          case mfail of-            Nothing -> return ()-            Just ProjectBlockTerrain -> return ()-            Just ProjectBlockActor | not $ bproj tb -> return ()-            Just failMsg -> execFailure target req failMsg-  -- All blasts bounce off obstacles many times before they destruct.-  forM_ [101..201] $ \k100 -> do-    bag2 <- getsState $ beqp . getActorBody target-    let mn2 = EM.lookup iid bag2-    maybe (return ()) (projectN k100) mn2-  bag3 <- getsState $ beqp . getActorBody target-  let mn3 = EM.lookup iid bag3-  maybe (return ()) (\kit -> execUpdAtomic-                             $ UpdLoseItem iid itemBase kit container) mn3-  execSfx-  return True  -- we neglect verifying that at least one projectile got off---- ** RefillHP---- Unaffected by armor.-effectRefillHP :: (MonadAtomic m, MonadServer m)-               => Bool -> m () -> Int -> ActorId -> ActorId -> m Bool-effectRefillHP overfill execSfx power source target = do-  tb <- getsState $ getActorBody target-  hpMax <- sumOrganEqpServer IK.EqpSlotAddMaxHP target-  let overMax | overfill = xM hpMax * 10  -- arbitrary limit to scumming-              | otherwise = xM hpMax-      serious = not (bproj tb) && source /= target && power > 1-      deltaHP | power > 0 = min (xM power) (max 0 $ overMax - bhp tb)-              | serious = -- if overfull, at least cut back to max-                          min (xM power) (xM hpMax - bhp tb)-              | otherwise = xM power-  if deltaHP == 0-    then return False-    else do-      execUpdAtomic $ UpdRefillHP target deltaHP-      execSfx-      when (deltaHP < 0 && serious) $ halveCalm target-      return True---- ** RefillCalm--effectRefillCalm ::  (MonadAtomic m, MonadServer m)-                 => Bool -> m () -> Int -> ActorId -> ActorId -> m Bool-effectRefillCalm overfill execSfx power source target = do-  tb <- getsState $ getActorBody target-  calmMax <- sumOrganEqpServer IK.EqpSlotAddMaxCalm target-  let overMax | overfill = xM calmMax * 10  -- arbitrary limit to scumming-              | otherwise = xM calmMax-      serious = not (bproj tb) && source /= target && power > 1-      deltaCalm | power > 0 = min (xM power) (max 0 $ overMax - bcalm tb)-                | serious = -- if overfull, at least cut back to max-                            min (xM power) (xM calmMax - bcalm tb)-                | otherwise = xM power-  if deltaCalm == 0-    then return False-    else do-      execSfx-      udpateCalm target deltaCalm-      return True---- ** Dominate--effectDominate :: (MonadAtomic m, MonadServer m)-               => (IK.Effect -> m Bool)-               -> ActorId -> ActorId-               -> m Bool-effectDominate recursiveCall source target = do-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  if bfid tb == bfid sb then-    -- Dominate is rather on projectiles than on items, so alternate effect-    -- is useful to avoid boredom if domination can't happen.-    recursiveCall IK.Impress-  else-    dominateFidSfx (bfid sb) target---- ** Impress--effectImpress :: (MonadAtomic m, MonadServer m)-              => ActorId -> ActorId -> m Bool-effectImpress source target = do-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  if bfidImpressed tb == bfid sb || bproj tb then-    return False-  else do-    execUpdAtomic $ UpdFidImpressedActor target (bfidImpressed tb) (bfid sb)-    return True---- ** CallFriend---- Note that the Calm expended doesn't depend on the number of actors called.-effectCallFriend :: (MonadAtomic m, MonadServer m)-                   => m () -> Dice.Dice -> ActorId -> ActorId-                   -> m Bool-effectCallFriend execSfx nDm source target = do-  -- Obvious effect, nothing announced.-  Kind.COps{cotile} <- getsState scops-  power <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  activeItems <- activeItemsServer target-  if not $ hpEnough10 tb activeItems then do-    unless (bproj tb) $ do-      let subject = partActor tb-          verb = "lack enough HP to call aid"-          msg = makeSentence [MU.SubjectVerbSg subject verb]-      execSfxAtomic $ SfxMsgFid (bfid sb) msg-    return False-  else do-    let deltaHP = - xM 10-    execUpdAtomic $ UpdRefillHP target deltaHP-    execSfx-    let validTile t = not $ Tile.hasFeature cotile TK.NoActor t-    ps <- getsState $ nearbyFreePoints validTile (bpos tb) (blid tb)-    time <- getsState $ getLocalTime (blid tb)-    -- We call target's friends so that AI monsters that test by throwing-    -- don't waste artifacts very valuable for heroes. Heroes should rather-    -- not test scrolls by throwing.-    recruitActors (take power ps) (blid tb) time (bfid tb)---- ** Summon---- Note that the Calm expended doesn't depend on the number of actors summoned.-effectSummon :: (MonadAtomic m, MonadServer m)-             => m () -> Freqs ItemKind -> Dice.Dice -> ActorId -> ActorId-             -> m Bool-effectSummon execSfx actorFreq nDm source target = do-  -- Obvious effect, nothing announced.-  Kind.COps{cotile} <- getsState scops-  power <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  activeItems <- activeItemsServer target-  if not $ calmEnough10 tb activeItems then do-    unless (bproj tb) $ do-      let subject = partActor tb-          verb = "lack enough Calm to summon"-          msg = makeSentence [MU.SubjectVerbSg subject verb]-      execSfxAtomic $ SfxMsgFid (bfid sb) msg-    return False-  else do-    let deltaCalm = - xM 10-    unless (bproj tb) $ udpateCalm target deltaCalm-    execSfx-    let validTile t = not $ Tile.hasFeature cotile TK.NoActor t-    ps <- getsState $ nearbyFreePoints validTile (bpos tb) (blid tb)-    localTime <- getsState $ getLocalTime (blid tb)-    -- Make sure summoned actors start acting after the summoner.-    let targetTime = timeShift localTime $ ticksPerMeter $ bspeed tb activeItems-        afterTime = timeShift targetTime $ Delta timeClip-    bs <- forM (take power ps) $ \p -> do-      maid <- addAnyActor actorFreq (blid tb) afterTime (Just p)-      case maid of-        Nothing -> return False  -- actorFreq is null; content writers...-        Just aid -> do-          b <- getsState $ getActorBody aid-          mleader <- getsState $ gleader . (EM.! bfid b) . sfactionD-          when (isNothing mleader) $-            execUpdAtomic-            $ UpdLeadFaction (bfid b) Nothing (Just (aid, Nothing))-          return True-    return $! or bs---- ** Ascend---- Note that projectiles can be teleported, too, for extra fun.-effectAscend :: (MonadAtomic m, MonadServer m)-             => (IK.Effect -> m Bool)-             -> m () -> Int -> ActorId -> ActorId-             -> m Bool-effectAscend recursiveCall execSfx k source target = do-  b1 <- getsState $ getActorBody target-  let lid1 = blid b1-      pos1 = bpos b1-  (lid2, pos2) <- getsState $ whereTo lid1 pos1 k . sdungeon-  sb <- getsState $ getActorBody source-  if braced b1 then do-    execSfxAtomic $ SfxMsgFid (bfid sb)-                              "Braced actors are immune to translocation."-    return False-  else if lid2 == lid1 && pos2 == pos1 then do-    execSfxAtomic $ SfxMsgFid (bfid sb) "No more levels in this direction."-    -- We keep it useful even in shallow dungeons.-    recursiveCall $ IK.Teleport 30  -- powerful teleport-  else do-    let switch1 = void $ switchLevels1 (target, b1)-        switch2 = do-          -- Make the initiator of the stair move the leader,-          -- to let him clear the stairs for others to follow.-          let mlead = Just target-          -- Move the actor to where the inhabitants were, if any.-          switchLevels2 lid2 pos2 (target, b1) mlead-          -- Verify only one non-projectile actor on every tile.-          !_ <- getsState $ posToActors pos1 lid1  -- assertion is inside-          !_ <- getsState $ posToActors pos2 lid2  -- assertion is inside-          return ()-    -- The actor will be added to the new level, but there can be other actors-    -- at his new position.-    inhabitants <- getsState $ posToActors pos2 lid2-    case inhabitants of-      [] -> do-        switch1-        switch2-      (_, b2) : _ -> do-        -- Alert about the switch.-        let subjects = map (partActor . snd) inhabitants-            subject = MU.WWandW subjects-            verb = "be pushed to another level"-            msg2 = makeSentence [MU.SubjectVerbSg subject verb]-        -- Only tell one player, even if many actors, because then-        -- they are projectiles, so not too important.-        execSfxAtomic $ SfxMsgFid (bfid b2) msg2-        -- Move the actor out of the way.-        switch1-        -- Move the inhabitant out of the way and to where the actor was.-        let moveInh inh = do-              -- Preserve old the leader, since the actor is pushed, so possibly-              -- has nothing worhwhile to do on the new level (and could try-              -- to switch back, if made a leader, leading to a loop).-              inhMLead <- switchLevels1 inh-              switchLevels2 lid1 pos1 inh inhMLead-        mapM_ moveInh inhabitants-        -- Move the actor to his destination.-        switch2-    execSfx-    return True--switchLevels1 :: MonadAtomic m => (ActorId, Actor) -> m (Maybe ActorId)-switchLevels1 (aid, bOld) = do-  let side = bfid bOld-  mleader <- getsState $ gleader . (EM.! side) . sfactionD-  -- Prevent leader pointing to a non-existing actor.-  mlead <--    if not (bproj bOld) && isJust mleader then do-      execUpdAtomic $ UpdLeadFaction side mleader Nothing-      return $ fst <$> mleader-        -- outside of a client we don't know the real tgt of aid, hence fst-    else return Nothing-  -- Remove the actor from the old level.-  -- Onlookers see somebody disappear suddenly.-  -- @UpdDestroyActor@ is too loud, so use @UpdLoseActor@ instead.-  ais <- getsState $ getCarriedAssocs bOld-  execUpdAtomic $ UpdLoseActor aid bOld ais-  return mlead--switchLevels2 ::(MonadAtomic m, MonadServer m)-              => LevelId -> Point -> (ActorId, Actor) -> Maybe ActorId-              -> m ()-switchLevels2 lidNew posNew (aid, bOld) mlead = do-  let lidOld = blid bOld-      side = bfid bOld-  let !_A = assert (lidNew /= lidOld `blame` "stairs looped" `twith` lidNew) ()-  -- Sync the actor time with the level time.-  timeOld <- getsState $ getLocalTime lidOld-  timeLastActive <- getsState $ getLocalTime lidNew-  -- This time calculation may cause a double move of a foe of the same-  -- speed, but this is OK --- the foe didn't have a chance to move-  -- before, because the arena went inactive, so he moves now one more time.-  let delta = timeLastActive `timeDeltaToFrom` timeOld-      shiftByDelta = (`timeShift` delta)-      computeNewTimeout :: ItemQuant -> ItemQuant-      computeNewTimeout (k, it) = (k, map shiftByDelta it)-      setTimeout :: ItemBag -> ItemBag-      setTimeout = EM.map computeNewTimeout-      bNew = bOld { blid = lidNew-                  , btime = shiftByDelta $ btime bOld-                  , bpos = posNew-                  , boldpos = Just posNew  -- new level, new direction-                  , boldlid = lidOld  -- record old level-                  , borgan = setTimeout $ borgan bOld-                  , beqp = setTimeout $ beqp bOld }-  -- Materialize the actor at the new location.-  -- Onlookers see somebody appear suddenly. The actor himself-  -- sees new surroundings and has to reset his perception.-  ais <- getsState $ getCarriedAssocs bOld-  execUpdAtomic $ UpdCreateActor aid bNew ais-  case mlead of-    Nothing -> return ()-    Just leader ->-      execUpdAtomic $ UpdLeadFaction side Nothing (Just (leader, Nothing))---- ** Escape---- | The faction leaves the dungeon.-effectEscape :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m Bool-effectEscape source target = do-  -- Obvious effect, nothing announced.-  sb <- getsState $ getActorBody source-  b <- getsState $ getActorBody target-  let fid = bfid b-  fact <- getsState $ (EM.! fid) . sfactionD-  if bproj b then-    return False-  else if not (fcanEscape $ gplayer fact) then do-    execSfxAtomic $ SfxMsgFid (bfid sb)-                              "This faction doesn't want to escape outside."-    return False-  else do-    deduceQuits fid Nothing $ Status Escape (fromEnum $ blid b) Nothing-    return True---- ** Paralyze---- | Advance target actor time by this many time clips. Not by actor moves,--- to hurt fast actors more.-effectParalyze :: (MonadAtomic m, MonadServer m)-               => m () -> Dice.Dice -> ActorId -> m Bool-effectParalyze execSfx nDm target = do-  p <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm-  b <- getsState $ getActorBody target-  if bproj b || bhp b <= 0-    then return False-    else do-      let t = timeDeltaScale (Delta timeClip) p-      execUpdAtomic $ UpdAgeActor target t-      execSfx-      return True---- ** InsertMove---- | Give target actor the given number of extra moves. Don't give--- an absolute amount of time units, to benefit slow actors more.-effectInsertMove :: (MonadAtomic m, MonadServer m)-                 => m () -> Dice.Dice -> ActorId -> m Bool-effectInsertMove execSfx nDm target = do-  p <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm-  b <- getsState $ getActorBody target-  activeItems <- activeItemsServer target-  let tpm = ticksPerMeter $ bspeed b activeItems-      t = timeDeltaScale tpm (-p)-  execUpdAtomic $ UpdAgeActor target t-  execSfx-  return True---- ** Teleport---- | Teleport the target actor.--- Note that projectiles can be teleported, too, for extra fun.-effectTeleport :: (MonadAtomic m, MonadServer m)-               => m () -> Dice.Dice -> ActorId -> ActorId -> m Bool-effectTeleport execSfx nDm source target = do-  Kind.COps{cotile} <- getsState scops-  range <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm-  sb <- getsState $ getActorBody source-  b <- getsState $ getActorBody target-  Level{ltile} <- getLevel (blid b)-  as <- getsState $ actorList (const True) (blid b)-  let spos = bpos b-      dMinMax delta pos =-        let d = chessDist spos pos-        in d >= range - delta && d <= range + delta-      dist delta pos _ = dMinMax delta pos-  tpos <- rndToAction $ findPosTry 200 ltile-    (\p t -> Tile.isWalkable cotile t-             && (not (dMinMax 9 p)  -- don't loop, very rare-                 || not (Tile.hasFeature cotile TK.NoActor t)-                    && unoccupied as p))-    [ dist 1-    , dist $ 1 + range `div` 9-    , dist $ 1 + range `div` 7-    , dist $ 1 + range `div` 5-    , dist 5-    , dist 7-    ]-  if braced b then do-    execSfxAtomic $ SfxMsgFid (bfid sb)-                              "Braced actors are immune to translocation."-    return False-  else if not (dMinMax 9 tpos) then do  -- very rare-    execSfxAtomic $ SfxMsgFid (bfid sb) "Translocation not possible."-    return False-  else do-    execUpdAtomic $ UpdMoveActor target spos tpos-    execSfx-    return True---- ** CreateItem---- TODO: if the items is created not on the ground, perhaps it should--- be IDed, so that there are no rings with unkown max Calm bonus--- leading to attempts to do illegal actions (which the server then catches).--- This is in analogy to picking item from the ground, whereas it's IDed.-effectCreateItem :: (MonadAtomic m, MonadServer m)-                  => ActorId -> CStore -> GroupName ItemKind -> IK.TimerDice-                  -> m Bool-effectCreateItem target store grp tim = do-  tb <- getsState $ getActorBody target-  delta <- case tim of-    IK.TimerNone -> return $ Delta timeZero-    IK.TimerGameTurn nDm -> do-      k <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm-      let !_A = assert (k >= 0) ()-      return $! timeDeltaScale (Delta timeTurn) k-    IK.TimerActorTurn nDm -> do-      k <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm-      let !_A = assert (k >= 0) ()-      activeItems <- activeItemsServer target-      let actorTurn = ticksPerMeter $ bspeed tb activeItems-      return $! timeDeltaScale actorTurn k-  let c = CActor target store-  bagBefore <- getsState $ getCBag c-  let litemFreq = [(grp, 1)]-  -- Power depth of new items unaffected by number of spawned actors.-  m5 <- rollItem 0 (blid tb) litemFreq-  let (itemKnown, itemFull, _, seed, _) =-        fromMaybe (assert `failure` (blid tb, litemFreq, c)) m5-  itemRev <- getsServer sitemRev-  let mquant = case HM.lookup itemKnown itemRev of-        Nothing -> Nothing-        Just iid -> (iid,) <$> iid `EM.lookup` bagBefore-  case mquant of-    Just (iid, (1, afterIt@(timer : rest))) | tim /= IK.TimerNone -> do-      -- Already has such an item, so only increase the timer by half delta.-      let newIt = let halfTurns = delta `timeDeltaDiv` 2-                      newTimer = timer `timeShift` halfTurns-                  in newTimer : rest-      when (afterIt /= newIt) $-        execUpdAtomic $ UpdTimeItem iid c afterIt newIt  -- TODO: announce-    _ -> do-      -- Multiple such items, so it's a periodic poison, etc., so just stack,-      -- or no such items at all, so create some.-      iid <- registerItem itemFull itemKnown seed (itemK itemFull) c True-      unless (tim == IK.TimerNone) $ do-        bagAfter <- getsState $ getCBag c-        localTime <- getsState $ getLocalTime (blid tb)-        let newTimer = localTime `timeShift` delta-            (afterK, afterIt) =-              fromMaybe (assert `failure` (iid, bagAfter, c))-                        (iid `EM.lookup` bagAfter)-            newIt = replicate afterK newTimer-        when (afterIt /= newIt) $-          execUpdAtomic $ UpdTimeItem iid c afterIt newIt-  return True---- ** DropItem---- | Make the target actor drop all items in his equiment with the given symbol--- (not just a random single item, or cluttering equipment with rubbish--- would be beneficial).-effectDropItem :: (MonadAtomic m, MonadServer m)-               => m () -> CStore -> GroupName ItemKind -> Bool -> ActorId-               -> m Bool-effectDropItem execSfx store grp hit target = do-  Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops-  discoKind <- getsServer sdiscoKind-  b <- getsState $ getActorBody target-  let hasGroup (iid, _) = do-        item <- getsState $ getItemBody iid-        case EM.lookup (jkindIx item) discoKind of-          Just kindId ->-            return $! maybe False (> 0) $ lookup grp $ IK.ifreq (okind kindId)-          Nothing ->-            assert `failure` (target, grp, iid, item)-  assocsCStore <- getsState $ EM.assocs . getActorBag target store-  is <- filterM hasGroup assocsCStore-  if null is-    then return False-    else do-      mapM_ (uncurry (dropCStoreItem store target b hit)) is-      unless (store == COrgan) execSfx-      return True---- | Drop a single actor's item. Note that if there are multiple copies,--- at most one explodes to avoid excessive carnage and UI clutter--- (let's say, the multiple explosions interfere with each other or perhaps--- larger quantities of explosives tend to be packaged more safely).-dropCStoreItem :: (MonadAtomic m, MonadServer m)-               => CStore -> ActorId -> Actor -> Bool -> ItemId -> ItemQuant-               -> m ()-dropCStoreItem store aid b hit iid kit@(k, _) = do-  item <- getsState $ getItemBody iid-  let c = CActor aid store-      fragile = IK.Fragile `elem` jfeature item-      durable = IK.Durable `elem` jfeature item-      isDestroyed = hit && not durable || bproj b && fragile-  if isDestroyed then do-    discoEffect <- getsServer sdiscoEffect-    let aspects = case EM.lookup iid discoEffect of-          Just ItemAspectEffect{jaspects} -> jaspects-          _ -> assert `failure` (aid, iid)-    itemToF <- itemToFullServer-    let itemFull = itemToF iid kit-        effs = strengthOnSmash itemFull-    effectAndDestroy aid aid iid c False effs aspects kit-  else do-    mvCmd <- generalMoveItem iid k (CActor aid store)-                                   (CActor aid CGround)-    mapM_ execUpdAtomic mvCmd---- ** PolyItem---- TODO: ask player for an item-effectPolyItem :: (MonadAtomic m, MonadServer m)-               => m () -> ActorId -> ActorId -> m Bool-effectPolyItem execSfx source target = do-  sb <- getsState $ getActorBody source-  let cstore = CGround-  allAssocs <- fullAssocsServer target [cstore]-  case allAssocs of-    [] -> do-      execSfxAtomic $ SfxMsgFid (bfid sb) $-        "The purpose of repurpose cannot be availed without an item"-        <+> ppCStoreIn cstore <> "."-      return False-    (iid, itemFull@ItemFull{..}) : _ -> case itemDisco of-      Just ItemDisco{..} -> do-        discoEffect <- getsServer sdiscoEffect-        let maxCount = Dice.maxDice $ IK.icount itemKind-            aspects = jaspects $ discoEffect EM.! iid-        if itemK < maxCount then do-          execSfxAtomic $ SfxMsgFid (bfid sb) $-            "The purpose of repurpose is served by" <+> tshow maxCount-            <+> "pieces of this item, not by" <+> tshow itemK <> "."-          return False-        else if IK.Unique `elem` aspects then do-          execSfxAtomic $ SfxMsgFid (bfid sb)-            "Unique items can't be repurposed."-          return False-        else do-          let c = CActor target cstore-              kit = (maxCount, take maxCount itemTimer)-          identifyIid execSfx iid c itemKindId-          execUpdAtomic $ UpdDestroyItem iid itemBase kit c-          effectCreateItem target cstore "useful" IK.TimerNone-      _ -> assert `failure` (target, iid, itemFull)---- ** Identify---- TODO: ask player for an item, because server doesn't know which--- is already identified, it only knows which cannot ever be.--- Perhaps refill Calm only when id successfull and scroll consumed,--- id the scroll anyway. Explain the Calm gain: "your most pressing--- existential concerns are answered scientifitically".-effectIdentify :: (MonadAtomic m, MonadServer m)-               => m () -> ItemId -> ActorId -> ActorId -> m Bool-effectIdentify execSfx iidId source target = do-  sb <- getsState $ getActorBody source-  let tryFull store as = case as of-        -- TODO: identify the scroll, but don't use up.-        [] -> do-          let (tIn, t) = ppCStore store-              msg = "Nothing to identify" <+> tIn <+> t <> "."-          execSfxAtomic $ SfxMsgFid (bfid sb) msg-          return False-        (iid, _) : rest | iid == iidId -> tryFull store rest  -- don't id itself-        (iid, itemFull@ItemFull{itemDisco=Just ItemDisco{..}}) : rest -> do-          -- TODO: use this (but faster, via traversing effects with 999?)-          -- also to prevent sending any other UpdDiscover.-          let ided = IK.Identified `elem` IK.ifeature itemKind-              itemSecret = itemNoAE itemFull-              statsObvious = textAllAE 7 False store itemFull-                             == textAllAE 7 False store itemSecret-          if ided && statsObvious-            then tryFull store rest-            else do-              let c = CActor target store-              identifyIid execSfx iid c itemKindId-              return True-        _ -> assert `failure` (store, as)-      tryStore stores = case stores of-        [] -> return False-        store : rest -> do-          allAssocs <- fullAssocsServer target [store]-          go <- tryFull store allAssocs-          if go then return True else tryStore rest-  tryStore [CGround]--identifyIid :: (MonadAtomic m, MonadServer m)-            => m () -> ItemId -> Container -> Kind.Id ItemKind-            -> m ()-identifyIid execSfx iid c itemKindId = do-  execSfx-  seed <- getsServer $ (EM.! iid) . sitemSeedD-  item <- getsState $ getItemBody iid-  Level{ldepth} <- getLevel $ jlid item-  execUpdAtomic $ UpdDiscover c iid itemKindId seed ldepth---- ** SendFlying---- | Shend the target actor flying like a projectile. The arguments correspond--- to @ToThrow@ and @Linger@ properties of items. If the actors are adjacent,--- the vector is directed outwards, if no, inwards, if it's the same actor,--- boldpos is used, if it can't, a random outward vector of length 10--- is picked.-effectSendFlying :: (MonadAtomic m, MonadServer m)-                 => m () -> IK.ThrowMod-                 -> ActorId -> ActorId -> Maybe Bool-                 -> m Bool-effectSendFlying execSfx IK.ThrowMod{..} source target modePush = do-  v <- sendFlyingVector source target modePush-  Kind.COps{cotile} <- getsState scops-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  lvl@Level{lxsize, lysize} <- getLevel (blid tb)-  let eps = 0-      fpos = bpos tb `shift` v-  if braced tb then do-    execSfxAtomic $ SfxMsgFid (bfid sb)-                              "Braced actors are immune to translocation."-    return False-  else case bla lxsize lysize eps (bpos tb) fpos of-    Nothing -> assert `failure` (fpos, tb)-    Just [] -> assert `failure` "projecting from the edge of level"-                      `twith` (fpos, tb)-    Just (pos : rest) -> do-      let t = lvl `at` pos-      if not $ Tile.isWalkable cotile t-        then return False  -- supported by a wall-        else do-          weightAssocs <- fullAssocsServer target [CInv, CEqp, COrgan]-          let weight = sum $ map (jweight . itemBase . snd) weightAssocs-              path = bpos tb : pos : rest-              (trajectory, (speed, _)) =-                computeTrajectory weight throwVelocity throwLinger path-              ts = Just (trajectory, speed)-          if null trajectory || btrajectory tb == ts-             || throwVelocity <= 0 || throwLinger <= 0-            then return False  -- e.g., actor is too heavy; OK-            else do-              execUpdAtomic $ UpdTrajectory target (btrajectory tb) ts-              -- Give the actor one extra turn and also let the push start ASAP.-              -- So, if the push lasts one (his) turn, he will not lose-              -- any turn of movement (but he may need to retrace the push).-              activeItems <- activeItemsServer target-              let tpm = ticksPerMeter $ bspeed tb activeItems-                  delta = timeDeltaScale tpm (-1)-              execUpdAtomic $ UpdAgeActor target delta-              execSfx-              return True--sendFlyingVector :: (MonadAtomic m, MonadServer m)-                 => ActorId -> ActorId -> Maybe Bool -> m Vector-sendFlyingVector source target modePush = do-  sb <- getsState $ getActorBody source-  let boldpos_sb = fromMaybe (Point 0 0) (boldpos sb)-  if source == target then-    if boldpos_sb == bpos sb then rndToAction $ do-      z <- randomR (-10, 10)-      oneOf [Vector 10 z, Vector (-10) z, Vector z 10, Vector z (-10)]-    else-      return $! vectorToFrom (bpos sb) boldpos_sb-  else do-    tb <- getsState $ getActorBody target-    let (sp, tp) = if adjacent (bpos sb) (bpos tb)-                   then let pos = if chessDist boldpos_sb (bpos tb)-                                     > chessDist (bpos sb) (bpos tb)-                                  then boldpos_sb  -- avoid cardinal dir-                                  else bpos sb-                        in (pos, bpos tb)-                   else (bpos sb, bpos tb)-        pushV = vectorToFrom tp sp-        pullV = vectorToFrom sp tp-    return $! case modePush of-                Just True -> pushV-                Just False -> pullV-                Nothing | adjacent (bpos sb) (bpos tb) -> pushV-                Nothing -> pullV---- ** DropBestWeapon---- | Make the target actor drop his best weapon (stack).-effectDropBestWeapon :: (MonadAtomic m, MonadServer m)-                     => m () -> ActorId -> m Bool-effectDropBestWeapon execSfx target = do-  tb <- getsState $ getActorBody target-  allAssocs <- fullAssocsServer target [CEqp]-  localTime <- getsState $ getLocalTime (blid tb)-  case strongestMelee False localTime allAssocs of-    (_, (iid, _)) : _ -> do-      let kit = beqp tb EM.! iid-      dropCStoreItem CEqp target tb False iid kit-      execSfx-      return True-    [] ->-      return False---- ** ActivateInv---- | Activate all items with the given symbol--- in the target actor's equipment (there's no variant that activates--- a random one, to avoid the incentive for carrying garbage).--- Only one item of each stack is activated (and possibly consumed).-effectActivateInv :: (MonadAtomic m, MonadServer m)-                  => m () -> ActorId -> Char -> m Bool-effectActivateInv execSfx target symbol =-  effectTransformEqp execSfx target symbol CInv $ \iid _ ->-    applyItem target iid CInv--effectTransformEqp :: forall m. (MonadAtomic m, MonadServer m)-                   => m () -> ActorId -> Char -> CStore-                   -> (ItemId -> ItemQuant -> m ())-                   -> m Bool-effectTransformEqp execSfx target symbol cstore m = do-  let hasSymbol (iid, _) = do-        item <- getsState $ getItemBody iid-        return $! jsymbol item == symbol-  assocsCStore <- getsState $ EM.assocs . getActorBag target cstore-  is <- if symbol == ' '-        then return assocsCStore-        else filterM hasSymbol assocsCStore-  if null is-    then return False-    else do-      mapM_ (uncurry m) is-      execSfx-      return True---- ** ApplyPerfume--effectApplyPerfume :: (MonadAtomic m, MonadServer m)-                   => m () -> ActorId -> m Bool-effectApplyPerfume execSfx target = do-  tb <- getsState $ getActorBody target-  Level{lsmell} <- getLevel $ blid tb-  let f p fromSm =-        execUpdAtomic $ UpdAlterSmell (blid tb) p (Just fromSm) Nothing-  mapWithKeyM_ f lsmell-  execSfx-  return True---- ** OneOf--effectOneOf :: (MonadAtomic m, MonadServer m)-            => (IK.Effect -> m Bool)-            -> [IK.Effect]-            -> m Bool-effectOneOf recursiveCall l = do-  let call1 = do-        ef <- rndToAction $ oneOf l-        recursiveCall ef-      call99 = replicate 99 call1-      f callNext result = do-        b <- result-        if b then return True else callNext-  foldr f (return False) call99---- ** Recharging--effectRecharging :: (MonadAtomic m, MonadServer m)-                 => (IK.Effect -> m Bool)-                 -> IK.Effect -> Bool-                 -> m Bool-effectRecharging recursiveCall e recharged =-  if recharged-  then recursiveCall e-  else return False---- ** Temporary--effectTemporary :: (MonadAtomic m, MonadServer m)-                => m () -> ActorId -> ItemId-                -> m Bool-effectTemporary execSfx source iid = do-  bag <- getsState $ getCBag $ CActor source COrgan-  case iid `EM.lookup` bag of-    Just _ -> return ()  -- still some copies left of a multi-copy tmp item-    Nothing -> execSfx  -- last copy just destroyed-  return True

+ Game/LambdaHack/Server/HandleRequestM.hs view

@@ -0,0 +1,611 @@+{-# LANGUAGE GADTs #-}+-- | Semantics of request.+-- A couple of them do not take time, the rest does.+-- Note that since the results are atomic commands, which are executed+-- only later (on the server and some of the clients), all condition+-- are checkd by the semantic functions in the context of the state+-- before the server command. Even if one or more atomic actions+-- are already issued by the point an expression is evaluated, they do not+-- influence the outcome of the evaluation.+module Game.LambdaHack.Server.HandleRequestM+  ( handleRequestAI, handleRequestUI, switchLeader, handleRequestTimed+  , reqMove, reqDisplace, reqGameExit+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , setBWait, handleRequestTimedCases+  , affectSmell, reqMelee, reqAlter, reqWait+  , reqMoveItems, reqMoveItem, computeRndTimeout, reqProject, reqApply+  , reqGameRestart, reqGameSave, reqTactic, reqAutomate+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.EnumMap.Strict as EM++import Game.LambdaHack.Atomic+import qualified Game.LambdaHack.Common.Ability as Ability+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Vector+import qualified Game.LambdaHack.Content.ItemKind as IK+import Game.LambdaHack.Content.ModeKind+import qualified Game.LambdaHack.Content.TileKind as TK+import Game.LambdaHack.Server.CommonM+import Game.LambdaHack.Server.HandleEffectM+import Game.LambdaHack.Server.ItemM+import Game.LambdaHack.Server.MonadServer+import Game.LambdaHack.Server.PeriodicM+import Game.LambdaHack.Server.State++-- | The semantics of server commands.+-- AI always takes time and so doesn't loop.+handleRequestAI :: (MonadAtomic m)+                => ReqAI+                -> m (Maybe RequestAnyAbility)+handleRequestAI cmd = case cmd of+  ReqAITimed cmdT -> return $ Just cmdT+  ReqAINop -> return Nothing++-- | The semantics of server commands. Only the first two cases take time.+handleRequestUI :: (MonadAtomic m, MonadServer m)+                => FactionId -> ActorId -> ReqUI+                -> m (Maybe RequestAnyAbility)+handleRequestUI fid aid cmd = case cmd of+  ReqUITimed cmdT -> return $ Just cmdT+  ReqUIGameRestart t d -> reqGameRestart aid t d >> return Nothing+  ReqUIGameExit -> reqGameExit aid >> return Nothing+  ReqUIGameSave -> reqGameSave >> return Nothing+  ReqUITactic toT -> reqTactic fid toT >> return Nothing+  ReqUIAutomate -> reqAutomate fid >> return Nothing+  ReqUINop -> return Nothing++-- | This is a shorthand. Instead of setting @bwait@ in @ReqWait@+-- and unsetting in all other requests, we call this once before+-- executing a request.+setBWait :: (MonadAtomic m) => RequestTimed a -> ActorId -> m (Maybe Bool)+{-# INLINE setBWait #-}+setBWait cmd aid = do+  let mwait = case cmd of+        ReqWait -> Just True  -- true wait, with bracind, no overhead, etc.+        ReqWait10 -> Just False  -- false wait, only one clip at a time+        _ -> Nothing+  bPre <- getsState $ getActorBody aid+  when ((mwait == Just True) /= bwait bPre) $+    execUpdAtomic $ UpdWaitActor aid (mwait == Just True)+  return mwait++handleRequestTimed :: (MonadAtomic m, MonadServer m)+                   => FactionId -> ActorId -> RequestTimed a -> m Bool+handleRequestTimed fid aid cmd = do+  mwait <- setBWait cmd aid+  -- Note that only the ordinary 1-turn wait eliminates overhead.+  -- The more fine-graned waits don't make actors braced and induce+  -- overhead, so that they have some drawbacks in addition to the+  -- benefit of seeing approaching danger up to almost a turn faster.+  -- It may be too late to block then, but not too late to sidestep or attack.+  unless (mwait == Just True) $ overheadActorTime fid+  advanceTime aid (if mwait == Just False then 10 else 100)+  handleRequestTimedCases aid cmd+  managePerRequest aid+  return $! isNothing mwait  -- for speed, we report if @cmd@ harmless++-- | Clear deltas for Calm and HP for proper UI display and AI hints.+managePerRequest :: MonadAtomic m => ActorId -> m ()+managePerRequest aid = do+  b <- getsState $ getActorBody aid+  let clearMark = 0+  unless (bcalmDelta b == ResDelta (0, 0) (0, 0)) $+    -- Clear delta for the next player turn.+    execUpdAtomic $ UpdRefillCalm aid clearMark+  unless (bhpDelta b == ResDelta (0, 0) (0, 0)) $+    -- Clear delta for the next player turn.+    execUpdAtomic $ UpdRefillHP aid clearMark++handleRequestTimedCases :: (MonadAtomic m, MonadServer m)+                        => ActorId -> RequestTimed a -> m ()+handleRequestTimedCases aid cmd = case cmd of+  ReqMove target -> reqMove aid target+  ReqMelee target iid cstore -> reqMelee aid target iid cstore+  ReqDisplace target -> reqDisplace aid target+  ReqAlter tpos -> reqAlter aid tpos+  ReqWait -> reqWait aid+  ReqWait10 -> reqWait aid  -- the differences are handled elsewhere+  ReqMoveItems l -> reqMoveItems aid l+  ReqProject p eps iid cstore -> reqProject aid p eps iid cstore+  ReqApply iid cstore -> reqApply aid iid cstore++switchLeader :: (MonadAtomic m, MonadServer m)+             => FactionId -> ActorId -> m ()+{-# INLINE switchLeader #-}+switchLeader fid aidNew = do+  fact <- getsState $ (EM.! fid) . sfactionD+  bPre <- getsState $ getActorBody aidNew+  let mleader = _gleader fact+      !_A1 = assert (Just aidNew /= mleader+                     && not (bproj bPre)+                     `blame` (aidNew, bPre, fid, fact)) ()+      !_A2 = assert (bfid bPre == fid+                     `blame` "client tries to move other faction actors"+                     `twith` (aidNew, bPre, fid, fact)) ()+  let (autoDun, _) = autoDungeonLevel fact+  arena <- case mleader of+    Nothing -> return $! blid bPre+    Just leader -> do+      b <- getsState $ getActorBody leader+      return $! blid b+  if | blid bPre /= arena && autoDun ->+       execFailure aidNew ReqWait{-hack-} NoChangeDunLeader+     | otherwise -> do+       execUpdAtomic $ UpdLeadFaction fid mleader (Just aidNew)+     -- We exchange times of the old and new leader.+     -- This permits an abuse, because a slow tank can be moved fast+     -- by alternating between it and many fast actors (until all of them+     -- get slowed down by this and none remain). But at least the sum+     -- of all times of a faction is conserved. And we avoid double moves+     -- against the UI player caused by his leader changes. There may still+     -- happen double moves caused by AI leader changes, but that's rare.+     -- The flip side is the possibility of multi-moves of the UI player+     -- as in the case of the tank.+     -- Warning: when the action is performed on the server,+     -- the time of the actor is different than when client prepared that+     -- action, so any client checks involving time should discount this.+       case mleader of+         Just aidOld | aidOld /= aidNew -> swapTime aidOld aidNew+         _ -> return ()++-- * ReqMove++-- | Add a smell trace for the actor to the level. For now, only actors+-- with gender leave strong and unique enough smell. If smell already there+-- and the actor can smell, remove smell. Projectiles are ignored.+-- As long as an actor can smell, he doesn't leave any smell ever.+affectSmell :: (MonadAtomic m, MonadServer m) => ActorId -> m ()+affectSmell aid = do+  b <- getsState $ getActorBody aid+  unless (bproj b) $ do+    fact <- getsState $ (EM.! bfid b) . sfactionD+    actorAspect <- getsServer sactorAspect+    let ar = actorAspect EM.! aid+        smellRadius = aSmell ar+    when (fhasGender (gplayer fact) || smellRadius > 0) $ do+      localTime <- getsState $ getLocalTime $ blid b+      lvl <- getLevel $ blid b+      let oldS = fromMaybe timeZero $ EM.lookup (bpos b) . lsmell $ lvl+          newTime = timeShift localTime smellTimeout+          newS = if smellRadius > 0+                 then timeZero+                 else newTime+      when (oldS /= newS) $+        execUpdAtomic $ UpdAlterSmell (blid b) (bpos b) oldS newS++-- | Actor moves or attacks.+-- Note that client may not be able to see an invisible monster+-- so it's the server that determines if melee took place, etc.+-- Also, only the server is authorized to check if a move is legal+-- and it needs full context for that, e.g., the initial actor position+-- to check if melee attack does not try to reach to a distant tile.+reqMove :: (MonadAtomic m, MonadServer m) => ActorId -> Vector -> m ()+reqMove source dir = do+  Kind.COps{coTileSpeedup} <- getsState scops+  sb <- getsState $ getActorBody source+  let lid = blid sb+  lvl <- getLevel lid+  let spos = bpos sb           -- source position+      tpos = spos `shift` dir  -- target position+  -- We start by checking actors at the target position.+  tgt <- getsState $ posToAssocs tpos lid+  case tgt of+    (target, tb) : _ | not (bproj sb && bproj tb) -> do  -- visible or not+      -- Projectiles are too small to hit each other.+      -- Here the only weapon of projectiles is picked, too.+      mweapon <- pickWeaponServer source+      case mweapon of+        Nothing -> reqWait source+        Just (wp, cstore) -> reqMelee source target wp cstore+    _+      | Tile.isWalkable coTileSpeedup $ lvl `at` tpos -> do+          -- Movement requires full access.+          execUpdAtomic $ UpdMoveActor source spos tpos+          affectSmell source+      | otherwise ->+          -- Client foolishly tries to move into blocked, boring tile.+          execFailure source (ReqMove dir) MoveNothing++-- * ReqMelee++-- | Resolves the result of an actor moving into another.+-- Actors on blocked positions can be attacked without any restrictions.+-- For instance, an actor embedded in a wall can be attacked from+-- an adjacent position. This function is analogous to projectGroupItem,+-- but for melee and not using up the weapon.+-- No problem if there are many projectiles at the spot. We just+-- attack the one specified.+reqMelee :: (MonadAtomic m, MonadServer m)+         => ActorId -> ActorId -> ItemId -> CStore -> m ()+reqMelee source target iid cstore = do+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  let adj = checkAdjacent sb tb+      req = ReqMelee target iid cstore+  if source == target then execFailure source req MeleeSelf+  else if not adj then execFailure source req MeleeDistant+  else do+    let sfid = bfid sb+        tfid = bfid tb+    sfact <- getsState $ (EM.! sfid) . sfactionD+    ttrunk <- getsState $ getItemBody $ btrunk tb+    -- Only catch with appendages, never with weapons. Never steal trunk+    -- from an already caught projectile or one with many items inside.+    if bproj tb && length (beqp tb) == 1 && jweight ttrunk > 1  -- not a blast+       && cstore == COrgan then do+      -- Catching the projectile, that is, stealing the item from its eqp.+      -- No effect from our weapon (organ) is applied to the projectile+      -- and the weapon (organ) is never destroyed, even if not durable.+      -- Pushed actor doesn't stop flight by catching the projectile+      -- nor does he lose 1HP.+      -- This is not overpowered, because usually at least one partial wait+      -- is needed to sync (if not, attacker should switch missiles)+      -- and so only every other missile can be caught. Normal sidestepping+      -- or sync and displace, if in a corridor, is as effective+      -- and blocking can be even more so, depending on stats of the missile.+      -- Missiles are really easy to defend against, but sight (and so, Calm)+      -- is the key, as well as light, ambush around a corner, etc.+      execSfxAtomic $ SfxSteal source target iid cstore+      case EM.assocs $ beqp tb of+        [(iid2, (k, _))] -> do+          upds <- generalMoveItem True iid2 k (CActor target CEqp)+                                              (CActor source CInv)+          mapM_ execUpdAtomic upds+        err -> assert `failure` err+      -- Let the caught missile vanish, but don't remove its trajectory+      -- so that it doesn't pretend to be a non-projectile.+      execUpdAtomic $ UpdTrajectory target (btrajectory tb)+                                           (Just ([], toSpeed 0))+    else do+      -- Normal hit, with effects. Msgs inside @SfxStrike@ describe+      -- the source part of the strike.+      execSfxAtomic $ SfxStrike source target iid cstore+      let c = CActor source cstore+      -- Msgs inside @itemEffect@ describe the target part of the strike.+      -- If any effects and aspects, this is also where they are identified.+      -- Here also the melee damage is applied, before any effects are.+      meleeEffectAndDestroy source target iid c+      sb2 <- getsState $ getActorBody source+      case btrajectory sb2 of+        Just (tra, speed) | not $ null tra -> do+          -- Deduct a hitpoint for a pierce of a projectile+          -- or due to a hurled actor colliding with another.+          -- Don't deduct if no pierce, to prevent spam.+          when (not (bproj sb2) || bhp sb2 > oneM) $+            execUpdAtomic $ UpdRefillHP source minusM+          when (not (bproj sb2) || bhp sb2 <= oneM) $+            -- Non-projectiles can't pierce, so terminate their flight.+            -- If projectile has too low HP to pierce, ditto.+            execUpdAtomic+            $ UpdTrajectory source (btrajectory sb2) (Just ([], speed))+        _ -> return ()+      -- The only way to start a war is to slap an enemy. Being hit by+      -- and hitting projectiles count as unintentional friendly fire.+      let friendlyFire = bproj sb2 || bproj tb+          fromDipl = EM.findWithDefault Unknown tfid (gdipl sfact)+      unless (friendlyFire+              || isAtWar sfact tfid  -- already at war+              || isAllied sfact tfid  -- allies never at war+              || sfid == tfid) $+        execUpdAtomic $ UpdDiplFaction sfid tfid fromDipl War++-- * ReqDisplace++-- | Actor tries to swap positions with another.+reqDisplace :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m ()+reqDisplace source target = do+  Kind.COps{coTileSpeedup} <- getsState scops+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  tfact <- getsState $ (EM.! bfid tb) . sfactionD+  let tpos = bpos tb+      adj = checkAdjacent sb tb+      atWar = isAtWar tfact (bfid sb)+      req = ReqDisplace target+  actorAspect <- getsServer sactorAspect+  let ar = actorAspect EM.! target+  dEnemy <- getsState $ dispEnemy source target $ aSkills ar+  if | not adj -> execFailure source req DisplaceDistant+     | atWar && not dEnemy -> do  -- if not at war, can displace+       mweapon <- pickWeaponServer source+       case mweapon of+         Nothing -> reqWait source+         Just (wp, cstore)  -> reqMelee source target wp cstore+           -- DisplaceDying, etc.+     | otherwise -> do+       let lid = blid sb+       lvl <- getLevel lid+       -- Displacing requires full access.+       if Tile.isWalkable coTileSpeedup $ lvl `at` tpos then+         case posToAidsLvl tpos lvl of+           [] -> assert `failure` (source, sb, target, tb)+           [_] -> do+             execUpdAtomic $ UpdDisplaceActor source target+             -- We leave or wipe out smell, for consistency, but it's not+             -- absolute consistency, e.g., blinking doesn't touch smell,+             -- so sometimes smellers will backtrack once to wipe smell. OK.+             affectSmell source+             affectSmell target+           _ -> execFailure source req DisplaceProjectiles+       else+         -- Client foolishly tries to displace an actor without access.+         execFailure source req DisplaceAccess++-- * ReqAlter++-- | Search and/or alter the tile.+--+-- Note that if @serverTile /= freshClientTile@, @freshClientTile@+-- should not be alterable (but @serverTile@ may be).+reqAlter :: (MonadAtomic m, MonadServer m) => ActorId -> Point -> m ()+reqAlter source tpos = do+  Kind.COps{cotile=Kind.Ops{okind, opick}, coTileSpeedup} <- getsState scops+  sb <- getsState $ getActorBody source+  actorSk <- currentSkillsServer source+  let alterSkill = EM.findWithDefault 0 Ability.AbAlter actorSk+      lid = blid sb+      spos = bpos sb+      req = ReqAlter tpos+  lvl <- getLevel lid+  let serverTile = lvl `at` tpos+      hidden = Tile.isHideAs coTileSpeedup serverTile+  -- Only actors with AbAlter > 1 can search for hidden doors, etc.+  if alterSkill <= 1+     || not hidden  -- no searching needed+        && alterSkill < Tile.alterMinSkill coTileSpeedup serverTile+  then execFailure source req AlterUnskilled+  else if not $ adjacent spos tpos then execFailure source req AlterDistant+  else do+    let changeTo tgroup = do+          -- No @SfxAlter@, because the effect is obvious (e.g., opened door).+          let nightCond kt = not (Tile.kindHasFeature TK.Walkable kt+                                  && Tile.kindHasFeature TK.Clear kt)+                             || (if lnight lvl then id else not)+                                  (Tile.kindHasFeature TK.Dark kt)+          -- Sometimes the tile is determined precisely by the ambient light+          -- of the source tiles. If not, default to cave day/night condition.+          mtoTile <- rndToAction $ opick tgroup nightCond+          toTile <- maybe (rndToAction $ fromMaybe (assert `failure` tgroup)+                                         <$> opick tgroup (const True))+                          return+                          mtoTile+          unless (toTile == serverTile) $ do+            execUpdAtomic $ UpdAlterTile lid tpos serverTile toTile+            case (Tile.isExplorable coTileSpeedup serverTile,+                  Tile.isExplorable coTileSpeedup toTile) of+              (False, True) -> execUpdAtomic $ UpdAlterClear lid 1+              (True, False) -> execUpdAtomic $ UpdAlterClear lid (-1)+              _ -> return ()+        feats = TK.tfeature $ okind serverTile+        toAlter feat =+          case feat of+            TK.OpenTo tgroup -> Just tgroup+            TK.CloseTo tgroup -> Just tgroup+            TK.ChangeTo tgroup -> Just tgroup+            _ -> Nothing+        groupsToAlterTo = mapMaybe toAlter feats+    embeds <- getsState $ getEmbedBag lid tpos+    if null groupsToAlterTo && null embeds && not hidden then+      -- Neither searching nor altering possible; silly client.+      execFailure source req AlterNothing+    else+      if EM.notMember tpos $ lfloor lvl then+        if null (posToAidsLvl tpos lvl) then do+          when hidden $+            -- Search, in case some actors present (e.g., of other factions)+            -- don't know this tile.+            execUpdAtomic $ UpdSearchTile source tpos serverTile+          when (alterSkill >= Tile.alterMinSkill coTileSpeedup serverTile) $ do+            case groupsToAlterTo of+              [] -> return ()+              [groupToAlterTo] -> changeTo groupToAlterTo+              l -> assert `failure` "tile changeable in many ways" `twith` l+            itemEffectEmbedded source tpos embeds+        else execFailure source req AlterBlockActor+      else execFailure source req AlterBlockItem++-- * ReqWait++-- | Do nothing.+--+-- Something is sometimes done in 'setBWait'.+reqWait :: MonadAtomic m => ActorId -> m ()+{-# INLINE reqWait #-}+reqWait _ = return ()++-- * ReqMoveItems++reqMoveItems :: (MonadAtomic m, MonadServer m)+             => ActorId -> [(ItemId, Int, CStore, CStore)] -> m ()+reqMoveItems aid l = do+  b <- getsState $ getActorBody aid+  actorAspect <- getsServer sactorAspect+  let ar = actorAspect EM.! aid+  -- Server accepts item movement based on calm at the start, not end+  -- or in the middle, to avoid interrupted or partially ignored commands.+      calmE = calmEnough b ar+  mapM_ (reqMoveItem aid calmE) l++reqMoveItem :: (MonadAtomic m, MonadServer m)+            => ActorId -> Bool -> (ItemId, Int, CStore, CStore) -> m ()+reqMoveItem aid calmE (iid, k, fromCStore, toCStore) = do+  b <- getsState $ getActorBody aid+  let fromC = CActor aid fromCStore+      req = ReqMoveItems [(iid, k, fromCStore, toCStore)]+  toC <- case toCStore of+    CGround -> pickDroppable aid b+    _ -> return $! CActor aid toCStore+  bagBefore <- getsState $ getContainerBag toC+  if+   | k < 1 || fromCStore == toCStore -> execFailure aid req ItemNothing+   | toCStore == CEqp && eqpOverfull b k ->+     execFailure aid req EqpOverfull+   | (fromCStore == CSha || toCStore == CSha) && not calmE ->+     execFailure aid req ItemNotCalm+   | otherwise -> do+    itemToF <- itemToFullServer+    let itemFull = itemToF iid (k, [])+    when (fromCStore == CGround) $+      case itemFull of+        ItemFull{itemDisco=+                   Just ItemDisco{itemKind=IK.ItemKind{IK.ieffects}}}+          | any IK.forIdEffect ieffects -> return ()  -- discover by use+        _ -> do+          seed <- getsServer $ (EM.! iid) . sitemSeedD+          execUpdAtomic $ UpdDiscoverSeed fromC iid seed+    upds <- generalMoveItem True iid k fromC toC+    mapM_ execUpdAtomic upds+    -- Reset timeout for equipped periodic items.+    when (toCStore `elem` [CEqp, COrgan]+          && fromCStore `notElem` [CEqp, COrgan]) $ do+      localTime <- getsState $ getLocalTime (blid b)+      -- The first recharging period after pick up is random,+      -- between 1 and 2 standard timeouts of the item.+      mrndTimeout <- rndToAction $ computeRndTimeout localTime iid itemFull+      let beforeIt = case iid `EM.lookup` bagBefore of+            Nothing -> []  -- no such items before move+            Just (_, it2) -> it2+      -- The moved item set (not the whole stack) has its timeout+      -- reset to a random value between timeout and twice timeout.+      -- This prevents micromanagement via swapping items in and out of eqp+      -- and via exact prediction of first timeout after equip.+      case mrndTimeout of+        Just rndT -> do+          bagAfter <- getsState $ getContainerBag toC+          let afterIt = case iid `EM.lookup` bagAfter of+                Nothing -> assert `failure` (iid, bagAfter, toC)+                Just (_, it2) -> it2+              resetIt = beforeIt ++ replicate k rndT+          when (afterIt /= resetIt) $+            execUpdAtomic $ UpdTimeItem iid toC afterIt resetIt+        Nothing -> return ()  -- no Periodic or Timeout aspect; don't touch++computeRndTimeout :: Time -> ItemId -> ItemFull -> Rnd (Maybe Time)+computeRndTimeout localTime iid ItemFull{..}=+  case itemDisco of+    Just ItemDisco{itemKind, itemAspect=Just ar} ->+      case aTimeout ar of+        t | t /= 0 && IK.Periodic `elem` IK.ieffects itemKind -> do+          rndT <- randomR (0, t)+          let rndTurns = timeDeltaScale (Delta timeTurn) rndT+          return $ Just $ timeShift localTime rndTurns+        _ -> return Nothing+    _ -> assert `failure` iid++-- * ReqProject++reqProject :: (MonadAtomic m, MonadServer m)+           => ActorId    -- ^ actor projecting the item (is on current lvl)+           -> Point      -- ^ target position of the projectile+           -> Int        -- ^ digital line parameter+           -> ItemId     -- ^ the item to be projected+           -> CStore     -- ^ whether the items comes from floor or inventory+           -> m ()+reqProject source tpxy eps iid cstore = do+  let req = ReqProject tpxy eps iid cstore+  b <- getsState $ getActorBody source+  actorAspect <- getsServer sactorAspect+  let ar = actorAspect EM.! source+      calmE = calmEnough b ar+  if cstore == CSha && not calmE then execFailure source req ItemNotCalm+  else do+    mfail <- projectFail source tpxy eps iid cstore False+    maybe (return ()) (execFailure source req) mfail++-- * ReqApply++reqApply :: (MonadAtomic m, MonadServer m)+         => ActorId  -- ^ actor applying the item (is on current level)+         -> ItemId   -- ^ the item to be applied+         -> CStore   -- ^ the location of the item+         -> m ()+reqApply aid iid cstore = do+  let req = ReqApply iid cstore+  b <- getsState $ getActorBody aid+  actorAspect <- getsServer sactorAspect+  let ar = actorAspect EM.! aid+      calmE = calmEnough b ar+  if cstore == CSha && not calmE then execFailure aid req ItemNotCalm+  else do+    bag <- getsState $ getBodyStoreBag b cstore+    case EM.lookup iid bag of+      Nothing -> execFailure aid req ApplyOutOfReach+      Just kit -> do+        itemToF <- itemToFullServer+        actorSk <- currentSkillsServer aid+        localTime <- getsState $ getLocalTime (blid b)+        let skill = EM.findWithDefault 0 Ability.AbApply actorSk+            itemFull = itemToF iid kit+            legal = permittedApply localTime skill calmE " " itemFull+        case legal of+          Left reqFail -> execFailure aid req reqFail+          Right _ -> applyItem aid iid cstore++-- * ReqGameRestart++reqGameRestart :: (MonadAtomic m, MonadServer m)+               => ActorId -> GroupName ModeKind -> Challenge+               -> m ()+reqGameRestart aid groupName scurChalSer = do+  modifyServer $ \ser -> ser {sdebugNxt = (sdebugNxt ser) {scurChalSer}}+  b <- getsState $ getActorBody aid+  oldSt <- getsState $ gquit . (EM.! bfid b) . sfactionD+  modifyServer $ \ser ->+    ser { swriteSave = True  -- fake saving to abort turn+        , squit = True }  -- do this at once+  isNoConfirms <- isNoConfirmsGame+  -- This call to `revealItems` is really needed, because the other+  -- happens only at game conclusion, not at quitting.+  unless isNoConfirms $ revealItems Nothing+  execUpdAtomic $ UpdQuitFaction (bfid b) oldSt+                $ Just $ Status Restart (fromEnum $ blid b) (Just groupName)++-- * ReqGameExit++reqGameExit :: (MonadAtomic m, MonadServer m) => ActorId -> m ()+reqGameExit aid = do+  b <- getsState $ getActorBody aid+  oldSt <- getsState $ gquit . (EM.! bfid b) . sfactionD+  modifyServer $ \ser -> ser { swriteSave = True+                             , squit = True }  -- do this at once+  execUpdAtomic $ UpdQuitFaction (bfid b) oldSt+                $ Just $ Status Camping (fromEnum $ blid b) Nothing++-- * ReqGameSave++reqGameSave :: MonadServer m => m ()+reqGameSave =+  modifyServer $ \ser -> ser { swriteSave = True+                             , squit = True }  -- do this at once++-- * ReqTactic++reqTactic :: MonadAtomic m => FactionId -> Tactic -> m ()+reqTactic fid toT = do+  fromT <- getsState $ ftactic . gplayer . (EM.! fid) . sfactionD+  execUpdAtomic $ UpdTacticFaction fid toT fromT++-- * ReqAutomate++reqAutomate :: MonadAtomic m => FactionId -> m ()+reqAutomate fid = execUpdAtomic $ UpdAutoFaction fid True

− Game/LambdaHack/Server/HandleRequestServer.hs

@@ -1,540 +0,0 @@-{-# LANGUAGE GADTs #-}--- | Semantics of request.--- A couple of them do not take time, the rest does.--- Note that since the results are atomic commands, which are executed--- only later (on the server and some of the clients), all condition--- are checkd by the semantic functions in the context of the state--- before the server command. Even if one or more atomic actions--- are already issued by the point an expression is evaluated, they do not--- influence the outcome of the evaluation.--- TODO: document-module Game.LambdaHack.Server.HandleRequestServer-  ( handleRequestAI, handleRequestUI, reqMove, reqDisplace-  ) where--import Control.Applicative-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.Maybe-import Data.Text (Text)--import Game.LambdaHack.Atomic-import qualified Game.LambdaHack.Common.Ability as Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.ModeKind-import qualified Game.LambdaHack.Content.TileKind as TK-import Game.LambdaHack.Server.CommonServer-import Game.LambdaHack.Server.HandleEffectServer-import Game.LambdaHack.Server.ItemServer-import Game.LambdaHack.Server.MonadServer-import Game.LambdaHack.Server.State---- | The semantics of server commands. The resulting actor id--- is of the actor that carried out the request.-handleRequestAI :: (MonadAtomic m, MonadServer m)-                => FactionId -> ActorId -> RequestAI -> m (ActorId, m ())-handleRequestAI fid aid cmd = case cmd of-  ReqAITimed cmdT -> return (aid, handleRequestTimed aid cmdT)-  ReqAILeader aidNew mtgtNew cmd2 -> do-    switchLeader fid aidNew mtgtNew-    handleRequestAI fid aidNew cmd2-  ReqAIPong -> return (aid, return ())---- | The semantics of server commands. The resulting actor id--- is of the actor that carried out the request. @Nothing@ means--- the command took no time.-handleRequestUI :: (MonadAtomic m, MonadServer m)-                => FactionId -> RequestUI -> m (Maybe ActorId, m ())-handleRequestUI fid cmd = case cmd of-  ReqUITimed cmdT -> do-    fact <- getsState $ (EM.! fid) . sfactionD-    let (aid, _) = fromMaybe (assert `failure` fact) $ gleader fact-    return (Just aid, handleRequestTimed aid cmdT)-  ReqUILeader aidNew mtgtNew cmd2 -> do-    switchLeader fid aidNew mtgtNew-    handleRequestUI fid cmd2-  ReqUIGameRestart aid t d names ->-    return (Nothing, reqGameRestart aid t d names)-  ReqUIGameExit aid -> return (Nothing, reqGameExit aid)-  ReqUIGameSave -> return (Nothing, reqGameSave)-  ReqUITactic toT -> return (Nothing, reqTactic fid toT)-  ReqUIAutomate -> return (Nothing, reqAutomate fid)-  ReqUIPong _ -> return (Nothing, return ())--handleRequestTimed :: (MonadAtomic m, MonadServer m)-                   => ActorId -> RequestTimed a -> m ()-handleRequestTimed aid cmd = case cmd of-  ReqMove target -> reqMove aid target-  ReqMelee target iid cstore -> reqMelee aid target iid cstore-  ReqDisplace target -> reqDisplace aid target-  ReqAlter tpos mfeat -> reqAlter aid tpos mfeat-  ReqWait -> reqWait aid-  ReqMoveItems l -> reqMoveItems aid l-  ReqProject p eps iid cstore -> reqProject aid p eps iid cstore-  ReqApply iid cstore -> reqApply aid iid cstore-  ReqTrigger mfeat -> reqTrigger aid mfeat--switchLeader :: (MonadAtomic m, MonadServer m)-             => FactionId -> ActorId -> Maybe Target -> m ()-switchLeader fid aidNew mtgtNew = do-  fact <- getsState $ (EM.! fid) . sfactionD-  bPre <- getsState $ getActorBody aidNew-  let mleader = gleader fact-      actorChanged = fmap fst mleader /= Just aidNew-  let !_A = assert (Just (aidNew, mtgtNew) /= mleader-                    && not (bproj bPre)-                    `blame` (aidNew, mtgtNew, bPre, fid, fact)) ()-  let !_A = assert (bfid bPre == fid-                    `blame` "client tries to move other faction actors"-                    `twith` (aidNew, mtgtNew, bPre, fid, fact)) ()-  let (autoDun, autoLvl) = autoDungeonLevel fact-  arena <- case mleader of-    Nothing -> return $! blid bPre-    Just (leader, _) -> do-      b <- getsState $ getActorBody leader-      return $! blid b-  if actorChanged && blid bPre /= arena && autoDun-  then execFailure aidNew ReqWait{-hack-} NoChangeDunLeader-  else if actorChanged && autoLvl-  then execFailure aidNew ReqWait{-hack-} NoChangeLvlLeader-  else execUpdAtomic $ UpdLeadFaction fid mleader (Just (aidNew, mtgtNew))---- * ReqMove---- TODO: let only some actors/items leave smell, e.g., a Smelly Hide Armour--- and then remove the efficiency hack below that only heroes leave smell--- | Add a smell trace for the actor to the level. For now, only heroes--- leave smell. If smell already there and the actor can smell, remove smell.-addSmell :: (MonadAtomic m, MonadServer m) => ActorId -> m ()-addSmell aid = do-  b <- getsState $ getActorBody aid-  fact <- getsState $ (EM.! bfid b) . sfactionD-  smellRadius <- sumOrganEqpServer IK.EqpSlotAddSmell aid-  let dumbMonster = not (fhasGender $ gplayer fact) && smellRadius <= 0-  unless (bproj b || dumbMonster) $ do-    -- TODO: right now only humans leave smell and content should not-    -- give humans the ability to smell (dominated monsters are rare enough).-    -- In the future smells should be marked by the faction that left them-    -- and actors shold only follow enemy smells.-    time <- getsState $ getLocalTime $ blid b-    lvl <- getLevel $ blid b-    let oldS = EM.lookup (bpos b) . lsmell $ lvl-        newTime = timeShift time smellTimeout-        newS = if smellRadius > 0-               then Nothing       -- smelling monster or hero-               else Just newTime  -- hero-    when (oldS /= newS) $-      execUpdAtomic $ UpdAlterSmell (blid b) (bpos b) oldS newS---- | Actor moves or attacks.--- Note that client may not be able to see an invisible monster--- so it's the server that determines if melee took place, etc.--- Also, only the server is authorized to check if a move is legal--- and it needs full context for that, e.g., the initial actor position--- to check if melee attack does not try to reach to a distant tile.-reqMove :: (MonadAtomic m, MonadServer m) => ActorId -> Vector -> m ()-reqMove source dir = do-  cops <- getsState scops-  sb <- getsState $ getActorBody source-  let lid = blid sb-  lvl <- getLevel lid-  let spos = bpos sb           -- source position-      tpos = spos `shift` dir  -- target position-  -- We start by checking actors at the the target position.-  tgt <- getsState $ posToActors tpos lid-  case tgt of-    (target, tb) : _ | not (bproj sb && bproj tb) -> do  -- visible or not-      -- Projectiles are too small to hit each other.-      -- Attacking does not require full access, adjacency is enough.-      -- Here the only weapon of projectiles is picked, too.-      mweapon <- pickWeaponServer source-      case mweapon of-        Nothing -> reqWait source-        Just (wp, cstore) -> reqMelee source target wp cstore-    _-      | accessible cops lvl spos tpos -> do-          -- Movement requires full access.-          execUpdAtomic $ UpdMoveActor source spos tpos-          addSmell source-      | otherwise ->-          -- Client foolishly tries to move into blocked, boring tile.-          execFailure source (ReqMove dir) MoveNothing---- * ReqMelee---- | Resolves the result of an actor moving into another.--- Actors on blocked positions can be attacked without any restrictions.--- For instance, an actor embedded in a wall can be attacked from--- an adjacent position. This function is analogous to projectGroupItem,--- but for melee and not using up the weapon.--- No problem if there are many projectiles at the spot. We just--- attack the one specified.-reqMelee :: (MonadAtomic m, MonadServer m)-         => ActorId -> ActorId -> ItemId -> CStore -> m ()-reqMelee source target iid cstore = do-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  let adj = checkAdjacent sb tb-      req = ReqMelee target iid cstore-  if source == target then execFailure source req MeleeSelf-  else if not adj then execFailure source req MeleeDistant-  else do-    let sfid = bfid sb-        tfid = bfid tb-    sfact <- getsState $ (EM.! sfid) . sfactionD-    hurtBonus <- armorHurtBonus source target-    let hitA | hurtBonus <= -50  -- e.g., braced and no hit bonus-               = HitBlock 2-             | hurtBonus <= -10  -- low bonus vs armor-               = HitBlock 1-             | otherwise = HitClear-    execSfxAtomic $ SfxStrike source target iid cstore hitA-    -- Deduct a hitpoint for a pierce of a projectile-    -- or due to a hurled actor colliding with another or a wall.-    case btrajectory sb of-      Nothing -> return ()-      Just (tra, speed) -> do-        execUpdAtomic $ UpdRefillHP source minusM-        unless (bproj sb || null tra) $-          -- Non-projectiles can't pierce, so terminate their flight.-          execUpdAtomic-          $ UpdTrajectory source (btrajectory sb) (Just ([], speed))-    let c = CActor source cstore-    -- Msgs inside itemEffect describe the target part.-    itemEffectAndDestroy source target iid c-    -- The only way to start a war is to slap an enemy. Being hit by-    -- and hitting projectiles count as unintentional friendly fire.-    let friendlyFire = bproj sb || bproj tb-        fromDipl = EM.findWithDefault Unknown tfid (gdipl sfact)-    unless (friendlyFire-            || isAtWar sfact tfid  -- already at war-            || isAllied sfact tfid  -- allies never at war-            || sfid == tfid) $-      execUpdAtomic $ UpdDiplFaction sfid tfid fromDipl War---- * ReqDisplace---- | Actor tries to swap positions with another.-reqDisplace :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m ()-reqDisplace source target = do-  cops <- getsState scops-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  tfact <- getsState $ (EM.! bfid tb) . sfactionD-  let spos = bpos sb-      tpos = bpos tb-      adj = checkAdjacent sb tb-      atWar = isAtWar tfact (bfid sb)-      req = ReqDisplace target-  activeItems <- activeItemsServer target-  dEnemy <- getsState $ dispEnemy source target activeItems-  if not adj then execFailure source req DisplaceDistant-  else if atWar && not dEnemy-  then do-    mweapon <- pickWeaponServer source-    case mweapon of-      Nothing -> reqWait source-      Just (wp, cstore)  -> reqMelee source target wp cstore-        -- DisplaceDying, etc.-  else do-    let lid = blid sb-    lvl <- getLevel lid-    -- Displacing requires full access.-    if accessible cops lvl spos tpos then do-      tgts <- getsState $ posToActors tpos lid-      case tgts of-        [] -> assert `failure` (source, sb, target, tb)-        [_] -> execUpdAtomic $ UpdDisplaceActor source target-        _ -> execFailure source req DisplaceProjectiles-    else-      -- Client foolishly tries to displace an actor without access.-      execFailure source req DisplaceAccess---- * ReqAlter---- | Search and/or alter the tile.------ Note that if @serverTile /= freshClientTile@, @freshClientTile@--- should not be alterable (but @serverTile@ may be).-reqAlter :: (MonadAtomic m, MonadServer m)-         => ActorId -> Point -> Maybe TK.Feature -> m ()-reqAlter source tpos mfeat = do-  cops@Kind.COps{cotile=cotile@Kind.Ops{okind, opick}} <- getsState scops-  sb <- getsState $ getActorBody source-  actorSk <- actorSkillsServer source-  let skill = EM.findWithDefault 0 Ability.AbAlter actorSk-      lid = blid sb-      spos = bpos sb-      req = ReqAlter tpos mfeat-  -- Only actors with AbAlter can search for hidden doors, etc.-  if skill < 1 then execFailure source req AlterUnskilled-  else if not $ adjacent spos tpos then execFailure source req AlterDistant-  else do-    lvl <- getLevel lid-    let serverTile = lvl `at` tpos-        freshClientTile = hideTile cops lvl tpos-        changeTo tgroup = do-          -- No @SfxAlter@, because the effect is obvious (e.g., opened door).-          toTile <- rndToAction $ fromMaybe (assert `failure` tgroup)-                                  <$> opick tgroup (const True)-          unless (toTile == serverTile) $ do-            execUpdAtomic $ UpdAlterTile lid tpos serverTile toTile-            case (Tile.isExplorable cotile serverTile,-                  Tile.isExplorable cotile toTile) of-              (False, True) -> execUpdAtomic $ UpdAlterClear lid 1-              (True, False) -> execUpdAtomic $ UpdAlterClear lid (-1)-              _ -> return ()-        feats = case mfeat of-          Nothing -> TK.tfeature $ okind serverTile-          Just feat2 | Tile.hasFeature cotile feat2 serverTile -> [feat2]-          Just _ -> []-        toAlter feat =-          case feat of-            TK.OpenTo tgroup -> Just tgroup-            TK.CloseTo tgroup -> Just tgroup-            TK.ChangeTo tgroup -> Just tgroup-            _ -> Nothing-        groupsToAlterTo = mapMaybe toAlter feats-    as <- getsState $ actorList (const True) lid-    if null groupsToAlterTo && serverTile == freshClientTile then-      -- Neither searching nor altering possible; silly client.-      execFailure source req AlterNothing-    else-      if EM.notMember tpos $ lfloor lvl then-        if unoccupied as tpos then do-          when (serverTile /= freshClientTile) $-            -- Search, in case some actors (of other factions?)-            -- don't know this tile.-            execUpdAtomic $ UpdSearchTile source tpos freshClientTile serverTile-          maybe (return ()) changeTo $ listToMaybe groupsToAlterTo-            -- TODO: pick another, if the first one void-          -- Perform an effect, if any permitted.-          void $ triggerEffect source tpos feats-        else execFailure source req AlterBlockActor-      else execFailure source req AlterBlockItem---- * ReqWait---- | Do nothing.------ Something is sometimes done in 'LoopAction.setBWait'.-reqWait :: MonadAtomic m => ActorId -> m ()-reqWait _ = return ()---- * ReqMoveItems--reqMoveItems :: (MonadAtomic m, MonadServer m)-             => ActorId -> [(ItemId, Int, CStore, CStore)] -> m ()-reqMoveItems aid l = do-  b <- getsState $ getActorBody aid-  activeItems <- activeItemsServer aid-  -- Server accepts item movement based on calm at the start, not end-  -- or in the middle, to avoid interrupted or partially ignored commands.-  let calmE = calmEnough b activeItems-  mapM_ (reqMoveItem aid calmE) l--reqMoveItem :: (MonadAtomic m, MonadServer m)-            => ActorId -> Bool -> (ItemId, Int, CStore, CStore) -> m ()-reqMoveItem aid calmE (iid, k, fromCStore, toCStore) = do-  b <- getsState $ getActorBody aid-  let fromC = CActor aid fromCStore-      toC = CActor aid toCStore-      req = ReqMoveItems [(iid, k, fromCStore, toCStore)]-  bagBefore <- getsState $ getCBag toC-  if k < 1 || fromCStore == toCStore then execFailure aid req ItemNothing-  else if toCStore == CEqp-          && eqpOverfull b k then execFailure aid req EqpOverfull-  else if (fromCStore == CSha || toCStore == CSha)-          && not calmE then execFailure aid req ItemNotCalm-  else do-    when (fromCStore == CGround) $ do-      seed <- getsServer $ (EM.! iid) . sitemSeedD-      item <- getsState $ getItemBody iid-      Level{ldepth} <- getLevel $ jlid item-      execUpdAtomic $ UpdDiscoverSeed fromC iid seed ldepth-    upds <- generalMoveItem iid k fromC toC-    mapM_ execUpdAtomic upds-    -- Reset timeout for equipped periodic items.-    when (toCStore `elem` [CEqp, COrgan]-          && fromCStore `notElem` [CEqp, COrgan]) $ do-      localTime <- getsState $ getLocalTime (blid b)-      discoEffect <- getsServer sdiscoEffect-      -- The first recharging period after pick up is random,-      -- between 1 and 2 standard timeouts of the item.-      mrndTimeout <- rndToAction $ computeRndTimeout localTime discoEffect iid-      let beforeIt = case iid `EM.lookup` bagBefore of-            Nothing -> []  -- no such items before move-            Just (_, it2) -> it2-      -- The moved item set (not the whole stack) has its timeout-      -- reset to a random value between timeout and twice timeout.-      -- This prevents micromanagement via swapping items in and out of eqp-      -- and via exact prediction of first timeout after equip.-      case mrndTimeout of-        Just rndT -> do-          bagAfter <- getsState $ getCBag toC-          let afterIt = case iid `EM.lookup` bagAfter of-                Nothing -> assert `failure` (iid, bagAfter, toC)-                Just (_, it2) -> it2-              resetIt = beforeIt ++ replicate k rndT-          when (afterIt /= resetIt) $-            execUpdAtomic $ UpdTimeItem iid toC afterIt resetIt-        Nothing -> return ()  -- no Periodic or Timeout aspect; don't touch--computeRndTimeout :: Time -> DiscoveryEffect -> ItemId -> Rnd (Maybe Time)-computeRndTimeout localTime discoEffect iid = do-  let timeoutAspect :: IK.Aspect Int -> Maybe Int-      timeoutAspect (IK.Timeout t) = Just t-      timeoutAspect _ = Nothing-  case EM.lookup iid discoEffect of-    Just ItemAspectEffect{jaspects} ->-      case mapMaybe timeoutAspect jaspects of-        [t] | IK.Periodic `elem` jaspects -> do-          rndT <- randomR (0, t)-          let rndTurns = timeDeltaScale (Delta timeTurn) rndT-          return $ Just $ timeShift localTime rndTurns-        _ -> return Nothing-    _ -> assert `failure` (iid, discoEffect)---- * ReqProject--reqProject :: (MonadAtomic m, MonadServer m)-           => ActorId    -- ^ actor projecting the item (is on current lvl)-           -> Point      -- ^ target position of the projectile-           -> Int        -- ^ digital line parameter-           -> ItemId     -- ^ the item to be projected-           -> CStore     -- ^ whether the items comes from floor or inventory-           -> m ()-reqProject source tpxy eps iid cstore = do-  let req = ReqProject tpxy eps iid cstore-  b <- getsState $ getActorBody source-  activeItems <- activeItemsServer source-  let calmE = calmEnough b activeItems-  if cstore == CSha && not calmE then execFailure source req ItemNotCalm-  else do-    mfail <- projectFail source tpxy eps iid cstore False-    maybe (return ()) (execFailure source req) mfail---- * ReqApply--reqApply :: (MonadAtomic m, MonadServer m)-         => ActorId  -- ^ actor applying the item (is on current level)-         -> ItemId   -- ^ the item to be applied-         -> CStore   -- ^ the location of the item-         -> m ()-reqApply aid iid cstore = do-  let req = ReqApply iid cstore-  b <- getsState $ getActorBody aid-  activeItems <- activeItemsServer aid-  let calmE = calmEnough b activeItems-  if cstore == CSha && not calmE then execFailure aid req ItemNotCalm-  else do-    bag <- getsState $ getActorBag aid cstore-    case EM.lookup iid bag of-      Nothing -> execFailure aid req ApplyOutOfReach-      Just kit -> do-        itemToF <- itemToFullServer-        actorSk <- actorSkillsServer aid-        localTime <- getsState $ getLocalTime (blid b)-        let skill = EM.findWithDefault 0 Ability.AbApply actorSk-            itemFull = itemToF iid kit-            legal = permittedApply " " localTime skill itemFull b activeItems-        case legal of-          Left reqFail -> execFailure aid req reqFail-          Right _ -> applyItem aid iid cstore---- * ReqTrigger---- | Perform the effect specified for the tile in case it's triggered.-reqTrigger :: (MonadAtomic m, MonadServer m)-           => ActorId -> Maybe TK.Feature -> m ()-reqTrigger aid mfeat = do-  Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops-  sb <- getsState $ getActorBody aid-  let lid = blid sb-  lvl <- getLevel lid-  let tpos = bpos sb-      serverTile = lvl `at` tpos-      feats = case mfeat of-        Nothing -> TK.tfeature $ okind serverTile-        Just feat2 | Tile.hasFeature cotile feat2 serverTile -> [feat2]-        Just _ -> []-      req = ReqTrigger mfeat-  go <- triggerEffect aid tpos feats-  unless go $ execFailure aid req TriggerNothing--triggerEffect :: (MonadAtomic m, MonadServer m)-              => ActorId -> Point -> [TK.Feature] -> m Bool-triggerEffect aid tpos feats = do-  let triggerFeat feat =-        case feat of-          TK.Cause ef -> itemEffectCause aid tpos ef-          _ -> return False-  goes <- mapM triggerFeat feats-  return $! or goes---- * ReqGameRestart---- TODO: implement a handshake and send hero names there,--- so that they are available in the first game too,--- not only in subsequent, restarted, games.-reqGameRestart :: (MonadAtomic m, MonadServer m)-               => ActorId -> GroupName ModeKind -> Int -> [(Int, (Text, Text))]-               -> m ()-reqGameRestart aid groupName d configHeroNames = do-  modifyServer $ \ser -> ser {sdebugNxt = (sdebugNxt ser) {scurDiffSer = d}}-  b <- getsState $ getActorBody aid-  let fid = bfid b-  oldSt <- getsState $ gquit . (EM.! fid) . sfactionD-  modifyServer $ \ser ->-    ser { squit = True  -- do this at once-        , sheroNames = EM.insert fid configHeroNames $ sheroNames ser }-  revealItems Nothing Nothing-  execUpdAtomic $ UpdQuitFaction fid (Just b) oldSt-                $ Just $ Status Restart (fromEnum $ blid b) (Just groupName)---- * ReqGameExit--reqGameExit :: (MonadAtomic m, MonadServer m) => ActorId -> m ()-reqGameExit aid  = do-  b <- getsState $ getActorBody aid-  let fid = bfid b-  oldSt <- getsState $ gquit . (EM.! fid) . sfactionD-  modifyServer $ \ser -> ser {swriteSave = True}-  modifyServer $ \ser -> ser {squit = True}  -- do this at once-  execUpdAtomic $ UpdQuitFaction fid (Just b) oldSt-                $ Just $ Status Camping (fromEnum $ blid b) Nothing---- * ReqGameSave--reqGameSave :: MonadServer m => m ()-reqGameSave = do-  modifyServer $ \ser -> ser {swriteSave = True}-  modifyServer $ \ser -> ser {squit = True}  -- do this at once---- * ReqTactic--reqTactic :: (MonadAtomic m, MonadServer m) => FactionId -> Tactic -> m ()-reqTactic fid toT = do-  fromT <- getsState $ ftactic . gplayer . (EM.! fid) . sfactionD-  execUpdAtomic $ UpdTacticFaction fid toT fromT---- * ReqAutomate--reqAutomate :: (MonadAtomic m, MonadServer m) => FactionId -> m ()-reqAutomate fid = execUpdAtomic $ UpdAutoFaction fid True

+ Game/LambdaHack/Server/ItemM.hs view

@@ -0,0 +1,182 @@+-- | Server operations for items.+module Game.LambdaHack.Server.ItemM+  ( rollItem, rollAndRegisterItem, registerItem+  , placeItemsInDungeon, embedItemsInDungeon, fullAssocsServer+  , itemToFullServer, mapActorCStore_+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import Data.Function+import qualified Data.HashMap.Strict as HM+import Data.Ord++import Game.LambdaHack.Atomic+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Content.ItemKind as IK+import Game.LambdaHack.Content.TileKind (TileKind)+import Game.LambdaHack.Server.ItemRev+import Game.LambdaHack.Server.MonadServer+import Game.LambdaHack.Server.State++onlyRegisterItem :: (MonadAtomic m, MonadServer m)+                 => ItemKnown -> ItemSeed -> m ItemId+onlyRegisterItem itemKnown@(_, aspectRecord, _, _) seed = do+  itemRev <- getsServer sitemRev+  case HM.lookup itemKnown itemRev of+    Just iid -> return iid+    Nothing -> do+      icounter <- getsServer sicounter+      modifyServer $ \ser ->+        ser { sdiscoAspect = EM.insert icounter aspectRecord (sdiscoAspect ser)+            , sitemSeedD = EM.insert icounter seed (sitemSeedD ser)+            , sitemRev = HM.insert itemKnown icounter (sitemRev ser)+            , sicounter = succ icounter }+      return $! icounter++registerItem :: (MonadAtomic m, MonadServer m)+             => ItemFull -> ItemKnown -> ItemSeed -> Container -> Bool+             -> m ItemId+registerItem ItemFull{..} itemKnown seed container verbose = do+  iid <- onlyRegisterItem itemKnown seed+  let cmd = if verbose then UpdCreateItem else UpdSpotItem False+  execUpdAtomic $ cmd iid itemBase (itemK, itemTimer) container+  knowItems <- getsServer $ sknowItems . sdebugSer+  when knowItems $ case container of+    CTrunk{} -> return ()+    _ -> do+      let ItemDisco{itemKindId} = fromJust itemDisco+      execUpdAtomic $ UpdDiscover container iid itemKindId seed+  return iid++createLevelItem :: (MonadAtomic m, MonadServer m) => Point -> LevelId -> m ()+createLevelItem pos lid = do+  Level{litemFreq} <- getLevel lid+  let container = CFloor lid pos+  void $ rollAndRegisterItem lid litemFreq container True Nothing++embedItem :: (MonadAtomic m, MonadServer m)+          => LevelId -> Point -> Kind.Id TileKind -> m ()+embedItem lid pos tk = do+  Kind.COps{cotile} <- getsState scops+  let embeds = Tile.embeddedItems cotile tk+      container = CEmbed lid pos+      f grp = rollAndRegisterItem lid [(grp, 1)] container False Nothing+  mapM_ f embeds++rollItem :: (MonadAtomic m, MonadServer m)+         => Int -> LevelId -> Freqs ItemKind+         -> m (Maybe ( ItemKnown, ItemFull, ItemDisco+                     , ItemSeed, GroupName ItemKind ))+rollItem lvlSpawned lid itemFreq = do+  cops <- getsState scops+  flavour <- getsServer sflavour+  disco <- getsServer sdiscoKind+  discoRev <- getsServer sdiscoKindRev+  uniqueSet <- getsServer suniqueSet+  totalDepth <- getsState stotalDepth+  Level{ldepth} <- getLevel lid+  m5 <- rndToAction $ newItem cops flavour disco discoRev uniqueSet+                              itemFreq lvlSpawned lid ldepth totalDepth+  case m5 of+    Just (_, _, ItemDisco{itemKindId, itemKind}, _, _) ->+      when (IK.Unique `elem` IK.ieffects itemKind) $+        modifyServer $ \ser ->+          ser {suniqueSet = ES.insert itemKindId (suniqueSet ser)}+    _ -> return ()+  return m5++rollAndRegisterItem :: (MonadAtomic m, MonadServer m)+                    => LevelId -> Freqs ItemKind -> Container -> Bool+                    -> Maybe Int+                    -> m (Maybe (ItemId, (ItemFull, GroupName ItemKind)))+rollAndRegisterItem lid itemFreq container verbose mk = do+  -- Power depth of new items unaffected by number of spawned actors.+  m5 <- rollItem 0 lid itemFreq+  case m5 of+    Nothing -> return Nothing+    Just (itemKnown, itemFullRaw, _, seed, itemGroup) -> do+      let itemFull = itemFullRaw { itemK = fromMaybe (itemK itemFullRaw) mk+                                 , itemBase = itemBase itemFullRaw }+      iid <- registerItem itemFull itemKnown seed container verbose+      return $ Just (iid, (itemFull, itemGroup))++placeItemsInDungeon :: forall m. (MonadAtomic m, MonadServer m) => m ()+placeItemsInDungeon = do+  Kind.COps{coTileSpeedup} <- getsState scops+  let initialItems (lid, Level{ltile, litemNum, lxsize, lysize}) = do+        let placeItems :: Int -> m ()+            placeItems 0 = return ()+            placeItems !n = do+              Level{lfloor} <- getLevel lid+              -- We ensure that there are no big regions without items at all.+              let dist !p _ =+                    let f !k _ b = chessDist p k > 8 && b+                    in EM.foldrWithKey f True lfloor+                  notM !p _ = p `EM.notMember` lfloor+              pos <- rndToAction $ findPosTry2 100 ltile+                (\_ !t -> Tile.isWalkable coTileSpeedup t+                          && not (Tile.isNoItem coTileSpeedup t))+                -- If there are very many items, some regions may be very rich.+                ([dist | n * 100 < lxsize * lysize] ++ [notM])+                (\_ !t -> Tile.isOftenItem coTileSpeedup t)+                [notM]+              createLevelItem pos lid+              placeItems (n - 1)+        placeItems litemNum+  dungeon <- getsState sdungeon+  -- Make sure items on easy levels are generated first, to avoid all+  -- artifacts on deep levels.+  let absLid = abs . fromEnum+      fromEasyToHard = sortBy (comparing absLid `on` fst) $ EM.assocs dungeon+  mapM_ initialItems fromEasyToHard++embedItemsInDungeon :: (MonadAtomic m, MonadServer m) => m ()+embedItemsInDungeon = do+  let embedItems (lid, Level{ltile}) = PointArray.imapMA_ (embedItem lid) ltile+  dungeon <- getsState sdungeon+  -- Make sure items on easy levels are generated first, to avoid all+  -- artifacts on deep levels.+  let absLid = abs . fromEnum+      fromEasyToHard = sortBy (comparing absLid `on` fst) $ EM.assocs dungeon+  mapM_ embedItems fromEasyToHard++fullAssocsServer :: MonadServer m+                 => ActorId -> [CStore] -> m [(ItemId, ItemFull)]+fullAssocsServer aid cstores = do+  cops <- getsState scops+  discoKind <- getsServer sdiscoKind+  discoAspect <- getsServer sdiscoAspect+  getsState $ fullAssocs cops discoKind discoAspect aid cstores++itemToFullServer :: MonadServer m => m (ItemId -> ItemQuant -> ItemFull)+itemToFullServer = do+  cops <- getsState scops+  discoKind <- getsServer sdiscoKind+  discoAspect <- getsServer sdiscoAspect+  s <- getState+  let itemToF iid =+        itemToFull cops discoKind discoAspect iid (getItemBody iid s)+  return itemToF++-- | Mapping over actor's items from a give store.+mapActorCStore_ :: MonadServer m+                => CStore -> (ItemId -> ItemQuant -> m a) -> Actor ->  m ()+mapActorCStore_ cstore f b = do+  bag <- getsState $ getBodyStoreBag b cstore+  mapM_ (uncurry f) $ EM.assocs bag

Game/LambdaHack/Server/ItemRev.hs view

@@ -2,31 +2,31 @@ -- | Server types and operations for items that don't involve server state -- nor our custom monads. module Game.LambdaHack.Server.ItemRev-  ( ItemRev, buildItem, newItem, UniqueSet+  ( ItemKnown, ItemRev, buildItem, newItem, UniqueSet     -- * Item discovery types   , DiscoveryKindRev, serverDiscos, ItemSeedDict     -- * The @FlavourMap@ type   , FlavourMap, emptyFlavourMap, dungeonFlavourMap   ) where -import Control.Applicative-import Control.Exception.Assert.Sugar-import Control.Monad+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.HashMap.Strict as HM-import qualified Data.Ix as Ix-import Data.List import qualified Data.Set as S +import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.Frequency import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK @@ -39,28 +39,30 @@ type UniqueSet = ES.EnumSet (Kind.Id ItemKind)  serverDiscos :: Kind.COps -> Rnd (DiscoveryKind, DiscoveryKindRev)-serverDiscos Kind.COps{coitem=Kind.Ops{obounds, ofoldrWithKey}} = do-  let ixs = map toEnum $ take (Ix.rangeSize obounds) [0..]+serverDiscos Kind.COps{coitem=Kind.Ops{olength, ofoldlWithKey', okind}} = do+  let ixs = [toEnum 0..toEnum (olength-1)]       shuffle :: Eq a => [a] -> Rnd [a]       shuffle [] = return []       shuffle l = do         x <- oneOf l         (x :) <$> shuffle (delete x l)   shuffled <- shuffle ixs-  let f ik _ (ikMap, ikRev, ix : rest) =-        (EM.insert ix ik ikMap, EM.insert ik ix ikRev, rest)-      f ik  _ (ikMap, _, []) =+  let f (!ikMap, !ikRev, ix : rest) kmKind _ =+        let kmMean = meanAspect $ okind kmKind+        in (EM.insert ix KindMean{..} ikMap, EM.insert kmKind ix ikRev, rest)+      f (ikMap, _, []) ik  _ =         assert `failure` "too short ixs" `twith` (ik, ikMap)       (discoS, discoRev, _) =-        ofoldrWithKey f (EM.empty, EM.empty, shuffled)+        ofoldlWithKey' f (EM.empty, EM.empty, shuffled)   return (discoS, discoRev)  -- | Build an item with the given stats. buildItem :: FlavourMap -> DiscoveryKindRev -> Kind.Id ItemKind -> ItemKind-          -> LevelId+          -> LevelId -> Dice.Dice           -> Item-buildItem (FlavourMap flavour) discoRev ikChosen kind jlid =+buildItem (FlavourMap flavour) discoRev ikChosen kind jlid jdamage =   let jkindIx  = discoRev EM.! ikChosen+      jfid     = Nothing  -- the default       jsymbol  = IK.isymbol kind       jname    = IK.iname kind       jflavour =@@ -72,12 +74,13 @@   in Item{..}  -- | Generate an item based on level.-newItem :: Kind.COps -> FlavourMap -> DiscoveryKindRev -> UniqueSet+newItem :: Kind.COps -> FlavourMap+        -> DiscoveryKind -> DiscoveryKindRev -> UniqueSet         -> Freqs ItemKind -> Int -> LevelId -> AbsDepth -> AbsDepth         -> Rnd (Maybe ( ItemKnown, ItemFull, ItemDisco                       , ItemSeed, GroupName ItemKind ))-newItem Kind.COps{coitem=Kind.Ops{ofoldrGroup}}-        flavour discoRev uniqueSet itemFreq lvlSpawned jlid+newItem Kind.COps{coitem=Kind.Ops{ofoldlGroup'}}+        flavour disco discoRev uniqueSet itemFreq lvlSpawned lid         ldepth@(AbsDepth ldAbs) totalDepth@(AbsDepth depth) = do   -- Effective generation depth of actors (not items) increases with spawns.   let scaledDepth = ldAbs * 10 `div` depth@@ -86,11 +89,11 @@                   $ min depth                   $ ldAbs + numSpawnedCoeff - scaledDepth       findInterval _ x1y1 [] = (x1y1, (11, 0))-      findInterval ld x1y1 ((x, y) : rest) =+      findInterval !ld !x1y1 ((!x, !y) : rest) =         if fromIntegral ld * 10 <= x * fromIntegral depth         then (x1y1, (x, y))         else findInterval ld (x, y) rest-      linearInterpolation ld dataset =+      linearInterpolation !ld !dataset =         -- We assume @dataset@ is sorted and between 0 and 10.         let ((x1, y1), (x2, y2)) = findInterval ld (0, 0) dataset         in ceiling@@ -98,13 +101,13 @@              + fromIntegral (y2 - y1)                * (fromIntegral ld * 10 - x1 * fromIntegral depth)                / ((x2 - x1) * fromIntegral depth)-      f _ _ _ ik _ acc | ik `ES.member` uniqueSet = acc-      f itemGroup q p ik kind acc =+      f _ _ acc _ ik _ | ik `ES.member` uniqueSet = acc+      f !itemGroup !q !acc !p !ik !kind =         -- Don't consider lvlSpawned for uniques.-        let ld = if IK.Unique `elem` IK.iaspects kind then ldAbs else ldSpawned+        let ld = if IK.Unique `elem` IK.ieffects kind then ldAbs else ldSpawned             rarity = linearInterpolation ld (IK.irarity kind)         in (q * p * rarity, ((ik, kind), itemGroup)) : acc-      g (itemGroup, q) = ofoldrGroup itemGroup (f itemGroup q) []+      g (itemGroup, q) = ofoldlGroup' itemGroup (f itemGroup q) []       freqDepth = concatMap g itemFreq       freq = toFreq ("newItem ('" <> tshow ldSpawned <> ")") freqDepth   if nullFreq freq then return Nothing@@ -112,16 +115,22 @@     ((itemKindId, itemKind), itemGroup) <- frequency freq     -- Number of new items/actors unaffected by number of spawned actors.     itemN <- castDice ldepth totalDepth (IK.icount itemKind)-    seed <- fmap toEnum random-    let itemBase = buildItem flavour discoRev itemKindId itemKind jlid+    seed <- toEnum <$> random+    jdamage <- frequency $ toFreq "jdamage" $ IK.idamage itemKind+    let itemBase = buildItem flavour discoRev itemKindId itemKind lid jdamage+        kindIx = jkindIx itemBase         itemK = max 1 itemN-        itemTimer = []-        itemDiscoData = ItemDisco {itemKindId, itemKind, itemAE = Just iae}+        itemTimer = [timeZero | IK.Periodic `elem` IK.ieffects itemKind]+                      -- delay first discharge of single organs+        itemAspectMean = kmMean $ EM.findWithDefault (assert `failure` kindIx)+                                                     kindIx disco+        itemDiscoData = ItemDisco { itemKindId, itemKind, itemAspectMean+                                  , itemAspect = Just aspectRecord }         itemDisco = Just itemDiscoData         -- Bonuses on items/actors unaffected by number of spawned actors.-        iae = seedToAspectsEffects seed itemKind ldepth totalDepth+        aspectRecord = seedToAspect seed itemKind ldepth totalDepth         itemFull = ItemFull {..}-    return $ Just ( (jkindIx itemBase, iae)+    return $ Just ( (kindIx, aspectRecord, jdamage, jfid itemBase)                   , itemFull                   , itemDiscoData                   , seed@@ -136,35 +145,48 @@  -- | Assigns flavours to item kinds. Assures no flavor is repeated for the same -- symbol, except for items with only one permitted flavour.-rollFlavourMap :: S.Set Flavour -> Kind.Id ItemKind -> ItemKind+rollFlavourMap :: S.Set Flavour                -> Rnd ( EM.EnumMap (Kind.Id ItemKind) Flavour                       , EM.EnumMap Char (S.Set Flavour) )+               -> Kind.Id ItemKind -> ItemKind                -> Rnd ( EM.EnumMap (Kind.Id ItemKind) Flavour                       , EM.EnumMap Char (S.Set Flavour) )-rollFlavourMap fullFlavSet key ik rnd =+rollFlavourMap fullFlavSet rnd key ik =   let flavours = IK.iflavour ik   in if length flavours == 1      then rnd      else do-       (assocs, availableMap) <- rnd+       (!assocs, !availableMap) <- rnd        let available =              EM.findWithDefault fullFlavSet (IK.isymbol ik) availableMap            proper = S.fromList flavours `S.intersection` available        assert (not (S.null proper)                `blame` "not enough flavours for items"                `twith` (flavours, available, ik, availableMap)) $ do-         flavour <- oneOf (S.toList proper)+         flavour <- oneOf $ S.toList proper          let availableReduced = S.delete flavour available          return ( EM.insert key flavour assocs                 , EM.insert (IK.isymbol ik) availableReduced availableMap)  -- | Randomly chooses flavour for all item kinds for this game. dungeonFlavourMap :: Kind.COps -> Rnd FlavourMap-dungeonFlavourMap Kind.COps{coitem=Kind.Ops{ofoldrWithKey}} =+dungeonFlavourMap Kind.COps{coitem=Kind.Ops{ofoldlWithKey'}} =   liftM (FlavourMap . fst) $-    ofoldrWithKey (rollFlavourMap (S.fromList stdFlav))-                  (return (EM.empty, EM.empty))+    ofoldlWithKey' (rollFlavourMap (S.fromList stdFlav))+                   (return (EM.empty, EM.empty))  -- | Reverse item map, for item creation, to keep items and item identifiers -- in bijection. type ItemRev = HM.HashMap ItemKnown ItemId++-- | The essential item properties, used for the @ItemRev@ hash table+-- from items to their ids, needed to assign ids to newly generated items.+-- All the other meaningul properties can be derived from them.+-- Note 1: @jlid@ is not meaningful; it gets forgotten if items from+-- different levels roll the same random properties and so are merged.+-- However, the first item generated by the server wins, which is most+-- of the time the lower @jlid@ item, which makes sense for the client.+-- Note 2: @ItemSeed@ instead of @AspectRecord@ is not enough,+-- becaused different seeds may result in the same @AspectRecord@+-- and we don't want such items to be distinct in UI and elsewhere.+type ItemKnown = (ItemKindIx, AspectRecord, Dice.Dice, Maybe FactionId)

− Game/LambdaHack/Server/ItemServer.hs

@@ -1,213 +0,0 @@--- | Server operations for items.-module Game.LambdaHack.Server.ItemServer-  ( rollItem, rollAndRegisterItem, registerItem-  , placeItemsInDungeon, embedItemsInDungeon, fullAssocsServer-  , activeItemsServer, itemToFullServer, mapActorCStore_-  ) where--import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Function-import qualified Data.HashMap.Strict as HM-import Data.List-import Data.Maybe-import Data.Ord-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Atomic-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Content.ItemKind (ItemKind)-import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.TileKind (TileKind)-import qualified Game.LambdaHack.Content.TileKind as TK-import Game.LambdaHack.Server.ItemRev-import Game.LambdaHack.Server.MonadServer-import Game.LambdaHack.Server.State--registerItem :: (MonadAtomic m, MonadServer m)-             => ItemFull -> ItemKnown -> ItemSeed -> Int -> Container -> Bool-             -> m ItemId-registerItem itemFull itemKnown@(_, iae) seed k container verbose = do-  itemRev <- getsServer sitemRev-  let cmd = if verbose then UpdCreateItem else UpdSpotItem-  case HM.lookup itemKnown itemRev of-    Just iid -> do-      -- TODO: try to avoid this case for createItems,-      -- to make items more interesting-      execUpdAtomic $ cmd iid (itemBase itemFull) (k, []) container-      return iid-    Nothing -> do-      let fovSight = fromMaybe 0-                     $ strengthFromEqpSlot IK.EqpSlotAddSight itemFull-          fovSmell = fromMaybe 0-                     $ strengthFromEqpSlot IK.EqpSlotAddSmell itemFull-          fovLight = fromMaybe 0-                     $ strengthFromEqpSlot IK.EqpSlotAddLight itemFull-          ssl = FovCache3{..}-      icounter <- getsServer sicounter-      modifyServer $ \ser ->-        ser { sdiscoEffect = EM.insert icounter iae (sdiscoEffect ser)-            , sitemSeedD = EM.insert icounter seed (sitemSeedD ser)-            , sitemRev = HM.insert itemKnown icounter (sitemRev ser)-            , sItemFovCache = if ssl == emptyFovCache3 then sItemFovCache ser-                              else EM.insert icounter ssl (sItemFovCache ser)-            , sicounter = succ icounter }-      execUpdAtomic $ cmd icounter (itemBase itemFull) (k, []) container-      return $! icounter--createLevelItem :: (MonadAtomic m, MonadServer m)-                => Point -> LevelId -> m ()-createLevelItem pos lid = do-  Level{litemFreq} <- getLevel lid-  let container = CFloor lid pos-  void $ rollAndRegisterItem lid litemFreq container True Nothing--embedItem :: (MonadAtomic m, MonadServer m)-          => LevelId -> Point -> Kind.Id TileKind -> m ()-embedItem lid pos tk = do-  Kind.COps{cotile} <- getsState scops-  let embeds = Tile.embedItems cotile tk-      causes = Tile.causeEffects cotile tk-      -- TODO: unhack this, e.g., by turning each Cause into Embed-      itemFreq = zip embeds (repeat 1)-                 ++ -- Hack: the bag, not item, is relevant.-                    [("hero", 1) |  not (null causes) && null embeds]-      container = CEmbed lid pos-  void $ rollAndRegisterItem lid itemFreq container False Nothing--rollItem :: (MonadAtomic m, MonadServer m)-         => Int -> LevelId -> Freqs ItemKind-         -> m (Maybe ( ItemKnown, ItemFull, ItemDisco-                     , ItemSeed, GroupName ItemKind ))-rollItem lvlSpawned lid itemFreq = do-  cops <- getsState scops-  flavour <- getsServer sflavour-  discoRev <- getsServer sdiscoKindRev-  uniqueSet <- getsServer suniqueSet-  totalDepth <- getsState stotalDepth-  Level{ldepth} <- getLevel lid-  m5 <- rndToAction $ newItem cops flavour discoRev uniqueSet-                              itemFreq lvlSpawned lid ldepth totalDepth-  case m5 of-    Just (_, _, ItemDisco{ itemKindId-                         , itemAE=Just ItemAspectEffect{jaspects}}, _, _) ->-      when (IK.Unique `elem` jaspects) $-        modifyServer $ \ser ->-          ser {suniqueSet = ES.insert itemKindId (suniqueSet ser)}-    _ -> return ()-  return m5--rollAndRegisterItem :: (MonadAtomic m, MonadServer m)-                    => LevelId -> Freqs ItemKind -> Container -> Bool-                    -> Maybe Int-                    -> m (Maybe (ItemId, (ItemFull, GroupName ItemKind)))-rollAndRegisterItem lid itemFreq container verbose mk = do-  -- Power depth of new items unaffected by number of spawned actors.-  m5 <- rollItem 0 lid itemFreq-  case m5 of-    Nothing -> return Nothing-    Just (itemKnown, itemFullRaw, itemDisco, seed, itemGroup) -> do-      let item = itemBase itemFullRaw-          trunkName = makePhrase [MU.WownW (MU.Text $ jname item) "trunk"]-          itemTrunk = if null $ IK.ikit $ itemKind itemDisco-                      then item-                      else item {jname = trunkName}-          itemFull = itemFullRaw { itemK = fromMaybe (itemK itemFullRaw) mk-                                 , itemBase = itemTrunk }-      iid <- registerItem itemFull itemKnown seed-                          (itemK itemFull) container verbose-      return $ Just (iid, (itemFull, itemGroup))--placeItemsInDungeon :: forall m. (MonadAtomic m, MonadServer m) => m ()-placeItemsInDungeon = do-  Kind.COps{cotile} <- getsState scops-  let initialItems (lid, Level{lfloor, ltile, litemNum, lxsize, lysize}) = do-        let factionDist = max lxsize lysize - 5-            placeItems :: [Point] -> Int -> m ()-            placeItems _ 0 = return ()-            placeItems lfloorKeys n = do-              let dist p = minimum $ maxBound : map (chessDist p) lfloorKeys-              pos <- rndToAction $ findPosTry 500 ltile-                   (\_ t -> Tile.isWalkable cotile t-                            && not (Tile.hasFeature cotile TK.NoItem t))-                   [ \p t -> Tile.hasFeature cotile TK.OftenItem t-                             && dist p > factionDist `div` 5-                   , \p t -> Tile.hasFeature cotile TK.OftenItem t-                             && dist p > factionDist `div` 7-                   , \p t -> Tile.hasFeature cotile TK.OftenItem t-                             && dist p > factionDist `div` 9-                   , \p t -> Tile.hasFeature cotile TK.OftenItem t-                             && dist p > factionDist `div` 12-                   , \p _ -> dist p > factionDist `div` 5-                   , \p t -> Tile.hasFeature cotile TK.OftenItem t-                             || dist p > factionDist `div` 7-                   , \p t -> Tile.hasFeature cotile TK.OftenItem t-                             || dist p > factionDist `div` 9-                   , \p t -> Tile.hasFeature cotile TK.OftenItem t-                             || dist p > factionDist `div` 12-                   , \p _ -> dist p > 1-                   , \p _ -> dist p > 0-                   ]-              createLevelItem pos lid-              placeItems (pos : lfloorKeys) (n - 1)-        placeItems (EM.keys lfloor) litemNum-  dungeon <- getsState sdungeon-  -- Make sure items on easy levels are generated first, to avoid all-  -- artifacts on deep levels.-  let absLid = abs . fromEnum-      fromEasyToHard = sortBy (comparing absLid `on` fst) $ EM.assocs dungeon-  mapM_ initialItems fromEasyToHard--embedItemsInDungeon :: (MonadAtomic m, MonadServer m) => m ()-embedItemsInDungeon = do-  let embedItems (lid, Level{ltile}) =-        PointArray.mapWithKeyMA (embedItem lid) ltile-  dungeon <- getsState sdungeon-  -- Make sure items on easy levels are generated first, to avoid all-  -- artifacts on deep levels.-  let absLid = abs . fromEnum-      fromEasyToHard = sortBy (comparing absLid `on` fst) $ EM.assocs dungeon-  mapM_ embedItems fromEasyToHard--fullAssocsServer :: MonadServer m-                 => ActorId -> [CStore] -> m [(ItemId, ItemFull)]-fullAssocsServer aid cstores = do-  cops <- getsState scops-  discoKind <- getsServer sdiscoKind-  discoEffect <- getsServer sdiscoEffect-  getsState $ fullAssocs cops discoKind discoEffect aid cstores--activeItemsServer :: MonadServer m => ActorId -> m [ItemFull]-activeItemsServer aid = do-  activeAssocs <- fullAssocsServer aid [CEqp, COrgan]-  return $! map snd activeAssocs--itemToFullServer :: MonadServer m => m (ItemId -> ItemQuant -> ItemFull)-itemToFullServer = do-  cops <- getsState scops-  discoKind <- getsServer sdiscoKind-  discoEffect <- getsServer sdiscoEffect-  s <- getState-  let itemToF iid =-        itemToFull cops discoKind discoEffect iid (getItemBody iid s)-  return itemToF---- | Mapping over actor's items from a give store.-mapActorCStore_ :: MonadServer m-                => CStore -> (ItemId -> ItemQuant -> m a) -> Actor ->  m ()-mapActorCStore_ cstore f b = do-  bag <- getsState $ getBodyActorBag b cstore-  mapM_ (uncurry f) $ EM.assocs bag

+ Game/LambdaHack/Server/LoopM.hs view

@@ -0,0 +1,513 @@+{-# LANGUAGE GADTs #-}+-- | The main loop of the server, processing human and computer player+-- moves turn by turn.+module Game.LambdaHack.Server.LoopM+  ( loopSer+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , factionArena, arenasForLoop, handleFidUpd, loopUpd, endClip+  , applyPeriodicLevel+  , handleTrajectories, hTrajectories, handleActors, hActors+  , gameExit, restartGame, writeSaveAll, setTrajectory+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.Ord as Ord++import Game.LambdaHack.Atomic+import Game.LambdaHack.Client.UI (Config, SessionUI)+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.ClientOptions+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import Game.LambdaHack.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.Request+import Game.LambdaHack.Common.Response+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Vector+import qualified Game.LambdaHack.Content.ItemKind as IK+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Server.EndM+import Game.LambdaHack.Server.Fov+import Game.LambdaHack.Server.HandleEffectM+import Game.LambdaHack.Server.HandleRequestM+import Game.LambdaHack.Server.ItemM+import Game.LambdaHack.Server.MonadServer+import Game.LambdaHack.Server.PeriodicM+import Game.LambdaHack.Server.ProtocolM+import Game.LambdaHack.Server.StartM+import Game.LambdaHack.Server.State++-- | Start a game session, including the clients, and then loop,+-- communicating with the clients.+loopSer :: (MonadAtomic m, MonadServerReadRequest m)+        => DebugModeSer  -- ^ server debug parameters+        -> Config+        -> (Maybe SessionUI -> Kind.COps -> FactionId -> ChanServer -> IO ())+             -- ^ the code to run for UI clients+        -> m ()+loopSer sdebug sconfig executorClient = do+  -- Recover states and launch clients.+  cops <- getsState scops+  let updConn = updateConn cops sconfig executorClient+  restored <- tryRestore cops sdebug+  case restored of+    Just (sRaw, ser) | not $ snewGameSer sdebug -> do  -- a restored game+      execUpdAtomic $ UpdResumeServer $ updateCOps (const cops) sRaw+      putServer ser+      modifyServer $ \ser2 -> ser2 {sdebugNxt = sdebug}+      applyDebug+      updConn+      initPer+      pers <- getsServer sperFid+      factionD <- getsState sfactionD+      mapM_ (\fid -> sendUpdate fid $ UpdResume fid (pers EM.! fid))+            (EM.keys factionD)+      -- We dump RNG seeds here, in case the game wasn't run+      -- with --dumpInitRngs previously and we need the seeds.+      rngs <- getsServer srngs+      when (sdumpInitRngs sdebug) $ dumpRngs rngs+    _ -> do  -- starting new game for this savefile (--newGame or fresh save)+      s <- gameReset cops sdebug Nothing Nothing  -- get RNG from item boost+      -- Set up commandline debug mode.+      let debugBarRngs = sdebug {sdungeonRng = Nothing, smainRng = Nothing}+      modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs+                                 , sdebugSer = debugBarRngs }+      execUpdAtomic $ UpdRestartServer s+      updConn+      initPer+      reinitGame+      writeSaveAll False+  loopUpd updConn++factionArena :: MonadStateRead m => Faction -> m (Maybe LevelId)+factionArena fact = case _gleader fact of+  -- Even spawners need an active arena for their leader,+  -- or they start clogging stairs.+  Just leader -> do+    b <- getsState $ getActorBody leader+    return $ Just $ blid b+  Nothing -> if fleaderMode (gplayer fact) == LeaderNull+                || EM.null (gvictims fact)  -- not in-between spawns+             then return Nothing+             else Just <$> getEntryArena fact++arenasForLoop :: MonadStateRead m => m [LevelId]+{-# INLINE arenasForLoop #-}+arenasForLoop = do+  factionD <- getsState sfactionD+  marenas <- mapM factionArena $ EM.elems factionD+  let arenas = ES.toList $ ES.fromList $ catMaybes marenas+      !_A = assert (not (null arenas)+                    `blame` "game over not caught earlier"+                    `twith` factionD) ()+  return $! arenas++handleFidUpd :: (MonadAtomic m, MonadServerReadRequest m)+             => Bool -> (FactionId -> m ()) -> FactionId -> Faction -> m Bool+{-# INLINE handleFidUpd #-}+handleFidUpd True _ _ _ = return True+handleFidUpd False updatePerFid fid fact = do+  -- Update perception on all levels at once,+  -- in case a leader is changed to actor on another+  -- (possibly not even currently active) level.+  updatePerFid fid+  fa <- factionArena fact+  arenas <- getsServer sarenas+  -- Move a single actor, starting on arena with leader, if available.+  -- The boolean result says if turn was aborted (due to save, restart, etc.).+  -- If the turn was aborted, we have the guarantee game state was not+  -- changed and so we can save without risk of affecting gameplay.+  let handle [] = return False+      handle (lid : rest) = do+        nonWaitMove <- handleActors lid fid+        swriteSave <- getsServer swriteSave+        if | nonWaitMove -> return False+           | swriteSave -> return True+           | otherwise -> handle rest+      myArenas = case fa of+        Just myArena -> myArena : delete myArena arenas+        Nothing -> arenas+  handle myArenas++-- | Handle a clip (a part of a turn for which one or more frames+-- will be generated). Run the leader and other actors moves.+-- Eventually advance the time and repeat.+loopUpd :: forall m. (MonadAtomic m, MonadServerReadRequest m) => m () -> m ()+loopUpd updConn = do+  let updatePerFid :: FactionId -> m ()+      {-# NOINLINE updatePerFid #-}+      updatePerFid fid = do  -- {-# SCC updatePerFid #-} do+        perValid <- getsServer $ (EM.! fid) . sperValidFid+        mapM_ (\(lid, valid) -> unless valid $ updatePer fid lid)+              (EM.assocs perValid)+      handleFid :: Bool -> (FactionId, Faction) -> m Bool+      {-# NOINLINE handleFid #-}+      handleFid aborted (fid, fact) = handleFidUpd aborted updatePerFid fid fact+      loopUpdConn = do+        factionD <- getsState sfactionD+        -- Start handling with the single UI faction, to safely save&exit.+        -- Note that this hack fails if there are many UI factions+        -- (when we reenable multiplayer). Then players will request+        -- save&exit and others will vote on it and it will happen+        -- after the turn has ended, not at the start.+        aborted <- foldM handleFid False (EM.toDescList factionD)+        unless aborted $ do+          -- Projectiles are processed last, so that the UI leader+          -- can save&exit before the state is changed and the turn+          -- needs to be carried through.+          arenas <- getsServer sarenas+          mapM_ (\fid -> mapM_ (`handleTrajectories` fid) arenas)+                (EM.keys factionD)+          endClip updatePerFid  -- must be last, in case performs a bkp save+        quit <- getsServer squit+        if quit then do+          modifyServer $ \ser -> ser {squit = False}+          endOrLoop loopUpdConn (restartGame updConn loopUpdConn)+                    gameExit (writeSaveAll True)+        else+          loopUpdConn+  loopUpdConn++-- | Handle the end of every clip. Do whatever has to be done+-- every fixed number of time units, e.g., monster generation.+-- Advance time. Perform periodic saves, if applicable.+endClip :: forall m. (MonadAtomic m, MonadServer m)+        => (FactionId -> m ()) -> m ()+{-# INLINE endClip #-}+endClip updatePerFid = do+  Kind.COps{corule} <- getsState scops+  let RuleKind{rwriteSaveClips, rleadLevelClips} = Kind.stdRuleset corule+  time <- getsState stime+  let clipN = time `timeFit` timeClip+      clipInTurn = let r = timeTurn `timeFit` timeClip+                   in assert (r >= 5) r+  validArenas <- getsServer svalidArenas+  unless validArenas $ do+    sarenas <- arenasForLoop+    modifyServer $ \ser -> ser {sarenas, svalidArenas = True}+  arenas <- getsServer sarenas+  -- I need to send time updates, because I can't add time to each command,+  -- because I'd need to send also all arenas, which should be updated,+  -- and this is too expensive data for each, e.g., projectile move.+  -- I send even if nothing changes so that UI time display can progress.+  quit <- getsServer squit+  unless quit $ do+    execUpdAtomic $ UpdAgeGame arenas+    -- Perform periodic dungeon maintenance.+    when (clipN `mod` rleadLevelClips == 0) leadLevelSwitch+    case clipN `mod` clipInTurn of+      2 ->+        -- Periodic activation only once per turn, for speed,+        -- but on all active arenas. Calm updates and domination+        -- happen there as well.+        applyPeriodicLevel+      4 ->+        -- Add monsters each turn, not each clip.+        spawnMonster+      _ -> return ()+  -- Update all perception for visual feedback and to make sure+  -- saving a game doesn't affect gameplay (by updating perception).+  factionD <- getsState sfactionD+  mapM_ updatePerFid (EM.keys factionD)+  -- Save needs to be at the end, so that restore can start at the beginning.+  when (clipN `mod` rwriteSaveClips == 0) $ writeSaveAll False++-- | Check if the given actor is dominated and update his calm.+manageCalmAndDomination :: (MonadAtomic m, MonadServer m)+                        => ActorId -> Actor -> m ()+manageCalmAndDomination aid b = do+  Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops+  fact <- getsState $ (EM.! bfid b) . sfactionD+  getItem <- getsState $ flip getItemBody+  discoKind <- getsServer sdiscoKind+  let isImpression iid = case EM.lookup (jkindIx $ getItem iid) discoKind of+        Just KindMean{kmKind} ->+          maybe False (> 0) (lookup "impressed" $ IK.ifreq $ okind kmKind)+        Nothing -> assert `failure` iid+      impressions = EM.filterWithKey (\iid _ -> isImpression iid) $ borgan b+  dominated <-+    if bcalm b == 0+       && not (null impressions)+       && fleaderMode (gplayer fact) /= LeaderNull+            -- animals/robots never Calm-dominated+    then+      let f (_, (k, _)) = k+          maxImpression = maximumBy (Ord.comparing f) $ EM.assocs impressions+      in case jfid $ getItem $ fst maxImpression of+        Nothing -> assert `failure` impressions+        Just fid1 -> assert (fid1 /= bfid b) $ dominateFidSfx fid1 aid+    else return False+  unless dominated $ do+    actorAspect <- getsServer sactorAspect+    let ar = actorAspect EM.! aid+    newCalmDelta <- getsState $ regenCalmDelta b ar+    unless (newCalmDelta == 0) $+      -- Update delta for the current player turn.+      udpateCalm aid newCalmDelta++-- | Trigger periodic items for all actors on the given level.+applyPeriodicLevel :: (MonadAtomic m, MonadServer m) => m ()+applyPeriodicLevel = do+  arenas <- getsServer sarenas+  let arenasSet = ES.fromDistinctAscList arenas+      applyPeriodicItem _ _ _ (_, (_, [])) = return ()+        -- periodic items always have at least one timer+      applyPeriodicItem aid cstore getStore (iid, _) = do+        -- Check if the item is still in the bag (previous items act!).+        bag <- getsState $ getStore . getActorBody aid+        case iid `EM.lookup` bag of+          Nothing -> return ()  -- item dropped+          Just kit -> do+            itemToF <- itemToFullServer+            let itemFull = itemToF iid kit+            case itemDisco itemFull of+              Just ItemDisco {itemKind=IK.ItemKind{IK.ieffects}} ->+                when (IK.Periodic `elem` ieffects) $+                  -- In periodic activation, consider *only* recharging effects.+                  -- Activate even if effects null, to possibly destroy item.+                  effectAndDestroy False aid aid iid (CActor aid cstore) True+                                   (filterRecharging ieffects) itemFull+              _ -> assert `failure` (aid, cstore, iid)+      applyPeriodicActor (aid, b) =+        when (not (bproj b) && blid b `ES.member` arenasSet) $ do+          mapM_ (applyPeriodicItem aid COrgan borgan) $ EM.assocs $ borgan b+          mapM_ (applyPeriodicItem aid CEqp beqp) $ EM.assocs $ beqp b+          -- While we are at it, also update their calm.+          manageCalmAndDomination aid b+  allActors <- getsState sactorD+  mapM_ applyPeriodicActor $ EM.assocs allActors++handleTrajectories :: (MonadAtomic m, MonadServer m)+                   => LevelId -> FactionId -> m ()+handleTrajectories lid fid = do+  localTime <- getsState $ getLocalTime lid+  levelTime <- getsServer $ (EM.! lid) . (EM.! fid) . sactorTime+  s <- getState+  let l = sortBy (Ord.comparing fst)+          $ filter (\(_, (_, b)) -> isJust (btrajectory b) || bhp b <= 0)+          $ map (\(a, atime) -> (atime, (a, getActorBody a s)))+          $ filter (\(_, atime) -> atime <= localTime) $ EM.assocs levelTime+  mapM_ (hTrajectories . snd) l+  unless (null l) $ handleTrajectories lid fid  -- for speeds > tile/clip++-- The body @b@ may be outdated by this time+-- (due to other actors following their trajectories)+-- but we decide death inspecting it --- last moment rescue+-- from projectiles or pushed actors doesn't work; too late.+-- Even if the actor got teleported to another level by this point,+-- we don't care, we set the trajectory, check death, etc.+hTrajectories :: (MonadAtomic m, MonadServer m) => (ActorId, Actor) -> m ()+{-# INLINE hTrajectories #-}+hTrajectories (aid, b) = do+  b2 <- if actorDying b then return b else do+          setTrajectory aid+          getsState $ getActorBody aid+  -- @setTrajectory@ might have affected @actorDying@, so we check again ASAP+  -- to make sure the body of the projectile (or pushed actor)+  -- doesn't block movement of other actors, but vanishes promptly.+  -- Bodies of actors that die in place remain on the battlefied until+  -- their natural next turn, to give them a chance of rescue.+  -- Note that domination of pushed actors is not checked+  -- nor is their calm updated. They are helpless wrt movement,+  -- but also invulnerable in this repsect.+  if actorDying b2 then dieSer aid b2 else advanceTime aid 100+  -- if @actorDying@ due to @bhp b <= 0@:+  -- If @b@ is a projectile, it means hits an actor or is hit by actor.+  -- Then the carried item is destroyed and that's all.+  -- If @b@ is not projectile, it dies, his items drop to the ground+  -- and possibly a new leader is elected.+  --+  -- if @actorDying@ due to @btrajectory@ null:+  -- A projectile drops to the ground due to obstacles or range.+  -- The carried item is not destroyed, unless it's fragile,+  -- but drops to the ground.++-- | Manage trajectory of a projectile.+--+-- Colliding with a wall or actor doesn't take time, because+-- the projectile does not move (the move is blocked).+-- Not advancing time forces dead projectiles to be destroyed ASAP.+-- Otherwise, with some timings, it can stay on the game map dead,+-- blocking path of human-controlled actors and alarming the hapless human.+setTrajectory :: (MonadAtomic m, MonadServer m) => ActorId -> m ()+{-# INLINE setTrajectory #-}+setTrajectory aid = do+  Kind.COps{coTileSpeedup} <- getsState scops+  b <- getsState $ getActorBody aid+  lvl <- getLevel $ blid b+  case btrajectory b of+    Just (d : lv, speed) ->+      if Tile.isWalkable coTileSpeedup $ lvl `at` (bpos b `shift` d)+      then do+        -- Hit clears trajectory of non-projectiles in reqMelee so no need here.+        -- Non-projectiles displace, to make pushing in crowds less lethal+        -- and chaotic and to avoid hitting harpoons when pulled by them.+        let tpos = bpos b `shift` d  -- target position+        case posToAidsLvl tpos lvl of+          [target] | not (bproj b) -> reqDisplace aid target+          _ -> reqMove aid d+        b2 <- getsState $ getActorBody aid+        unless ((fst <$> btrajectory b2) == Just []) $  -- set in reqMelee+          execUpdAtomic $ UpdTrajectory aid (btrajectory b2) (Just (lv, speed))+      else do+        -- Nothing from non-empty trajectories signifies obstacle hit.+        execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing+        -- Lose HP due to flying into an obstacle.+        execUpdAtomic $ UpdRefillHP aid minusM+    Just ([], _) ->+      -- Non-projectile actor stops flying.+      assert (not $ bproj b)+      $ execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing+    _ -> assert `failure` "Nothing trajectory" `twith` (aid, b)++handleActors :: (MonadAtomic m, MonadServerReadRequest m)+             => LevelId -> FactionId -> m Bool+handleActors lid fid = do+  localTime <- getsState $ getLocalTime lid+  levelTime <- getsServer $ (EM.! lid) . (EM.! fid) . sactorTime+  factionD <- getsState sfactionD+  s <- getState+  -- Leader acts first, so that UI leader can save&exit before state changes.+  let notLeader (aid, b) = Just aid /= _gleader (factionD EM.! bfid b)+      l = sortBy (Ord.comparing notLeader)+          $ filter (\(_, b) -> isNothing (btrajectory b) && bhp b > 0)+          $ map (\(a, _) -> (a, getActorBody a s))+          $ filter (\(_, atime) -> atime <= localTime) $ EM.assocs levelTime+  hActors fid l++hActors :: forall m. (MonadAtomic m, MonadServerReadRequest m)+        => FactionId -> [(ActorId, Actor)] -> m Bool+hActors _ [] = return False+hActors _fid as@((aid, body) : rest) = do+  let side = bfid body+      !_A = assert (side == _fid) ()+  fact <- getsState $ (EM.! side) . sfactionD+  squit <- getsServer squit+  let mleader = _gleader fact+      aidIsLeader = mleader == Just aid+      mainUIactor = fhasUI (gplayer fact)+                    && (aidIsLeader+                        || fleaderMode (gplayer fact) == LeaderNull)+      -- Checking squit, to avoid doubly setting faction status to Camping.+      mainUIunderAI = mainUIactor && isAIFact fact && not squit+      doQueryAI = not mainUIactor || isAIFact fact+  when mainUIunderAI $ do+    cmdS <- sendQueryUI side aid+    case fst cmdS of+      ReqUINop -> return ()+      ReqUIAutomate -> execUpdAtomic $ UpdAutoFaction side False+      ReqUIGameExit -> do+        reqGameExit aid+        -- This is not proper UI-forced save, but a timeout, so don't save+        -- and no need to abort turn.+        modifyServer $ \ser -> ser {swriteSave = False}+      _ -> assert `failure` cmdS+  let mswitchLeader :: Maybe ActorId -> m ActorId+      {-# NOINLINE mswitchLeader #-}+      mswitchLeader (Just aidNew) = switchLeader side aidNew >> return aidNew+      mswitchLeader Nothing = return aid+  (aidNew, mtimed) <-+    if doQueryAI then do+      (cmd, maid) <- sendQueryAI side aid+      aidNew <- mswitchLeader maid+      mtimed <- handleRequestAI cmd+      return (aidNew, mtimed)+    else do+      (cmd, maid) <- sendQueryUI side aid+      aidNew <- mswitchLeader maid+      mtimed <- handleRequestUI side aidNew cmd+      return (aidNew, mtimed)+  case mtimed of+    Just (RequestAnyAbility timed) -> do+      nonWaitMove <- handleRequestTimed side aidNew timed+      if nonWaitMove then return True else hActors side rest+    Nothing -> do+      swriteSave <- getsServer swriteSave+      if swriteSave then return False else hActors side as++gameExit :: (MonadAtomic m, MonadServerReadRequest m) => m ()+gameExit = do+  -- Verify that the not saved caches are equal to future reconstructed.+  -- Otherwise, save/restore would change game state.+--  debugPossiblyPrint "Verifying all perceptions."+  sperCacheFid <- getsServer sperCacheFid+  sperValidFid <- getsServer sperValidFid+  sactorAspect <- getsServer sactorAspect+  sfovLucidLid <- getsServer sfovLucidLid+  sfovClearLid <- getsServer sfovClearLid+  sfovLitLid <- getsServer sfovLitLid+  sperFid <- getsServer sperFid+  discoAspect <- getsServer sdiscoAspect+  ( actorAspect, fovLitLid, fovClearLid, fovLucidLid+   ,perValidFid, perCacheFid, perFid )+    <- getsState $ perFidInDungeon discoAspect+  let !_A7 = assert (sfovLitLid == fovLitLid+                     `blame` "wrong accumulated sfovLitLid"+                     `twith` (sfovLitLid, fovLitLid)) ()+      !_A6 = assert (sfovClearLid == fovClearLid+                     `blame` "wrong accumulated sfovClearLid"+                     `twith` (sfovClearLid, fovClearLid)) ()+      !_A5 = assert (sactorAspect == actorAspect+                     `blame` "wrong accumulated sactorAspect"+                     `twith` (sactorAspect, actorAspect)) ()+      !_A4 = assert (sfovLucidLid == fovLucidLid+                     `blame` "wrong accumulated sfovLucidLid"+                     `twith` (sfovLucidLid, fovLucidLid)) ()+      !_A3 = assert (sperValidFid == perValidFid+                     `blame` "wrong accumulated sperValidFid"+                     `twith` (sperValidFid, perValidFid)) ()+      !_A2 = assert (sperCacheFid == perCacheFid+                     `blame` "wrong accumulated sperCacheFid"+                     `twith` (sperCacheFid, perCacheFid)) ()+      !_A1 = assert (sperFid == perFid+                     `blame` "wrong accumulated perception"+                     `twith` (sperFid, perFid)) ()+  -- Kill all clients, including those that did not take part+  -- in the current game.+  -- Clients exit not now, but after they print all ending screens.+  -- debugPrint "Server kills clients"+--  debugPossiblyPrint "Killing all clients."+  killAllClients+--  debugPossiblyPrint "All clients killed."+  return ()++restartGame :: (MonadAtomic m, MonadServer m)+            => m () -> m () -> Maybe (GroupName ModeKind) -> m ()+restartGame updConn loop mgameMode = do+  cops <- getsState scops+  sdebugNxt <- getsServer sdebugNxt+  srandom <- getsServer srandom+  s <- gameReset cops sdebugNxt mgameMode (Just srandom)+  let debugBarRngs = sdebugNxt {sdungeonRng = Nothing, smainRng = Nothing}+  modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs+                             , sdebugSer = debugBarRngs }+  execUpdAtomic $ UpdRestartServer s+  updConn+  initPer+  reinitGame+  writeSaveAll False+  loop++-- | Save game on server and all clients.+writeSaveAll :: (MonadAtomic m, MonadServer m) => Bool -> m ()+writeSaveAll uiRequested = do+  bench <- getsServer $ sbenchmark . sdebugCli . sdebugSer+  noConfirmsGame <- isNoConfirmsGame+  when (uiRequested || not bench && not noConfirmsGame) $ do+    execUpdAtomic UpdWriteSave+    saveServer

− Game/LambdaHack/Server/LoopServer.hs

@@ -1,440 +0,0 @@-{-# LANGUAGE GADTs #-}--- | The main loop of the server, processing human and computer player--- moves turn by turn.-module Game.LambdaHack.Server.LoopServer (loopSer) where--import Control.Applicative-import Control.Arrow ((&&&))-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Key (mapWithKeyM_)-import Data.List-import Data.Maybe-import qualified Data.Ord as Ord--import Game.LambdaHack.Atomic-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.ClientOptions-import qualified Game.LambdaHack.Common.Color as Color-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.Random-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.Response-import Game.LambdaHack.Common.State-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.Server.EndServer-import Game.LambdaHack.Server.Fov-import Game.LambdaHack.Server.HandleEffectServer-import Game.LambdaHack.Server.HandleRequestServer-import Game.LambdaHack.Server.MonadServer-import Game.LambdaHack.Server.PeriodicServer-import Game.LambdaHack.Server.ProtocolServer-import Game.LambdaHack.Server.StartServer-import Game.LambdaHack.Server.State---- | Start a game session, including the clients, and then loop,--- communicating with the clients.-loopSer :: (MonadAtomic m, MonadServerReadRequest m)-        => Kind.COps  -- ^ game content-        -> DebugModeSer  -- ^ server debug parameters-        -> (FactionId -> ChanServer ResponseUI RequestUI -> IO ())-             -- ^ the code to run for UI clients-        -> (FactionId -> ChanServer ResponseAI RequestAI -> IO ())-             -- ^ the code to run for AI clients-        -> m ()-loopSer cops sdebug executorUI executorAI = do-  -- Recover states and launch clients.-  let updConn = updateConn executorUI executorAI-  restored <- tryRestore cops sdebug-  case restored of-    Just (sRaw, ser) | not $ snewGameSer sdebug -> do  -- run a restored game-      -- First, set the previous cops, to send consistent info to clients.-      let setPreviousCops = const cops-      execUpdAtomic $ UpdResumeServer $ updateCOps setPreviousCops sRaw-      putServer ser-      sdebugNxt <- initDebug cops sdebug-      modifyServer $ \ser2 -> ser2 {sdebugNxt}-      applyDebug-      updConn-      initPer-      pers <- getsServer sper-      broadcastUpdAtomic $ \fid -> UpdResume fid (pers EM.! fid)-      -- Second, set the current cops and reinit perception.-      let setCurrentCops = const (speedupCOps (sallClear sdebugNxt) cops)-      -- @sRaw@ is correct here, because none of the above changes State.-      execUpdAtomic $ UpdResumeServer $ updateCOps setCurrentCops sRaw-      -- We dump RNG seeds here, in case the game wasn't run-      -- with --dumpInitRngs previously and we need to seeds.-      when (sdumpInitRngs sdebug) dumpRngs-    _ -> do  -- Starting the first new game for this savefile.-      -- Set up commandline debug mode-      let mrandom = case restored of-            Just (_, ser) -> Just $ srandom ser-            Nothing -> Nothing-      s <- gameReset cops sdebug Nothing mrandom-      sdebugNxt <- initDebug cops sdebug-      let debugBarRngs = sdebugNxt {sdungeonRng = Nothing, smainRng = Nothing}-      modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs-                                 , sdebugSer = debugBarRngs }-      let speedup = speedupCOps (sallClear sdebugNxt)-      execUpdAtomic $ UpdRestartServer $ updateCOps speedup s-      updConn-      initPer-      reinitGame-      writeSaveAll False-  resetSessionStart-  -- Note that if a faction enters dungeon on a level with no spawners,-  -- the faction won't cause spawning on its active arena-  -- as long as it has no leader. This may cause regeneration items-  -- of its opponents become overpowered and lead to micromanagement-  -- (make sure to kill all actors of the faction, go to a no-spawn-  -- level and heal fully with no risk nor cost).-  let arenasForLoop = do-        let factionArena fact =-              case gleader fact of-               -- Even spawners need an active arena for their leader,-               -- or they start clogging stairs.-               Just (leader, _) -> do-                  b <- getsState $ getActorBody leader-                  return $ Just $ blid b-               Nothing -> if fleaderMode (gplayer fact) == LeaderNull-                             || EM.null (gvictims fact)-                          then return Nothing-                          else Just <$> getEntryArena fact-        factionD <- getsState sfactionD-        marenas <- mapM factionArena $ EM.elems factionD-        let arenas = ES.toList $ ES.fromList $ catMaybes marenas-        let !_A = assert (not $ null arenas) ()  -- game over not caught earlier-        return $! arenas-  -- Start a clip (a part of a turn for which one or more frames-  -- will be generated). Do whatever has to be done-  -- every fixed number of time units, e.g., monster generation.-  -- Run the leader and other actors moves. Eventually advance the time-  -- and repeat.-  let loop arenasStart [] = do-        arenas <- arenasForLoop-        continue <- endClip arenasStart-        when continue (loop arenas arenas)-      loop arenasStart (arena : rest) = do-        handleActors arena-        quit <- getsServer squit-        if quit then do-          -- In case of game save+exit or restart, don't age levels (endClip)-          -- since possibly not all actors have moved yet.-          modifyServer $ \ser -> ser {squit = False}-          let loopAgain = loop arenasStart (arena : rest)-          endOrLoop loopAgain-                    (restartGame updConn loopNew) gameExit (writeSaveAll True)-        else-          loop arenasStart rest-      loopNew = do-        arenas <- arenasForLoop-        loop arenas arenas-  loopNew--endClip :: (MonadAtomic m, MonadServer m, MonadServerReadRequest m)-        => [LevelId] -> m Bool-endClip arenas = do-  Kind.COps{corule} <- getsState scops-  let stdRuleset = Kind.stdRuleset corule-      writeSaveClips = rwriteSaveClips stdRuleset-      leadLevelClips = rleadLevelClips stdRuleset-      ageProcessed lid = EM.insertWith absoluteTimeAdd lid timeClip-      ageServer lid ser = ser {sprocessed = ageProcessed lid $ sprocessed ser}-  mapM_ (modifyServer . ageServer) arenas-  execUpdAtomic $ UpdAgeGame (Delta timeClip) arenas-  -- Perform periodic dungeon maintenance.-  time <- getsState stime-  let clipN = time `timeFit` timeClip-      clipInTurn = let r = timeTurn `timeFit` timeClip-                   in assert (r > 2) r-      clipMod = clipN `mod` clipInTurn-  when (clipN `mod` writeSaveClips == 0) $ do-    modifyServer $ \ser -> ser {swriteSave = False}-    writeSaveAll False-  when (clipN `mod` leadLevelClips == 0) leadLevelSwitch-  if clipMod == 1 then do-    -- Periodic activation only once per turn, for speed, but on all arenas.-    mapM_ applyPeriodicLevel arenas-    -- Add monsters each turn, not each clip.-    -- Do this on only one of the arenas to prevent micromanagement,-    -- e.g., spreading leaders across levels to bump monster generation.-    arena <- rndToAction $ oneOf arenas-    spawnMonster arena-    -- Check, once per turn, for benchmark game stop, after a set time.-    stopAfter <- getsServer $ sstopAfter . sdebugSer-    case stopAfter of-      Nothing -> return True-      Just stopA -> do-        exit <- elapsedSessionTimeGT stopA-        if exit then do-          tellAllClipPS-          gameExit-          return False  -- don't re-enter the game loop-        else return True-  else return True---- | Trigger periodic items for all actors on the given level.-applyPeriodicLevel :: (MonadAtomic m, MonadServer m) => LevelId -> m ()-applyPeriodicLevel lid = do-  discoEffect <- getsServer sdiscoEffect-  let applyPeriodicItem c aid iid =-        case EM.lookup iid discoEffect of-          Just ItemAspectEffect{jeffects, jaspects} ->-            when (IK.Periodic `elem` jaspects) $ do-              -- Check if the item is still in the bag (previous items act!).-              bag <- getsState $ getCBag c-              case iid `EM.lookup` bag of-                Nothing -> return ()  -- item dropped-                Just kit ->-                  -- In periodic activation, consider *only* recharging effects.-                  effectAndDestroy aid aid iid c True-                                   (allRecharging jeffects) jaspects kit-          _ -> assert `failure` (lid, aid, c, iid)-      applyPeriodicCStore aid cstore = do-        let c = CActor aid cstore-        bag <- getsState $ getCBag c-        mapM_ (applyPeriodicItem c aid) $ EM.keys bag-      applyPeriodicActor aid = do-        applyPeriodicCStore aid COrgan-        applyPeriodicCStore aid CEqp-  allActors <- getsState $ actorRegularAssocs (const True) lid-  mapM_ (\(aid, _) -> applyPeriodicActor aid) allActors---- | Perform moves for individual actors, as long as there are actors--- with the next move time less or equal to the end of current cut-off.-handleActors :: (MonadAtomic m, MonadServerReadRequest m)-             => LevelId -> m ()-handleActors lid = do-  -- The end of this clip, inclusive. This is used exclusively-  -- to decide which actors to process this time. Transparent to clients.-  timeCutOff <- getsServer $ EM.findWithDefault timeClip lid . sprocessed-  Level{lprio} <- getLevel lid-  quit <- getsServer squit-  factionD <- getsState sfactionD-  s <- getState-  let -- Actors of the same faction move together.-      notDead (_, b) = not $ actorDying b-      notProj (_, b) = not $ bproj b-      notLeader (aid, b) = Just aid /= fmap fst (gleader (factionD EM.! bfid b))-      order = Ord.comparing $-        notDead &&& notProj &&& bfid . snd &&& notLeader &&& bsymbol . snd-      (atime, as) = EM.findMin lprio-      ams = map (\a -> (a, getActorBody a s)) as-      mnext | EM.null lprio = Nothing  -- no actor alive, wait until it spawns-            | otherwise = if atime > timeCutOff-                          then Nothing  -- no actor is ready for another move-                          else Just $ minimumBy order ams-      startActor aid = execSfxAtomic $ SfxActorStart aid-  case mnext of-    _ | quit -> return ()-    Nothing -> return ()-    Just (aid, b) | bproj b && maybe True (null . fst) (btrajectory b) -> do-      startActor aid-      -- A projectile drops to the ground due to obstacles or range.-      -- The carried item is not destroyed, but drops to the ground.-      dieSer aid b False-      handleActors lid-    Just (aid, b) | bhp b <= 0 -> do-      startActor aid-      -- If @b@ is a projectile and it hits an actor,-      -- the carried item is destroyed and that's all.-      -- Otherwise, an actor dies, items drop to the ground-      -- and possibly a new leader is elected.-      dieSer aid b (bproj b)-      handleActors lid-    Just (aid, body) -> do-      let side = bfid body-          fact = factionD EM.! side-          mleader = gleader fact-          aidIsLeader = fmap fst mleader == Just aid-          mainUIactor = fhasUI (gplayer fact)-                        && (aidIsLeader-                            || fleaderMode (gplayer fact) == LeaderNull)-      queryUI <--        if mainUIactor then do-          let underAI = isAIFact fact-          if underAI then do-            -- If UI client for the faction completely under AI control,-            -- ping often to sync frames and to catch ESC,-            -- which switches off Ai control.-            sendPingUI side-            fact2 <- getsState $ (EM.! side) . sfactionD-            let underAI2 = isAIFact fact2-            return $! not underAI2-          else return True-        else return False-      let setBWait hasWait aidNew = do-            bPre <- getsState $ getActorBody aidNew-            when (hasWait /= bwait bPre) $-              execUpdAtomic $ UpdWaitActor aidNew hasWait-      if isJust $ btrajectory body then do-        setTrajectory aid-        b2 <- getsState $ getActorBody aid-        unless (bproj b2 && actorDying b2) $-          advanceTime aid-      else if queryUI then do-        cmdS <- sendQueryUI side aid-        -- TODO: check that the command is legal first, report and reject,-        -- but do not crash (currently server asserts things and crashes)-        (aidNew, action) <- handleRequestUI side cmdS-        let hasWait (ReqUITimed ReqWait{}) = True-            hasWait (ReqUILeader _ _ cmd) = hasWait cmd-            hasWait _ = False-        maybe (return ()) (setBWait (hasWait cmdS)) aidNew-        -- Advance time once, after the leader switched perhaps many times.-        -- The following was true before, but now we badly want to avoid double-        -- moves against the UI player (especially deadly when using stairs),-        -- so this is no longer true:-          -- Sometimes this may result in a double move of the new leader,-          -- followed by a double pause. Or a fractional variant of that.-          -- In this setup, reading a scroll of Previous Leader is a free action-          -- for the old leader, but otherwise his time is undisturbed.-          -- He is able to move normally in the same turn, immediately-          -- after the new leader completes his move.-        -- So now we exchange times of the old and new leader.-        -- This permits an abuse, because a slow tank can be moved fast-        -- by alternating between it and many fast actors (until all of them-        -- get slowed down by this and none remain). But at least the sum-        -- of all times of a faction is conserved. And we avoid double moves-        -- against the UI player caused by his leader changes. There may still-        -- happen double moves caused by AI leader changes, but that's rare.-        -- The flip side is the possibility of multi-moves of the UI player-        -- as in the case of the tank, but at least the sum of times is OK.-        -- Warning: when the action is performed on the server,-        -- the time of the actor is different than when client prepared that-        -- action, so any client checks involving time should discount this.-        when (aidIsLeader && Just aid /= aidNew) $-          maybe (return ()) (swapTime aid) aidNew-        maybe (return ()) advanceTime aidNew-        action-        maybe (return ()) managePerTurn aidNew-      else do-        -- Clear messages in the UI client (if any), if the actor-        -- is a leader (which happens when a UI client is fully-        -- computer-controlled) or if faction is leaderless.-        -- We could record history more often, to avoid long reports,-        -- but we'd have to add -more- prompts.-        when mainUIactor $ execUpdAtomic $ UpdRecordHistory side-        cmdS <- sendQueryAI side aid-        (aidNew, action) <- handleRequestAI side aid cmdS-        let hasWait (ReqAITimed ReqWait{}) = True-            hasWait (ReqAILeader _ _ cmd) = hasWait cmd-            hasWait _ = False-        setBWait (hasWait cmdS) aidNew-        -- AI always takes time and so doesn't loop.-        advanceTime aidNew-        action-        managePerTurn aidNew-      b3 <- getsState $ getActorBody aid-      unless (waitedLastTurn b3) $ startActor aid-      handleActors lid--gameExit :: (MonadAtomic m, MonadServerReadRequest m) => m ()-gameExit = do-  -- Kill all clients, including those that did not take part-  -- in the current game.-  -- Clients exit not now, but after they print all ending screens.-  -- debugPrint "Server kills clients"-  killAllClients-  -- Verify that the saved perception is equal to future reconstructed.-  persAccumulated <- getsServer sper-  fovMode <- getsServer $ sfovMode . sdebugSer-  ser <- getServer-  pers <- getsState $ \s -> dungeonPerception (fromMaybe Digital fovMode) s ser-  let !_A = assert (persAccumulated == pers-                    `blame` "wrong accumulated perception"-                    `twith` (persAccumulated, pers)) ()-  return ()--restartGame :: (MonadAtomic m, MonadServerReadRequest m)-            => m () -> m () -> Maybe (GroupName ModeKind) ->  m ()-restartGame updConn loop mgameMode = do-  tellGameClipPS-  cops <- getsState scops-  sdebugNxt <- getsServer sdebugNxt-  srandom <- getsServer srandom-  s <- gameReset cops sdebugNxt mgameMode (Just srandom)-  let debugBarRngs = sdebugNxt {sdungeonRng = Nothing, smainRng = Nothing}-  modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs-                             , sdebugSer = debugBarRngs }-  execUpdAtomic $ UpdRestartServer s-  updConn-  initPer-  reinitGame-  writeSaveAll False-  loop---- TODO: This can be improved by adding a timeout--- and by asking clients to prepare--- a save (in this way checking they have permissions, enough space, etc.)--- and when all report back, asking them to commit the save.--- | Save game on server and all clients. Clients are pinged first,--- which greatly reduced the chance of saves being out of sync.-writeSaveAll :: (MonadAtomic m, MonadServerReadRequest m) => Bool -> m ()-writeSaveAll uiRequested = do-  bench <- getsServer $ sbenchmark . sdebugCli . sdebugSer-  when (uiRequested || not bench) $ do-    factionD <- getsState sfactionD-    let ping fid _ = do-          sendPingAI fid-          when (fhasUI $ gplayer $ factionD EM.! fid) $ sendPingUI fid-    mapWithKeyM_ ping factionD-    execUpdAtomic UpdWriteSave-    saveServer---- TODO: move somewhere?--- | Manage trajectory of a projectile.------ Colliding with a wall or actor doesn't take time, because--- the projectile does not move (the move is blocked).--- Not advancing time forces dead projectiles to be destroyed ASAP.--- Otherwise, with some timings, it can stay on the game map dead,--- blocking path of human-controlled actors and alarming the hapless human.-setTrajectory :: (MonadAtomic m, MonadServer m) => ActorId -> m ()-setTrajectory aid = do-  cops <- getsState scops-  b <- getsState $ getActorBody aid-  lvl <- getLevel $ blid b-  case btrajectory b of-    Just (d : lv, speed) ->-      if not $ accessibleDir cops lvl (bpos b) d-      then do-        -- Lose HP due to bumping into an obstacle.-        execUpdAtomic $ UpdRefillHP aid minusM-        execUpdAtomic $ UpdTrajectory aid-                                      (btrajectory b)-                                      (Just ([], speed))-      else do-        when (bproj b && null lv) $ do-          let toColor = Color.BrBlack-          when (bcolor b /= toColor) $-            execUpdAtomic $ UpdColorActor aid (bcolor b) toColor-        -- Hit clears trajectory of non-projectiles in reqMelee so no need here.-        -- Non-projectiles displace, to make pushing in crowds less lethal-        -- and chaotic and to avoid hitting harpoons when pulled by them.-        let tpos = bpos b `shift` d  -- target position-        tgt <- getsState $ posToActors tpos (blid b)-        case tgt of-          [(target, _)] | not (bproj b) -> reqDisplace aid target-          _ -> reqMove aid d-        b2 <- getsState $ getActorBody aid-        unless (btrajectory b2 == Just (lv, speed)) $  -- cleared in reqMelee-          execUpdAtomic $ UpdTrajectory aid (btrajectory b2) (Just (lv, speed))-    Just ([], _) -> do  -- non-projectile actor stops flying-      let !_A = assert (not $ bproj b) ()-      execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing-    _ -> assert `failure` "Nothing trajectory" `twith` (aid, b)

Game/LambdaHack/Server/MonadServer.hs view

@@ -1,39 +1,39 @@ -- | Game action monads and basic building blocks for human and computer--- player actions. Has no access to the the main action type.+-- player actions. Has no access to the main action type. -- Does not export the @liftIO@ operation nor a few other implementation -- details. module Game.LambdaHack.Server.MonadServer   ( -- * The server monad-    MonadServer( getServer, getsServer, modifyServer, putServer+    MonadServer( getsServer+               , modifyServer                , saveChanServer  -- exposed only to be implemented, not used                , liftIO  -- exposed only to be implemented, not used                )     -- * Assorted primitives-  , debugPossiblyPrint, debugPossiblyPrintAndExit-  , serverPrint, saveServer, saveName, dumpRngs-  , restoreScore, registerScore-  , resetSessionStart, resetGameStart, elapsedSessionTimeGT-  , tellAllClipPS, tellGameClipPS-  , tryRestore, speedupCOps, rndToAction, getSetGen+  , getServer, putServer, debugPossiblyPrint, debugPossiblyPrintAndExit+  , serverPrint, saveServer, dumpRngs, restoreScore, registerScore+  , rndToAction, getSetGen   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude++-- Cabal+import qualified Paths_LambdaHack as Self (version)+ import qualified Control.Exception as Ex hiding (handle)-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Control.Monad.State as St+import qualified Control.Monad.Trans.State.Strict as St import qualified Data.EnumMap.Strict as EM-import Data.Maybe-import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T-import System.Directory+import Data.Time.Clock.POSIX+import Data.Time.LocalTime import System.Exit (exitFailure) import System.FilePath-import System.IO+import System.IO (hFlush, stdout) import qualified System.Random as R-import System.Time -import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.ClientOptions import Game.LambdaHack.Common.Faction@@ -42,46 +42,46 @@ import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Save import qualified Game.LambdaHack.Common.Save as Save import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Server.State  class MonadStateRead m => MonadServer m where-  getServer      :: m StateServer   getsServer     :: (StateServer -> a) -> m a   modifyServer   :: (StateServer -> StateServer) -> m ()-  putServer      :: StateServer -> m ()-  -- We do not provide a MonadIO instance, so that outside of Action/+  saveChanServer :: m (Save.ChanSave (State, StateServer))+  -- We do not provide a MonadIO instance, so that outside   -- nobody can subvert the action monads by invoking arbitrary IO.   liftIO         :: IO a -> m a-  saveChanServer :: m (Save.ChanSave (State, StateServer)) +getServer :: MonadServer m => m StateServer+getServer = getsServer id++putServer :: MonadServer m => StateServer -> m ()+putServer s = modifyServer (const s)+ debugPossiblyPrint :: MonadServer m => Text -> m () debugPossiblyPrint t = do   debug <- getsServer $ sdbgMsgSer . sdebugSer   when debug $ liftIO $ do-    T.hPutStrLn stderr t-    hFlush stderr+    T.hPutStrLn stdout t+    hFlush stdout  debugPossiblyPrintAndExit :: MonadServer m => Text -> m () debugPossiblyPrintAndExit t = do   debug <- getsServer $ sdbgMsgSer . sdebugSer   when debug $ liftIO $ do-    T.hPutStrLn stderr t-    hFlush stderr+    T.hPutStrLn stdout t+    hFlush stdout     exitFailure  serverPrint :: MonadServer m => Text -> m () serverPrint t = liftIO $ do-  T.hPutStrLn stderr t-  hFlush stderr+  T.hPutStrLn stdout t+  hFlush stdout  saveServer :: MonadServer m => m () saveServer = do@@ -90,54 +90,47 @@   toSave <- saveChanServer   liftIO $ Save.saveToChan toSave (s, ser) -saveName :: String-saveName = serverSaveName---- | Dumps RNG states from the start of the game to stderr.-dumpRngs :: MonadServer m => m ()-dumpRngs = do-  rngs <- getsServer srngs-  liftIO $ do-    T.hPutStrLn stderr $ tshow rngs-    hFlush stderr+-- | Dumps RNG states from the start of the game to stdout.+dumpRngs :: MonadServer m => RNGs -> m ()+dumpRngs rngs = liftIO $ do+  T.hPutStrLn stdout $ tshow rngs+  hFlush stdout --- TODO: refactor wrt Game.LambdaHack.Common.Save -- | Read the high scores dictionary. Return the empty table if no file.-restoreScore :: MonadServer m => Kind.COps -> m HighScore.ScoreDict+restoreScore :: forall m. MonadServer m => Kind.COps -> m HighScore.ScoreDict restoreScore Kind.COps{corule} = do-  let stdRuleset = Kind.stdRuleset corule-      scoresFile = rscoresFile stdRuleset-  dataDir <- liftIO appDataDir-  let path = dataDir </> scoresFile-  configExists <- liftIO $ doesFileExist path-  mscore <- liftIO $ do-    res <- Ex.try $+  bench <- getsServer $ sbenchmark . sdebugCli . sdebugSer+  mscore <- if bench then return Nothing else do+    let stdRuleset = Kind.stdRuleset corule+        scoresFile = rscoresFile stdRuleset+    dataDir <- liftIO appDataDir+    let path bkp = dataDir </> bkp <> scoresFile+    configExists <- liftIO $ doesFileExist (path "")+    res <- liftIO $ Ex.try $       if configExists then do-        s <- strictDecodeEOF path-        return $ Just s+        (vlib2, s) <- strictDecodeEOF (path "")+        if vlib2 == Self.version+        then return $ Just s+        else do+          let msg = "High score file from old version of game detected."+          fail msg       else return Nothing-    let handler :: Ex.SomeException -> IO (Maybe a)+    let handler :: Ex.SomeException -> m (Maybe a)         handler e = do-          let msg = "High score restore failed. The error message is:"+          let msg = "High score restore failed. The old file moved aside. The error message is:"                     <+> (T.unwords . T.lines) (tshow e)-          delayPrint msg+          serverPrint msg+          liftIO $ renameFile (path "") (path "bkp.")           return Nothing     either handler return res   maybe (return HighScore.empty) return mscore  -- | Generate a new score, register it and save.-registerScore :: MonadServer m => Status -> Maybe Actor -> FactionId -> m ()-registerScore status mbody fid = do+registerScore :: MonadServer m => Status -> FactionId -> m ()+registerScore status fid = do   cops@Kind.COps{corule} <- getsState scops-  let !_A = assert (maybe True ((fid ==) . bfid) mbody) ()   fact <- getsState $ (EM.! fid) . sfactionD-  total <- case mbody of-    Just body -> getsState $ snd . calculateTotal body-    Nothing -> case gleader fact of-      Nothing -> return 0-      Just (aid, _) -> do-        b <- getsState $ getActorBody aid-        getsState $ snd . calculateTotal b+  total <- getsState $ snd . calculateTotal fid   let stdRuleset = Kind.stdRuleset corule       scoresFile = rscoresFile stdRuleset   dataDir <- liftIO appDataDir@@ -145,8 +138,9 @@   scoreDict <- restoreScore cops   gameModeId <- getsState sgameModeId   time <- getsState stime-  date <- liftIO getClockTime-  DebugModeSer{scurDiffSer} <- getsServer sdebugSer+  date <- liftIO getPOSIXTime+  tz <- liftIO $ getTimeZone $ posixSecondsToUTCTime date+  curChalSer <- getsServer $ scurChalSer . sdebugSer   factionD <- getsState sfactionD   bench <- getsServer $ sbenchmark . sdebugCli . sdebugSer   let path = dataDir </> scoresFile@@ -154,13 +148,14 @@         -- If not human, probably debugging, so dump instead of registering.         if bench || isAIFact fact then           debugPossiblyPrint $ T.intercalate "\n"-          $ HighScore.showScore (pos, HighScore.getRecord pos ntable)+          $ HighScore.showScore tz (pos, HighScore.getRecord pos ntable)         else           let nScoreDict = EM.insert gameModeId ntable scoreDict-          in when worthMentioning $-               liftIO $ encodeEOF path (nScoreDict :: HighScore.ScoreDict)-      diff | fhasUI $ gplayer fact = scurDiffSer-           | otherwise = difficultyInverse scurDiffSer+          in when worthMentioning $ liftIO $+               encodeEOF path (Self.version, nScoreDict :: HighScore.ScoreDict)+      chal | fhasUI $ gplayer fact = curChalSer+           | otherwise = curChalSer+                           {cdiff = difficultyInverse (cdiff curChalSer)}       theirVic (fi, fa) | isAtWar fact fi                           && not (isHorrorFact fa) = Just $ gvictims fa                         | otherwise = Nothing@@ -170,99 +165,23 @@       ourVictims = EM.unionsWith (+) $ mapMaybe ourVic $ EM.assocs factionD       table = HighScore.getTable gameModeId scoreDict       registeredScore =-        HighScore.register table total time status date diff-                           (fname $ gplayer fact)+        HighScore.register table total time status date chal+                           (T.unwords $ tail $ T.words $ gname fact)                            ourVictims theirVictims                            (fhiCondPoly $ gplayer fact)   outputScore registeredScore -resetSessionStart :: MonadServer m => m ()-resetSessionStart = do-  sstart <- liftIO getClockTime-  modifyServer $ \ser -> ser {sstart}---- TODO: all this breaks when games are loaded; we'd need to save--- elapsed game clock time to fix this.-resetGameStart :: MonadServer m => m ()-resetGameStart = do-  sgstart <- liftIO getClockTime-  time <- getsState stime-  modifyServer $ \ser ->-    ser {sgstart, sallTime = absoluteTimeAdd (sallTime ser) time}--elapsedSessionTimeGT :: MonadServer m => Int -> m Bool-elapsedSessionTimeGT stopAfter = do-  current <- liftIO getClockTime-  TOD s p <- getsServer sstart-  return $! TOD (s + fromIntegral stopAfter) p <= current--tellAllClipPS :: MonadServer m => m ()-tellAllClipPS = do-  bench <- getsServer $ sbenchmark . sdebugCli . sdebugSer-  when bench $ do-    TOD s p <- getsServer sstart-    TOD sCur pCur <- liftIO getClockTime-    allTime <- getsServer sallTime-    gtime <- getsState stime-    let time = absoluteTimeAdd allTime gtime-    let diff = fromIntegral sCur + fromIntegral pCur / 10e12-               - fromIntegral s - fromIntegral p / 10e12-        cps = fromIntegral (timeFit time timeClip) / diff :: Double-    debugPossiblyPrint $-      "Session time:" <+> tshow diff <> "s."-      <+> "Average clips per second:" <+> tshow cps <> "."--tellGameClipPS :: MonadServer m => m ()-tellGameClipPS = do-  bench <- getsServer $ sbenchmark . sdebugCli . sdebugSer-  when bench $ do-    TOD s p <- getsServer sgstart-    unless (s == 0) $ do  -- loaded game, don't report anything-      TOD sCur pCur <- liftIO getClockTime-      time <- getsState stime-      let diff = fromIntegral sCur + fromIntegral pCur / 10e12-                 - fromIntegral s - fromIntegral p / 10e12-          cps = fromIntegral (timeFit time timeClip) / diff :: Double-      debugPossiblyPrint $-        "Game time:" <+> tshow diff <> "s."-        <+> "Average clips per second:" <+> tshow cps <> "."--tryRestore :: MonadServer m-           => Kind.COps -> DebugModeSer -> m (Maybe (State, StateServer))-tryRestore Kind.COps{corule} sdebugSer = do-  let bench = sbenchmark $ sdebugCli sdebugSer-  if bench then return Nothing-  else do-    let stdRuleset = Kind.stdRuleset corule-        scoresFile = rscoresFile stdRuleset-        pathsDataFile = rpathsDataFile stdRuleset-        prefix = ssavePrefixSer sdebugSer-    let copies = [( "GameDefinition" </> scoresFile-                  , scoresFile )]-        name = fromMaybe "save" prefix <.> saveName-    liftIO $ Save.restoreGame name copies pathsDataFile---- | Compute and insert auxiliary optimized components into game content,--- to be used in time-critical sections of the code.-speedupCOps :: Bool -> Kind.COps -> Kind.COps-speedupCOps allClear copsSlow@Kind.COps{cotile=tile} =-  let ospeedup = Tile.speedup allClear tile-      cotile = tile {Kind.ospeedup = Just ospeedup}-  in copsSlow {Kind.cotile = cotile}- -- | Invoke pseudo-random computation with the generator kept in the state. rndToAction :: MonadServer m => Rnd a -> m a rndToAction r = do-  g <- getsServer srandom-  let (a, ng) = St.runState r g-  modifyServer $ \ser -> ser {srandom = ng}-  return $! a+  gen <- getsServer srandom+  let (gen1, gen2) = R.split gen+  modifyServer $ \ser -> ser {srandom = gen1}+  return $! St.evalState r gen2  -- | Gets a random generator from the arguments or, if not present, -- generates one.-getSetGen :: MonadServer m-          => Maybe R.StdGen-          -> m R.StdGen+getSetGen :: MonadServer m => Maybe R.StdGen -> m R.StdGen getSetGen mrng = case mrng of   Just rnd -> return rnd   Nothing -> liftIO R.newStdGen

+ Game/LambdaHack/Server/PeriodicM.hs view

@@ -0,0 +1,269 @@+-- | Server operations performed periodically in the game loop+-- and related operations.+module Game.LambdaHack.Server.PeriodicM+  ( spawnMonster, addAnyActor+  , advanceTime, overheadActorTime, swapTime+  , leadLevelSwitch, udpateCalm+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import Data.Int (Int64)++import Game.LambdaHack.Atomic+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Frequency+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Perception+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Content.ItemKind as IK+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Server.CommonM+import Game.LambdaHack.Server.ItemM+import Game.LambdaHack.Server.MonadServer+import Game.LambdaHack.Server.State++-- | Spawn, possibly, a monster according to the level's actor groups.+-- We assume heroes are never spawned.+spawnMonster :: (MonadAtomic m, MonadServer m) => m ()+spawnMonster = do+  arenas <- getsServer sarenas+  -- Do this on only one of the arenas to prevent micromanagement,+  -- e.g., spreading leaders across levels to bump monster generation.+  arena <- rndToAction $ oneOf arenas+  totalDepth <- getsState stotalDepth+  Level{ldepth, lactorCoeff, lactorFreq} <- getLevel arena+  lvlSpawned <- getsServer $ fromMaybe 0 . EM.lookup arena . snumSpawned+  rc <- rndToAction+        $ monsterGenChance ldepth totalDepth lvlSpawned lactorCoeff+  when rc $ do+    modifyServer $ \ser ->+      ser {snumSpawned = EM.insert arena (lvlSpawned + 1) $ snumSpawned ser}+    localTime <- getsState $ getLocalTime arena+    maid <- addAnyActor lactorFreq arena localTime Nothing+    case maid of+      Nothing -> return ()+      Just aid -> do+        b <- getsState $ getActorBody aid+        mleader <- getsState $ _gleader . (EM.! bfid b) . sfactionD+        when (isNothing mleader) $ supplantLeader (bfid b) aid++addAnyActor :: (MonadAtomic m, MonadServer m)+            => Freqs ItemKind -> LevelId -> Time -> Maybe Point+            -> m (Maybe ActorId)+addAnyActor actorFreq lid time mpos = do+  -- We bootstrap the actor by first creating the trunk of the actor's body+  -- contains the constant properties.+  cops <- getsState scops+  lvl <- getLevel lid+  factionD <- getsState sfactionD+  lvlSpawned <- getsServer $ fromMaybe 0 . EM.lookup lid . snumSpawned+  m4 <- rollItem lvlSpawned lid actorFreq+  case m4 of+    Nothing -> return Nothing+    Just (itemKnown, trunkFull, itemDisco, seed, _) -> do+      let ik = itemKind itemDisco+          freqNames = map fst $ IK.ifreq ik+          f fact = fgroups (gplayer fact)+          factGroups = concatMap f $ EM.elems factionD+          fidNames = case freqNames `intersect` factGroups of+            [] -> [nameOfHorrorFact]  -- fall back+            l -> l+      fidName <- rndToAction $ oneOf fidNames+      let g (_, fact) = fidName `elem` fgroups (gplayer fact)+          nameFids = map fst $ filter g $ EM.assocs factionD+          !_A = assert (not (null nameFids) `blame` (factionD, fidName)) ()+      fid <- rndToAction $ oneOf nameFids+      pers <- getsServer sperFid+      let allPers = ES.unions $ map (totalVisible . (EM.! lid))+                    $ EM.elems $ EM.delete fid pers  -- expensive :(+          -- Checking skill would be more accurate, but skills can be+          -- inside organs, equipment, tmp organs, created organs, etc.+          mobile = "mobile" `elem` freqNames+      pos <- case mpos of+        Just pos -> return pos+        Nothing -> do+          rollPos <- getsState $ rollSpawnPos cops allPers mobile lid lvl fid+          rndToAction rollPos+      let container = CTrunk fid lid pos+      trunkId <- registerItem trunkFull itemKnown seed container False+      addActorIid trunkId trunkFull False fid pos lid id time++rollSpawnPos :: Kind.COps -> ES.EnumSet Point+             -> Bool -> LevelId -> Level -> FactionId -> State+             -> Rnd Point+rollSpawnPos Kind.COps{coTileSpeedup} visible+             mobile lid lvl@Level{ltile, lxsize, lysize} fid s = do+  let inhabitants = warActorRegularList fid lid s+      distantSo df p _ = all (\b -> df $ chessDist (bpos b) p) inhabitants+      middlePos = Point (lxsize `div` 2) (lysize `div` 2)+      distantMiddle d p _ = chessDist p middlePos < d+      condList | mobile =+        [ distantSo (<= 10)  -- try hard to harass enemies+        , distantSo (<= 15)+        , distantSo (<= 20)+        ]+               | otherwise =+        [ distantMiddle 5+        , distantMiddle 10+        , distantMiddle 20+        , distantMiddle 50+        , distantMiddle 100+        ]+  -- Not considering TK.OftenActor, because monsters emerge from hidden ducts,+  -- which are easier to hide in crampy corridors that lit halls.+  findPosTry2 (if mobile then 500 else 100) ltile+    ( \p t -> Tile.isWalkable coTileSpeedup t+              && not (Tile.isNoActor coTileSpeedup t)+              && null (posToAidsLvl p lvl))+    condList+    (\p t -> distantSo (> 4) p t  -- otherwise actors in dark rooms swarmed+             && not (p `ES.member` visible))  -- visibility and plausibility+    [ \p t -> distantSo (> 3) p t+              && not (p `ES.member` visible)+    , \p t -> distantSo (> 2) p t -- otherwise actors hit on entering level+              && not (p `ES.member` visible)+    , \p _ -> not (p `ES.member` visible)+    ]++-- | Advance the move time for the given actor+advanceTime :: (MonadAtomic m, MonadServer m) => ActorId -> Int -> m ()+advanceTime aid percent = do+  b <- getsState $ getActorBody aid+  actorAspect <- getsServer sactorAspect+  let ar = actorAspect EM.! aid+      t = timeDeltaPercent (ticksPerMeter $ bspeed b ar) percent+  -- @t@ may be negative; that's OK.+  modifyServer $ \ser ->+    ser {sactorTime = ageActor (bfid b) (blid b) aid t $ sactorTime ser}++-- Add communication overhead time delta to all non-projectile, non-dying+-- faction's actors (except the leader). Effectively, this limits moves of+-- a faction to 10, regardless of the number of actors and their speeds.+-- To discourage micromanagement distributing actors among active arenas,+-- overhead applies to all actors in active arenas.+--+-- Leader is immune from overhead and so he is faster than other faction+-- members and of equal speed to leaders of other factions (of equal+-- base speed) regardless how numerous the faction is.+-- Thanks to this, there is no problem with leader of a numerous faction+-- having very long UI turns, introducing UI lag.+overheadActorTime :: (MonadAtomic m, MonadServer m) => FactionId -> m ()+overheadActorTime fid = do+  actorTime <- getsServer $ (EM.! fid) . sactorTime+  s <- getState+  mleader <- getsState $ _gleader . (EM.! fid) . sfactionD+  arenas <- getsServer sarenas+  let f !aid !time =+        let body = getActorBody aid s+        in if isNothing (btrajectory body)+              && bhp body > 0+              && Just aid /= mleader  -- leader fast, for UI to be fast+           then timeShift time (Delta timeClip)+           else time+      g !acc !lid = EM.adjust (EM.mapWithKey f) lid acc+      actorTimeNew = foldl' g actorTime arenas+  modifyServer $ \ser ->+    ser {sactorTime = EM.insert fid actorTimeNew $ sactorTime ser}++-- | Swap the relative move times of two actors (e.g., when switching+-- a UI leader).+swapTime :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m ()+swapTime source target = do+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  slvl <- getsState $ getLocalTime (blid sb)+  tlvl <- getsState $ getLocalTime (blid tb)+  btime_sb <- getsServer $ (EM.! source) . (EM.! blid sb) . (EM.! bfid sb) . sactorTime+  btime_tb <- getsServer $ (EM.! target) . (EM.! blid tb) . (EM.! bfid tb) . sactorTime+  let lvlDelta = slvl `timeDeltaToFrom` tlvl+      bDelta = btime_sb `timeDeltaToFrom` btime_tb+      sdelta = timeDeltaSubtract lvlDelta bDelta+      tdelta = timeDeltaReverse sdelta+  -- Equivalent, for the assert:+  let !_A = let sbodyDelta = btime_sb `timeDeltaToFrom` slvl+                tbodyDelta = btime_tb `timeDeltaToFrom` tlvl+                sgoal = slvl `timeShift` tbodyDelta+                tgoal = tlvl `timeShift` sbodyDelta+                sdelta' = sgoal `timeDeltaToFrom` btime_sb+                tdelta' = tgoal `timeDeltaToFrom` btime_tb+            in assert (sdelta == sdelta' && tdelta == tdelta'+                       `blame` ( slvl, tlvl, btime_sb, btime_tb+                               , sdelta, sdelta', tdelta, tdelta' )) ()+  when (sdelta /= Delta timeZero) $ modifyServer $ \ser ->+    ser {sactorTime = ageActor (bfid sb) (blid sb) source sdelta $ sactorTime ser}+  when (tdelta /= Delta timeZero) $ modifyServer $ \ser ->+    ser {sactorTime = ageActor (bfid tb) (blid tb) target tdelta $ sactorTime ser}++udpateCalm :: (MonadAtomic m, MonadServer m) => ActorId -> Int64 -> m ()+udpateCalm target deltaCalm = do+  tb <- getsState $ getActorBody target+  actorAspect <- getsServer sactorAspect+  let ar = actorAspect EM.! target+      calmMax64 = xM $ aMaxCalm ar+  execUpdAtomic $ UpdRefillCalm target deltaCalm+  when (bcalm tb < calmMax64+        && bcalm tb + deltaCalm >= calmMax64) $+    return ()+    -- We don't dominate the actor here, because if so, players would+    -- disengage after one of their actors is dominated and wait for him+    -- to regenerate Calm. This is unnatural and boring. Better fight+    -- and hope he gets his Calm again to 0 and then defects back.++leadLevelSwitch :: (MonadAtomic m, MonadServer m) => m ()+leadLevelSwitch = do+  let canSwitch fact = fst (autoDungeonLevel fact)+                       -- a hack to help AI, until AI client can switch levels+                       || case fleaderMode (gplayer fact) of+                            LeaderNull -> False+                            LeaderAI _ -> True+                            LeaderUI _ -> False+      flipFaction fact | not $ canSwitch fact = return ()+      flipFaction fact =+        case _gleader fact of+          Nothing -> return ()+          Just leader -> do+            body <- getsState $ getActorBody leader+            s <- getState+            let leaderStuck = waitedLastTurn body+                ourLvl (lid, lvl) =+                  ( lid+                  , EM.size (lfloor lvl)+                  , -- Drama levels skipped, hence @Regular@.+                    fidActorRegularIds (bfid body) lid s )+            ours <- getsState $ map ourLvl . EM.assocs . sdungeon+            -- Non-humans, being born in the dungeon, have a rough idea of+            -- the number of items left on the level and will focus+            -- on levels they started exploring and that have few items+            -- left. This is to to explore them completely, leave them+            -- once and for all and concentrate forces on another level.+            -- In addition, sole stranded actors tend to become leaders+            -- so that they can join the main force ASAP.+            let freqList = [ (k, (lid, a))+                           | (lid, itemN, a : rest) <- ours+                           , lid /= blid body || not leaderStuck+                           , let len = 1 + min 7 (length rest)+                                 divisor = 3 * itemN + len+                                 k = 1000000 `div` divisor ]+            unless (null freqList) $ do+              (lid, a) <- rndToAction $ frequency+                                      $ toFreq "leadLevel" freqList+              unless (lid == blid body) $  -- flip levels rather than actors+                supplantLeader (bfid body) a+  factionD <- getsState sfactionD+  mapM_ flipFaction $ EM.elems factionD

− Game/LambdaHack/Server/PeriodicServer.hs

@@ -1,345 +0,0 @@--- | Server operations performed periodically in the game loop--- and related operations.-module Game.LambdaHack.Server.PeriodicServer-  ( spawnMonster, addAnyActor, dominateFidSfx-  , advanceTime, swapTime, managePerTurn, leadLevelSwitch, udpateCalm-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Int (Int64)-import Data.List-import Data.Maybe--import Game.LambdaHack.Atomic-import qualified Game.LambdaHack.Common.Ability as Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Frequency-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.ItemKind (ItemKind)-import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.ModeKind-import qualified Game.LambdaHack.Content.TileKind as TK-import Game.LambdaHack.Server.CommonServer-import Game.LambdaHack.Server.ItemServer-import Game.LambdaHack.Server.MonadServer-import Game.LambdaHack.Server.State---- TODO: civilians would have 'it' pronoun--- | Sapwn, possibly, a monster according to the level's actor groups.--- We assume heroes are never spawned.-spawnMonster :: (MonadAtomic m, MonadServer m) => LevelId -> m ()-spawnMonster lid = do-  totalDepth <- getsState stotalDepth-  -- TODO: eliminate the defeated and victorious faction from lactorFreq;-  -- then fcanEscape and fneverEmpty make sense for spawning factions-  Level{ldepth, lactorCoeff, lactorFreq} <- getLevel lid-  lvlSpawned <- getsServer $ fromMaybe 0 . EM.lookup lid . snumSpawned-  rc <- rndToAction-        $ monsterGenChance ldepth totalDepth lvlSpawned lactorCoeff-  when rc $ do-    modifyServer $ \ser ->-      ser {snumSpawned = EM.insert lid (lvlSpawned + 1) $ snumSpawned ser}-    time <- getsState $ getLocalTime lid-    maid <- addAnyActor lactorFreq lid time Nothing-    case maid of-      Nothing -> return ()-      Just aid -> do-        b <- getsState $ getActorBody aid-        mleader <- getsState $ gleader . (EM.! bfid b) . sfactionD-        when (isNothing mleader) $-          execUpdAtomic $ UpdLeadFaction (bfid b) Nothing (Just (aid, Nothing))--addAnyActor :: (MonadAtomic m, MonadServer m)-            => Freqs ItemKind -> LevelId -> Time -> Maybe Point-            -> m (Maybe ActorId)-addAnyActor actorFreq lid time mpos = do-  -- We bootstrap the actor by first creating the trunk of the actor's body-  -- contains the constant properties.-  cops <- getsState scops-  lvl <- getLevel lid-  factionD <- getsState sfactionD-  lvlSpawned <- getsServer $ fromMaybe 0 . EM.lookup lid . snumSpawned-  m4 <- rollItem lvlSpawned lid actorFreq-  case m4 of-    Nothing -> return Nothing-    Just (itemKnown, trunkFull, itemDisco, seed, _) -> do-      let ik = itemKind itemDisco-          freqNames = map fst $ IK.ifreq ik-          f fact = fgroup (gplayer fact)-          factNames = map f $ EM.elems factionD-          fidName = case freqNames `intersect` factNames of-            [] -> head factNames  -- fall back to an arbitrary faction-            fName : _ -> fName-          g (_, fact) = fgroup (gplayer fact) == fidName-          mfid = find g $ EM.assocs factionD-          fid = fst $ fromMaybe (assert `failure` (factionD, fidName)) mfid-      pers <- getsServer sper-      let allPers = ES.unions $ map (totalVisible . (EM.! lid))-                    $ EM.elems $ EM.delete fid pers  -- expensive :(-          mobile = any (`elem` freqNames) ["mobile", "horror"]-      pos <- case mpos of-        Just pos -> return pos-        Nothing -> do-          fact <- getsState $ (EM.! fid) . sfactionD-          rollPos <- getsState $ rollSpawnPos cops allPers mobile lid lvl fact-          rndToAction rollPos-      let container = CTrunk fid lid pos-      trunkId <- registerItem trunkFull itemKnown seed-                              (itemK trunkFull) container False-      addActorIid trunkId trunkFull False fid pos lid id "it" time--rollSpawnPos :: Kind.COps -> ES.EnumSet Point-             -> Bool -> LevelId -> Level -> Faction -> State-             -> Rnd Point-rollSpawnPos Kind.COps{cotile} visible-             mobile lid Level{ltile, lxsize, lysize} fact s = do-  let inhabitants = actorRegularList (isAtWar fact) lid s-      as = actorList (const True) lid s-      distantSo df p _ =-        all (\b -> df $ chessDist (bpos b) p) inhabitants-      middlePos = Point (lxsize `div` 2) (lysize `div` 2)-      distantMiddle d p _ = chessDist p middlePos < d-      condList | mobile =-        [ distantSo (<= 10)  -- try hard to harass enemies-        , distantSo (<= 15)-        , distantSo (<= 20)-        ]-               | otherwise =-        [ distantMiddle 5-        , distantMiddle 10-        , distantMiddle 20-        , distantMiddle 50-        , distantMiddle 100-        ]-  -- Not considering TK.OftenActor, because monsters emerge from hidden ducts,-  -- which are easier to hide in crampy corridors that lit halls.-  findPosTry (if mobile then 500 else 100) ltile-    ( \p t -> Tile.isWalkable cotile t-              && not (Tile.hasFeature cotile TK.NoActor t)-              && unoccupied as p)-    (condList-     ++ [ distantSo (> 5)  -- otherwise actors in dark rooms are swarmed-        , distantSo (> 2)  -- otherwise actors can be hit on entering level-        , \p _ -> not (p `ES.member` visible)  -- surprise and believability-        ])--dominateFidSfx :: (MonadAtomic m, MonadServer m)-               => FactionId -> ActorId -> m Bool-dominateFidSfx fid target = do-  tb <- getsState $ getActorBody target-  -- Actors that don't move freely can't be dominated, for otherwise,-  -- when they are the last survivors, they could get stuck-  -- and the game wouldn't end.-  activeItems <- activeItemsServer target-  let actorMaxSk = sumSkills activeItems-      canMove = EM.findWithDefault 0 Ability.AbMove actorMaxSk > 0-                && EM.findWithDefault 0 Ability.AbTrigger actorMaxSk > 0-                && EM.findWithDefault 0 Ability.AbAlter actorMaxSk > 0-  if canMove && not (bproj tb)-    then do-      let execSfx = execSfxAtomic-                    $ SfxEffect (bfidImpressed tb) target IK.Dominate-      execSfx-      dominateFid fid target-      execSfx-      return True-    else-      return False--dominateFid :: (MonadAtomic m, MonadServer m)-            => FactionId -> ActorId -> m ()-dominateFid fid target = do-  Kind.COps{cotile} <- getsState scops-  tb0 <- getsState $ getActorBody target-  electLeader (bfid tb0) (blid tb0) target-  fact <- getsState $ (EM.! bfid tb0) . sfactionD-  -- Prevent the faction's stash from being lost in case they are not spawners.-  when (isNothing $ gleader fact) $ moveStores target CSha CInv-  tb <- getsState $ getActorBody target-  deduceKilled target tb-  -- TODO: some messages after game over below? Compare with dieSer.-  ais <- getsState $ getCarriedAssocs tb-  calmMax <- sumOrganEqpServer IK.EqpSlotAddMaxCalm target-  execUpdAtomic $ UpdLoseActor target tb ais-  let bNew = tb { bfid = fid-                , bfidImpressed = bfid tb-                , bcalm = max 0 $ xM calmMax `div` 2 }-  execUpdAtomic $ UpdSpotActor target bNew ais-  let discoverSeed (iid, cstore) = do-        seed <- getsServer $ (EM.! iid) . sitemSeedD-        item <- getsState $ getItemBody iid-        Level{ldepth} <- getLevel $ jlid item-        let c = CActor target cstore-        execUpdAtomic $ UpdDiscoverSeed c iid seed ldepth-      aic = getCarriedIidCStore tb-  mapM_ discoverSeed aic-  mleaderOld <- getsState $ gleader . (EM.! fid) . sfactionD-  -- Keep the leader if he is on stairs. We don't want to clog stairs.-  keepLeader <- case mleaderOld of-    Nothing -> return False-    Just (leaderOld, _) -> do-      body <- getsState $ getActorBody leaderOld-      lvl <- getLevel $ blid body-      return $! Tile.isStair cotile $ lvl `at` bpos body-  unless keepLeader $-    -- Focus on the dominated actor, by making him a leader.-    execUpdAtomic $ UpdLeadFaction fid mleaderOld (Just (target, Nothing))---- | Advance the move time for the given actor-advanceTime :: (MonadAtomic m, MonadServer m) => ActorId -> m ()-advanceTime aid = do-  b <- getsState $ getActorBody aid-  activeItems <- activeItemsServer aid-  localTime <- getsState $ getLocalTime (blid b)-  let halfActorTurn = timeDeltaDiv (ticksPerMeter $ bspeed b activeItems) 2-      -- Dead bodies stay around for only a half of standard turn,-      -- even if paralyzed.-      -- Projectiles that hit actors or are hit by actors vanish at once-      -- not to block actor's path, e.g., for Pull effect.-      t | bhp b <= 0 =-        let delta = Delta $ if bproj b then timeZero else timeTurn-            localPlusDelta = localTime `timeShift` delta-        in localPlusDelta `timeDeltaToFrom` btime b-        | otherwise = halfActorTurn-  execUpdAtomic $ UpdAgeActor aid t  -- @t@ may be negative; that's OK---- | Swap the relative move times of two actors (e.g., when switching--- a UI leader).-swapTime :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m ()-swapTime source target = do-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  slvl <- getsState $ getLocalTime (blid sb)-  tlvl <- getsState $ getLocalTime (blid tb)-  let lvlDelta = slvl `timeDeltaToFrom` tlvl-      bDelta = btime sb `timeDeltaToFrom` btime tb-      sdelta = timeDeltaSubtract lvlDelta bDelta-      tdelta = timeDeltaReverse sdelta-  -- Equivalent, for the assert:-  let !_A = let sbodyDelta = btime sb `timeDeltaToFrom` slvl-                tbodyDelta = btime tb `timeDeltaToFrom` tlvl-                sgoal = slvl `timeShift` tbodyDelta-                tgoal = tlvl `timeShift` sbodyDelta-                sdelta' = sgoal `timeDeltaToFrom` btime sb-                tdelta' = tgoal `timeDeltaToFrom` btime tb-            in assert (sdelta == sdelta' && tdelta == tdelta'-                      `blame` ( slvl, tlvl, btime sb, btime tb-                              , sdelta, sdelta', tdelta, tdelta' )) ()-  when (sdelta /= Delta timeZero) $ execUpdAtomic $ UpdAgeActor source sdelta-  when (tdelta /= Delta timeZero) $ execUpdAtomic $ UpdAgeActor target tdelta---- | Check if the given actor is dominated and update his calm.--- We don't update calm once per game turn (even though--- it would make fast actors less overpowered),--- beucase the effects of close enemies would sometimes manifest only after--- a couple of player turns (or perhaps never at all, if the player and enemy--- move away before that moment). A side effect is that under peaceful--- circumstances, non-max calm causes a consistent Calm regeneration--- UI indicator to be displayed each turn (not every few turns).-managePerTurn :: (MonadAtomic m, MonadServer m) => ActorId -> m ()-managePerTurn aid = do-  b <- getsState $ getActorBody aid-  unless (bproj b) $ do-    activeItems <- activeItemsServer aid-    fact <- getsState $ (EM.! bfid b) . sfactionD-    dominated <--      -- We react one turn after bcalm reaches 0, to let it be-      -- displayed first, to let the player panic in advance-      -- and also to avoid the dramatic domination message-      -- be swamped in other enemy turn messages.-      if bcalm b == 0-         && bfidImpressed b /= bfid b-         && fleaderMode (gplayer fact) /= LeaderNull-              -- animals/robots never Calm-dominated-      then dominateFidSfx (bfidImpressed b) aid-      else return False-    unless dominated $ do-      newCalmDelta <- getsState $ regenCalmDelta b activeItems-      let clearMark = 0-      unless (newCalmDelta == 0) $-        -- Update delta for the current player turn.-        udpateCalm aid newCalmDelta-      unless (bcalmDelta b == ResDelta 0 0) $-        -- Clear delta for the next player turn.-        execUpdAtomic $ UpdRefillCalm aid clearMark-      unless (bhpDelta b == ResDelta 0 0) $-        -- Clear delta for the next player turn.-        execUpdAtomic $ UpdRefillHP aid clearMark--udpateCalm :: (MonadAtomic m, MonadServer m) => ActorId -> Int64 -> m ()-udpateCalm target deltaCalm = do-  tb <- getsState $ getActorBody target-  activeItems <- activeItemsServer target-  let calmMax64 = xM $ sumSlotNoFilter IK.EqpSlotAddMaxCalm activeItems-  execUpdAtomic $ UpdRefillCalm target deltaCalm-  when (bcalm tb < calmMax64-        && bcalm tb + deltaCalm >= calmMax64-        && bfidImpressed tb /= bfidOriginal tb) $-    execUpdAtomic $-      UpdFidImpressedActor target (bfidImpressed tb) (bfidOriginal tb)--leadLevelSwitch :: (MonadAtomic m, MonadServer m) => m ()-leadLevelSwitch = do-  Kind.COps{cotile} <- getsState scops-  let canSwitch fact = fst (autoDungeonLevel fact)-                       -- a hack to help AI, until AI client can switch levels-                       || case fleaderMode (gplayer fact) of-                            LeaderNull -> False-                            LeaderAI _ -> True-                            LeaderUI _ -> False-      flipFaction fact | not $ canSwitch fact = return ()-      flipFaction fact =-        case gleader fact of-          Nothing -> return ()-          Just (leader, _) -> do-            body <- getsState $ getActorBody leader-            lvl2 <- getLevel $ blid body-            let leaderStuck = waitedLastTurn body-                t = lvl2 `at` bpos body-            -- Keep the leader: he is on stairs and not stuck-            -- and we don't want to clog stairs or get pushed to another level.-            unless (not leaderStuck && Tile.isStair cotile t) $ do-              actorD <- getsState sactorD-              let ourLvl (lid, lvl) =-                    ( lid-                    , EM.size (lfloor lvl)-                    , -- Drama levels skipped, hence @Regular@.-                      actorRegularAssocsLvl (== bfid body) lvl actorD )-              ours <- getsState $ map ourLvl . EM.assocs . sdungeon-              -- Non-humans, being born in the dungeon, have a rough idea of-              -- the number of items left on the level and will focus-              -- on levels they started exploring and that have few items-              -- left. This is to to explore them completely, leave them-              -- once and for all and concentrate forces on another level.-              -- In addition, sole stranded actors tend to become leaders-              -- so that they can join the main force ASAP.-              let freqList = [ (k, (lid, a))-                             | (lid, itemN, (a, _) : rest) <- ours-                             , not leaderStuck || lid /= blid body-                             , let len = 1 + min 10 (length rest)-                                   k = 1000000 `div` (3 * itemN + len) ]-              unless (null freqList) $ do-                (lid, a) <- rndToAction $ frequency-                                        $ toFreq "leadLevel" freqList-                unless (lid == blid body) $  -- flip levels rather than actors-                  execUpdAtomic-                  $ UpdLeadFaction (bfid body) (gleader fact)-                                               (Just (a, Nothing))-  factionD <- getsState sfactionD-  mapM_ flipFaction $ EM.elems factionD

+ Game/LambdaHack/Server/ProtocolM.hs view

@@ -0,0 +1,201 @@+-- | The server definitions for the server-client communication protocol.+module Game.LambdaHack.Server.ProtocolM+  ( -- * The communication channels+    ConnServerDict+    -- * The server-client communication monad+  , MonadServerReadRequest+      ( getsDict  -- exposed only to be implemented, not used+      , modifyDict  -- exposed only to be implemented, not used+      , liftIO  -- exposed only to be implemented, not used+      )+    -- * Protocol+  , putDict, sendUpdate, sendSfx, sendQueryAI, sendQueryUI+    -- * Assorted+  , killAllClients, childrenServer, updateConn, tryRestore+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Control.Concurrent+import Control.Concurrent.Async+import qualified Data.EnumMap.Strict as EM+import Data.Key (mapWithKeyM, mapWithKeyM_)+import System.FilePath+import System.IO.Unsafe (unsafePerformIO)++import Game.LambdaHack.Atomic+import Game.LambdaHack.Client.UI (Config, SessionUI, emptySessionUI)+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ClientOptions+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.File+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.Response+import qualified Game.LambdaHack.Common.Save as Save+import Game.LambdaHack.Common.State+import Game.LambdaHack.Common.Thread+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Server.DebugM+import Game.LambdaHack.Server.MonadServer hiding (liftIO)+import Game.LambdaHack.Server.State++writeQueue :: MonadServerReadRequest m+           => Response -> CliSerQueue Response -> m ()+{-# INLINE writeQueue #-}+writeQueue cmd responseS = liftIO $ putMVar responseS cmd++readQueueAI :: MonadServerReadRequest m+            => CliSerQueue RequestAI+            -> m RequestAI+{-# INLINE readQueueAI #-}+readQueueAI requestS = liftIO $ takeMVar requestS++readQueueUI :: MonadServerReadRequest m+            => CliSerQueue RequestUI+            -> m RequestUI+{-# INLINE readQueueUI #-}+readQueueUI requestS = liftIO $ takeMVar requestS++newQueue :: IO (CliSerQueue a)+newQueue = newEmptyMVar++tryRestore :: MonadServerReadRequest m+           => Kind.COps -> DebugModeSer+           -> m (Maybe (State, StateServer))+tryRestore cops@Kind.COps{corule} sdebugSer = do+  let bench = sbenchmark $ sdebugCli sdebugSer+  if bench then return Nothing+  else do+    let prefix = ssavePrefixSer sdebugSer+        fileName = prefix <.> Save.saveNameSer+    res <- liftIO $ Save.restoreGame cops fileName+    let stdRuleset = Kind.stdRuleset corule+        cfgUIName = rcfgUIName stdRuleset+        content = rcfgUIDefault stdRuleset+    dataDir <- liftIO appDataDir+    liftIO $ tryWriteFile (dataDir </> cfgUIName) content+    return $! res++-- | Connection information for all factions, indexed by faction identifier.+type ConnServerDict = EM.EnumMap FactionId ChanServer++-- | The server monad with the ability to communicate with clients.+class MonadServer m => MonadServerReadRequest m where+  getsDict     :: (ConnServerDict -> a) -> m a+  modifyDict   :: (ConnServerDict -> ConnServerDict) -> m ()+  liftIO       :: IO a -> m a++getDict :: MonadServerReadRequest m => m ConnServerDict+getDict = getsDict id++putDict :: MonadServerReadRequest m => ConnServerDict -> m ()+putDict s = modifyDict (const s)++sendUpdate :: MonadServerReadRequest m => FactionId -> UpdAtomic -> m ()+sendUpdate !fid !cmd = do+  chan <- getsDict (EM.! fid)+  let resp = RespUpdAtomic cmd+  debug <- getsServer $ sniffOut . sdebugSer+  when debug $ debugResponse fid resp+  writeQueue resp $ responseS chan++sendSfx :: MonadServerReadRequest m => FactionId -> SfxAtomic -> m ()+sendSfx !fid !sfx = do+  let resp = RespSfxAtomic sfx+  debug <- getsServer $ sniffOut . sdebugSer+  when debug $ debugResponse fid resp+  chan <- getsDict (EM.! fid)+  case chan of+    ChanServer{requestUIS=Just{}} -> writeQueue resp $ responseS chan+    _ -> return ()++sendQueryAI :: MonadServerReadRequest m => FactionId -> ActorId -> m RequestAI+sendQueryAI fid aid = do+  let respAI = RespQueryAI aid+  debug <- getsServer $ sniffOut . sdebugSer+  when debug $ debugResponse fid respAI+  chan <- getsDict (EM.! fid)+  req <- do+    writeQueue respAI $ responseS chan+    readQueueAI $ requestAIS chan+  when debug $ debugRequestAI aid req+  return req++sendQueryUI :: (MonadAtomic m, MonadServerReadRequest m)+            => FactionId -> ActorId -> m RequestUI+sendQueryUI fid _aid = do+  let respUI = RespQueryUI+  debug <- getsServer $ sniffOut . sdebugSer+  when debug $ debugResponse fid respUI+  chan <- getsDict (EM.! fid)+  req <- do+    writeQueue respUI $ responseS chan+    readQueueUI $ fromJust $ requestUIS chan+  when debug $ debugRequestUI _aid req+  return req++killAllClients :: (MonadAtomic m, MonadServerReadRequest m) => m ()+killAllClients = do+  d <- getDict+  let sendKill fid _ =+        -- We can't check in sfactionD, because client can be from an old game.+        sendUpdate fid $ UpdKillExit fid+  mapWithKeyM_ sendKill d++-- Global variable for all children threads of the server.+childrenServer :: MVar [Async ()]+{-# NOINLINE childrenServer #-}+childrenServer = unsafePerformIO (newMVar [])++-- | Update connections to the new definition of factions.+-- Connect to clients in old or newly spawned threads+-- that read and write directly to the channels.+updateConn :: (MonadAtomic m, MonadServerReadRequest m)+           => Kind.COps+           -> Config+           -> (Maybe SessionUI -> Kind.COps -> FactionId -> ChanServer+               -> IO ())+           -> m ()+updateConn cops sconfig executorClient = do+  -- Prepare connections based on factions.+  oldD <- getDict+  let sess = emptySessionUI sconfig+      mkChanServer :: Faction -> IO ChanServer+      mkChanServer fact = do+        responseS <- newQueue+        requestAIS <- newQueue+        requestUIS <- if fhasUI $ gplayer fact+                      then Just <$> newQueue+                      else return Nothing+        return $! ChanServer{..}+      addConn :: FactionId -> Faction -> IO ChanServer+      addConn fid fact = case EM.lookup fid oldD of+        Just conns -> return conns  -- share old conns and threads+        Nothing -> mkChanServer fact+  factionD <- getsState sfactionD+  d <- liftIO $ mapWithKeyM addConn factionD+  let newD = d `EM.union` oldD  -- never kill old clients+  putDict newD+  -- Spawn client threads.+  let toSpawn = newD EM.\\ oldD+      forkUI fid connS =+        forkChild childrenServer $ executorClient (Just sess) cops fid connS+      forkAI fid connS =+        forkChild childrenServer $ executorClient Nothing cops fid connS+      forkClient fid conn@ChanServer{requestUIS=Nothing} =+        -- When a connection is reused, clients are not respawned,+        -- even if UI usage changes, but it works OK thanks to UI faction+        -- clients distinguished by positive FactionId numbers.+        forkAI fid conn+      forkClient fid conn =+        forkUI fid conn+  liftIO $ mapWithKeyM_ forkClient toSpawn

− Game/LambdaHack/Server/ProtocolServer.hs

@@ -1,225 +0,0 @@-{-# LANGUAGE CPP #-}--- | The server definitions for the server-client communication protocol.-module Game.LambdaHack.Server.ProtocolServer-  ( -- * The communication channels-    ChanServer(..)-  , ConnServerDict  -- exposed only to be implemented, not used-    -- * The server-client communication monad-  , MonadServerReadRequest-      ( getDict  -- exposed only to be implemented, not used-      , getsDict  -- exposed only to be implemented, not used-      , modifyDict  -- exposed only to be implemented, not used-      , putDict  -- exposed only to be implemented, not used-      , liftIO  -- exposed only to be implemented, not used-      )-    -- * Protocol-  , sendUpdateAI, sendQueryAI, sendPingAI-  , sendUpdateUI, sendQueryUI, sendPingUI-    -- * Assorted-  , killAllClients, childrenServer, updateConn-#ifdef EXPOSE_INTERNAL-    -- * Internal operations-  , ConnServerFaction-#endif-  ) where--import Control.Concurrent-import Control.Concurrent.Async-import Control.Concurrent.STM (TQueue, atomically)-import qualified Control.Concurrent.STM as STM-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.Key (mapWithKeyM, mapWithKeyM_)-import Data.Maybe-import Game.LambdaHack.Common.Thread-import System.IO.Unsafe (unsafePerformIO)--import Game.LambdaHack.Atomic-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.Response-import Game.LambdaHack.Common.State-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Server.DebugServer-import Game.LambdaHack.Server.MonadServer hiding (liftIO)-import Game.LambdaHack.Server.State---- | Connection channel between the server and a single client.-data ChanServer resp req = ChanServer-  { responseS :: !(TQueue resp)-  , requestS  :: !(TQueue req)-  }---- | Connections to the human-controlled client of a faction and--- to the AI client for the same faction.-type ConnServerFaction = ( Maybe (ChanServer ResponseUI RequestUI)-                         , ChanServer ResponseAI RequestAI )---- | Connection information for all factions, indexed by faction identifier.-type ConnServerDict = EM.EnumMap FactionId ConnServerFaction---- TODO: refactor so that the monad is split in 2 and looks analogously--- to the Client monads. Restrict the Dict to implementation modules.--- Then on top of that implement sendQueryAI, etc.--- For now we call it MonadServerReadRequest--- though it also has the functionality of MonadServerWriteResponse.---- | The server monad with the ability to communicate with clients.-class MonadServer m => MonadServerReadRequest m where-  getDict      :: m ConnServerDict-  getsDict     :: (ConnServerDict -> a) -> m a-  modifyDict   :: (ConnServerDict -> ConnServerDict) -> m ()-  putDict      :: ConnServerDict -> m ()-  liftIO       :: IO a -> m a--writeTQueueAI :: MonadServerReadRequest m-              => ResponseAI -> TQueue ResponseAI -> m ()-writeTQueueAI cmd responseS = do-  debug <- getsServer $ sniffOut . sdebugSer-  when debug $ debugResponseAI cmd-  liftIO $ atomically $ STM.writeTQueue responseS cmd--writeTQueueUI :: MonadServerReadRequest m-              => ResponseUI -> TQueue ResponseUI -> m ()-writeTQueueUI cmd responseS = do-  debug <- getsServer $ sniffOut . sdebugSer-  when debug $ debugResponseUI cmd-  liftIO $ atomically $ STM.writeTQueue responseS cmd--readTQueueAI :: MonadServerReadRequest m-             => TQueue RequestAI -> m RequestAI-readTQueueAI requestS = liftIO $ atomically $ STM.readTQueue requestS--readTQueueUI :: MonadServerReadRequest m-             => TQueue RequestUI -> m RequestUI-readTQueueUI requestS = liftIO $ atomically $ STM.readTQueue requestS--sendUpdateAI :: MonadServerReadRequest m-             => FactionId -> ResponseAI -> m ()-sendUpdateAI fid cmd = do-  conn <- getsDict $ snd . (EM.! fid)-  writeTQueueAI cmd $ responseS conn--sendQueryAI :: MonadServerReadRequest m-            => FactionId -> ActorId -> m RequestAI-sendQueryAI fid aid = do-  conn <- getsDict $ snd . (EM.! fid)-  writeTQueueAI (RespQueryAI aid) $ responseS conn-  req <- readTQueueAI $ requestS conn-  debug <- getsServer $ sniffIn . sdebugSer-  when debug $ debugRequestAI aid req-  return $! req--sendPingAI :: (MonadAtomic m, MonadServerReadRequest m)-           => FactionId -> m ()-sendPingAI fid = do-  conn <- getsDict $ snd . (EM.! fid)-  writeTQueueAI RespPingAI $ responseS conn-  -- debugPrint $ "AI client" <+> tshow fid <+> "pinged..."-  cmdPong <- readTQueueAI $ requestS conn-  -- debugPrint $ "AI client" <+> tshow fid <+> "responded."-  case cmdPong of-    ReqAIPong -> return ()-    _ -> assert `failure` (fid, cmdPong)--sendUpdateUI :: MonadServerReadRequest m-             => FactionId -> ResponseUI -> m ()-sendUpdateUI fid cmd = do-  cs <- getsDict $ fst . (EM.! fid)-  case cs of-    Nothing -> assert `failure` "no channel for faction" `twith` fid-    Just conn ->-      writeTQueueUI cmd $ responseS conn--sendQueryUI :: (MonadAtomic m, MonadServerReadRequest m)-            => FactionId -> ActorId -> m RequestUI-sendQueryUI fid aid = do-  cs <- getsDict $ fst . (EM.! fid)-  case cs of-    Nothing -> assert `failure` "no channel for faction" `twith` fid-    Just conn -> do-      writeTQueueUI RespQueryUI $ responseS conn-      req <- readTQueueUI $ requestS conn-      debug <- getsServer $ sniffIn . sdebugSer-      when debug $ debugRequestUI aid req-      return $! req--sendPingUI :: (MonadAtomic m, MonadServerReadRequest m)-           => FactionId -> m ()-sendPingUI fid = do-  cs <- getsDict $ fst . (EM.! fid)-  case cs of-    Nothing -> assert `failure` "no channel for faction" `twith` fid-    Just conn -> do-      writeTQueueUI RespPingUI $ responseS conn-      -- debugPrint $ "UI client" <+> tshow fid <+> "pinged..."-      cmdPong <- readTQueueUI $ requestS conn-      -- debugPrint $ "UI client" <+> tshow fid <+> "responded."-      case cmdPong of-        ReqUIPong ats -> mapM_ execAtomic ats-        _ -> assert `failure` (fid, cmdPong)--killAllClients :: (MonadAtomic m, MonadServerReadRequest m) => m ()-killAllClients = do-  d <- getDict-  let sendKill fid cs = do-        -- We can't check in sfactionD, because client can be from an old game.-        when (isJust $ fst cs) $-          sendUpdateUI fid $ RespUpdAtomicUI $ UpdKillExit fid-        sendUpdateAI fid $ RespUpdAtomicAI $ UpdKillExit fid-  mapWithKeyM_ sendKill d---- Global variable for all children threads of the server.-childrenServer :: MVar [Async ()]-{-# NOINLINE childrenServer #-}-childrenServer = unsafePerformIO (newMVar [])---- | Update connections to the new definition of factions.--- Connect to clients in old or newly spawned threads--- that read and write directly to the channels.-updateConn :: (MonadAtomic m, MonadServerReadRequest m)-           => (FactionId-               -> ChanServer ResponseUI RequestUI-               -> IO ())-           -> (FactionId-               -> ChanServer ResponseAI RequestAI-               -> IO ())-           -> m ()-updateConn executorUI executorAI = do-  -- Prepare connections based on factions.-  oldD <- getDict-  let mkChanServer :: IO (ChanServer resp req)-      mkChanServer = do-        responseS <- STM.newTQueueIO-        requestS <- STM.newTQueueIO-        return $! ChanServer{..}-      addConn :: FactionId -> Faction -> IO ConnServerFaction-      addConn fid fact = case EM.lookup fid oldD of-        Just conns -> return conns  -- share old conns and threads-        Nothing | fhasUI $ gplayer fact -> do-          connS <- mkChanServer-          connAI <- mkChanServer-          return (Just connS, connAI)-        Nothing -> do-          connAI <- mkChanServer-          return (Nothing, connAI)-  factionD <- getsState sfactionD-  d <- liftIO $ mapWithKeyM addConn factionD-  let newD = d `EM.union` oldD  -- never kill old clients-  putDict newD-  -- Spawn client threads.-  let toSpawn = newD EM.\\ oldD-  let forkUI fid connS =-        forkChild childrenServer $ executorUI fid connS-      forkAI fid connS =-        forkChild childrenServer $ executorAI fid connS-      forkClient fid (connUI, connAI) = do-        -- When a connection is reused, clients are not respawned,-        -- even if UI usage changes, but it works OK thanks to UI faction-        -- clients distinguished by positive FactionId numbers.-        forkAI fid connAI  -- AI clients always needed, e.g., for auto-explore-        maybe (return ()) (forkUI fid) connUI-  liftIO $ mapWithKeyM_ forkClient toSpawn

+ Game/LambdaHack/Server/StartM.hs view

@@ -0,0 +1,351 @@+-- | Operations for starting and restarting the game.+module Game.LambdaHack.Server.StartM+  ( gameReset, reinitGame, updatePer, initPer, applyDebug+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Control.Arrow (first)+import qualified Control.Monad.Trans.State.Strict as St+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.IntMap.Strict as IM+import Data.Key (mapWithKeyM_)+import qualified Data.Map.Strict as M+import Data.Ord+import qualified Data.Text as T+import Data.Tuple (swap)+import qualified NLP.Miniutter.English as MU+import qualified System.Random as R++import Game.LambdaHack.Atomic+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.ClientOptions+import qualified Game.LambdaHack.Common.Color as Color+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Flavour+import qualified Game.LambdaHack.Common.HighScore as HighScore+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Perception+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import qualified Game.LambdaHack.Content.ItemKind as IK+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Server.CommonM+import qualified Game.LambdaHack.Server.DungeonGen as DungeonGen+import Game.LambdaHack.Server.Fov+import Game.LambdaHack.Server.ItemM+import Game.LambdaHack.Server.ItemRev+import Game.LambdaHack.Server.MonadServer+import Game.LambdaHack.Server.State++initPer :: MonadServer m => m ()+initPer = do+  discoAspect <- getsServer sdiscoAspect+  ( sactorAspect, sfovLitLid, sfovClearLid, sfovLucidLid+   ,sperValidFid, sperCacheFid, sperFid )+    <- getsState $ perFidInDungeon discoAspect+  modifyServer $ \ser ->+    ser { sactorAspect, sfovLitLid, sfovClearLid, sfovLucidLid+        , sperValidFid, sperCacheFid, sperFid }++reinitGame :: (MonadAtomic m, MonadServer m) => m ()+reinitGame = do+  Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops+  pers <- getsServer sperFid+  DebugModeSer{scurChalSer, sknowMap, sdebugCli} <- getsServer sdebugSer+  -- This state is quite small, fit for transmition to the client.+  -- The biggest part is content, which needs to be updated+  -- at this point to keep clients in sync with server improvements.+  s <- getState+  let defLocal | sknowMap = s+               | otherwise = localFromGlobal s+  discoS <- getsServer sdiscoKind+  let sdiscoKind =+        let f KindMean{kmKind} = IK.Identified `elem` IK.ifeature (okind kmKind)+        in EM.filter f discoS+      updRestart fid = UpdRestart fid sdiscoKind (pers EM.! fid) defLocal+                                  scurChalSer sdebugCli+  factionD <- getsState sfactionD+  mapWithKeyM_ (\fid _ -> execUpdAtomic $ updRestart fid) factionD+  dungeon <- getsState sdungeon+  let sactorTime = EM.map (const (EM.map (const EM.empty) dungeon)) factionD+  modifyServer $ \ser -> ser {sactorTime}+  populateDungeon+  mapM_ (\fid -> mapM_ (updatePer fid) (EM.keys dungeon))+        (EM.keys factionD)+  execUpdAtomic $ UpdMsgAll "SortSlots"  -- hack++updatePer :: (MonadAtomic m, MonadServer m) => FactionId -> LevelId -> m ()+{-# INLINE updatePer #-}+updatePer fid lid = do+  modifyServer $ \ser ->+    ser {sperValidFid = EM.adjust (EM.insert lid True) fid $ sperValidFid ser}+  sperFidOld <- getsServer sperFid+  let perOld = sperFidOld EM.! fid EM.! lid+  knowEvents <- getsServer $ sknowEvents . sdebugSer+  -- Performed in the State after action, e.g., with a new actor.+  perNew <- recomputeCachePer fid lid+  let inPer = diffPer perNew perOld+      outPer = diffPer perOld perNew+  unless (nullPer outPer && nullPer inPer) $+    unless knowEvents $  -- inconsistencies would quickly manifest+      execSendPer fid lid outPer inPer perNew++mapFromFuns :: (Bounded a, Enum a, Ord b) => [a -> b] -> M.Map b a+mapFromFuns =+  let fromFun f m1 =+        let invAssocs = map (\c -> (f c, c)) [minBound..maxBound]+            m2 = M.fromList invAssocs+        in m2 `M.union` m1+  in foldr fromFun M.empty++resetFactions :: FactionDict -> Kind.Id ModeKind -> Int -> AbsDepth -> Roster+              -> Rnd FactionDict+resetFactions factionDold gameModeIdOld curDiffSerOld totalDepth players = do+  let rawCreate (gplayer@Player{..}, initialActors) = do+        let castInitialActors (ln, d, actorGroup) = do+              n <- castDice (AbsDepth $ abs ln) totalDepth d+              return (ln, n, actorGroup)+        ginitial <- mapM castInitialActors initialActors+        let cmap =+              mapFromFuns [colorToTeamName, colorToPlainName, colorToFancyName]+            colorName = T.toLower $ head $ T.words fname+            prefix = case fleaderMode of+              LeaderNull -> "Loose"+              LeaderAI _ -> "Autonomous"+              LeaderUI _ -> "Controlled"+            gnameNew = prefix <+> if fhasGender+                                  then makePhrase [MU.Ws $ MU.Text fname]+                                  else fname+            gcolor = M.findWithDefault Color.BrWhite colorName cmap+            gvictimsDnew = case find (\fact -> gname fact == gnameNew)+                                $ EM.elems factionDold of+              Nothing -> EM.empty+              Just fact ->+                let sing = IM.singleton curDiffSerOld (gvictims fact)+                    f = IM.unionWith (EM.unionWith (+))+                in EM.insertWith f gameModeIdOld sing $ gvictimsD fact+        let gname = gnameNew+            gdipl = EM.empty  -- fixed below+            gquit = Nothing+            _gleader = Nothing+            gvictims = EM.empty+            gvictimsD = gvictimsDnew+            gsha = EM.empty+        return $! Faction{..}+  lUI <- mapM rawCreate $ filter (fhasUI . fst) $ rosterList players+  let !_A = assert (length lUI <= 1+                    `blame` "currently, at most one faction may have a UI"+                    `twith` lUI) ()+  lnoUI <- mapM rawCreate $ filter (not . fhasUI . fst) $ rosterList players+  let lFs = reverse (zip [toEnum (-1), toEnum (-2)..] lnoUI)  -- sorted+            ++ zip [toEnum 1..] lUI+      swapIx l =+        let findPlayerName name = find ((name ==) . fname . gplayer . snd)+            f (name1, name2) =+              case (findPlayerName name1 lFs, findPlayerName name2 lFs) of+                (Just (ix1, _), Just (ix2, _)) -> (ix1, ix2)+                _ -> assert `failure` "unknown faction"+                            `twith` ((name1, name2), lFs)+            ixs = map f l+        -- Only symmetry is ensured, everything else is permitted, e.g.,+        -- a faction in alliance with two others that are at war.+        in ixs ++ map swap ixs+      mkDipl diplMode =+        let f (ix1, ix2) =+              let adj fact = fact {gdipl = EM.insert ix2 diplMode (gdipl fact)}+              in EM.adjust adj ix1+        in foldr f+      rawFs = EM.fromDistinctAscList lFs+      -- War overrides alliance, so 'warFs' second.+      allianceFs = mkDipl Alliance rawFs (swapIx (rosterAlly players))+      warFs = mkDipl War allianceFs (swapIx (rosterEnemy players))+  return $! warFs++gameReset :: MonadServer m+          => Kind.COps -> DebugModeSer -> Maybe (GroupName ModeKind)+          -> Maybe R.StdGen -> m State+gameReset cops@Kind.COps{comode=Kind.Ops{opick, okind}}+          sdebug mGameMode mrandom = do+  -- Dungeon seed generation has to come first, to ensure item boosting+  -- is determined by the dungeon RNG.+  dungeonSeed <- getSetGen $ sdungeonRng sdebug `mplus` mrandom+  srandom <- getSetGen $ smainRng sdebug `mplus` mrandom+  let srngs = RNGs (Just dungeonSeed) (Just srandom)+  when (sdumpInitRngs sdebug) $ dumpRngs srngs+  scoreTable <- if sfrontendNull $ sdebugCli sdebug then+                  return HighScore.empty+                else+                  restoreScore cops+  factionDold <- getsState sfactionD+  gameModeIdOld <- getsState sgameModeId+  curChalSer <- getsServer $ scurChalSer . sdebugSer+#ifdef USE_BROWSER+  let startingModeGroup = "starting JS"+#else+  let startingModeGroup = "starting"+#endif+      gameMode = fromMaybe startingModeGroup+                 $ mGameMode `mplus` sgameMode sdebug+      rnd :: Rnd (FactionDict, FlavourMap, DiscoveryKind, DiscoveryKindRev,+                  DungeonGen.FreshDungeon, Kind.Id ModeKind)+      rnd = do+        modeKindId <- fromMaybe (assert `failure` gameMode)+                      <$> opick gameMode (const True)+        let mode = okind modeKindId+            automatePS ps = ps {rosterList =+              map (first $ automatePlayer True) $ rosterList ps}+            players = if sautomateAll sdebug+                      then automatePS $ mroster mode+                      else mroster mode+        sflavour <- dungeonFlavourMap cops+        (sdiscoKind, sdiscoKindRev) <- serverDiscos cops+        freshDng <- DungeonGen.dungeonGen cops $ mcaves mode+        factionD <- resetFactions factionDold gameModeIdOld+                                  (cdiff curChalSer)+                                  (DungeonGen.freshTotalDepth freshDng)+                                  players+        return ( factionD, sflavour, sdiscoKind+               , sdiscoKindRev, freshDng, modeKindId )+  let ( factionD, sflavour, sdiscoKind+       ,sdiscoKindRev, DungeonGen.FreshDungeon{..}, modeKindId ) =+        St.evalState rnd dungeonSeed+      defState = defStateGlobal freshDungeon freshTotalDepth+                                factionD cops scoreTable modeKindId+      defSer = emptyStateServer { srandom+                                , srngs }+  putServer defSer+  modifyServer $ \ser -> ser {sdiscoKind, sdiscoKindRev, sflavour}+  return $! defState++-- Spawn initial actors. Clients should notice this, to set their leaders.+populateDungeon :: (MonadAtomic m, MonadServer m) => m ()+populateDungeon = do+  cops@Kind.COps{coTileSpeedup} <- getsState scops+  placeItemsInDungeon+  embedItemsInDungeon+  dungeon <- getsState sdungeon+  factionD <- getsState sfactionD+  curChalSer <- getsServer $ scurChalSer . sdebugSer+  let ginitialWolf fact1 = if cwolf curChalSer && fhasUI (gplayer fact1)+                           then case ginitial fact1 of+                             [] -> []+                             (ln, _, grp) : _ -> [(ln, 1, grp)]+                           else ginitial fact1+      (minD, maxD) =+        case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of+          (Just ((s, _), _), Just ((e, _), _)) -> (s, e)+          _ -> assert `failure` "empty dungeon" `twith` dungeon+      -- Players that escape go first to be started over stairs, if possible.+      valuePlayer pl = (not $ fcanEscape pl, fname pl)+      -- Sorting, to keep games from similar game modes mutually reproducible.+      needInitialCrew = sortBy (comparing $ valuePlayer . gplayer . snd)+                        $ filter (not . null . ginitialWolf . snd)+                        $ EM.assocs factionD+      g (ln, _, _) = max minD . min maxD . toEnum $ ln+      getEntryLevels (_, fact) = map g $ ginitialWolf fact+      arenas = ES.toList $ ES.fromList+               $ concatMap getEntryLevels needInitialCrew+      hasActorsOnArena lid (_, fact) =+        any ((== lid) . g) $ ginitialWolf fact+      initialActors lid = do+        lvl <- getLevel lid+        let arenaFactions = filter (hasActorsOnArena lid) needInitialCrew+            indexff (fid, _) = findIndex ((== fid) . fst) arenaFactions+            representsAlliance ff2@(_, fact2) =+              not $ any (\ff3@(fid3, _) ->+                           indexff ff3 < indexff ff2+                           && isAllied fact2 fid3) arenaFactions+            arenaAlliances = filter representsAlliance arenaFactions+            placeAlliance ((fid3, _), ppos, timeOffset) =+              mapM_ (\(fid4, fact4) ->+                      when (isAllied fact4 fid3 || fid4 == fid3) $+                        placeActors lid ((fid4, fact4), ppos, timeOffset))+                    arenaFactions+        entryPoss <- rndToAction+                     $ findEntryPoss cops lid lvl (length arenaAlliances)+        mapM_ placeAlliance $ zip3 arenaAlliances entryPoss [0..]+      placeActors lid ((fid3, fact3), ppos, timeOffset) = do+        localTime <- getsState $ getLocalTime lid+        let clipInTurn = timeTurn `timeFit` timeClip+            nmult = 1 + timeOffset `mod` clipInTurn+            ntime = timeShift localTime (timeDeltaScale (Delta timeClip) nmult)+            validTile t = not $ Tile.isNoActor coTileSpeedup t+            initActors = ginitialWolf fact3+            initGroups = concat [ replicate n actorGroup+                                | ln3@(_, n, actorGroup) <- initActors+                                , g ln3 == lid ]+        psFree <- getsState $ nearbyFreePoints validTile ppos lid+        let ps = zip initGroups psFree+        forM_ ps $ \ (actorGroup, p) -> do+          maid <- addActor actorGroup fid3 p lid id ntime+          case maid of+            Nothing -> assert `failure` "can't spawn initial actors"+                              `twith` (lid, (fid3, fact3))+            Just aid -> do+              mleader <- getsState $ _gleader . (EM.! fid3) . sfactionD+              when (isNothing mleader) $ supplantLeader fid3 aid+              return True+  mapM_ initialActors arenas++-- | Find starting postions for all factions. Try to make them distant+-- from each other. Place as many of the factions, as possible,+-- over stairs, starting from the end of the list, including placing the last+-- factions over escapes (we assume they are guardians of the escapes).+-- This implies the inital factions (if any) start far from escapes.+findEntryPoss :: Kind.COps -> LevelId -> Level -> Int -> Rnd [Point]+findEntryPoss Kind.COps{coTileSpeedup}+              lid Level{ltile, lxsize, lysize, lstair, lescape} k = do+  let factionDist = max lxsize lysize - 10+      dist poss cmin l _ = all (\pos -> chessDist l pos > cmin) poss+      tryFind _ 0 = return []+      tryFind ps n = do+        let ds = [ dist ps $ factionDist `div` 2+                 , dist ps $ factionDist `div` 3+                 , dist ps $ factionDist `div` 4+                 , dist ps $ factionDist `div` 6+                 ]+        np <- findPosTry2 1000 ltile  -- try really hard, for skirmish fairness+                (\_ t -> Tile.isWalkable coTileSpeedup t+                         && not (Tile.isNoActor coTileSpeedup t))+                ds+                (\_p t -> Tile.isOftenActor coTileSpeedup t)+                ds+        nps <- tryFind (np : ps) (n - 1)+        return $! np : nps+      -- Prefer deeper stairs to avoid spawners ambushing explorers.+      (deeperStairs, shallowerStairs) =+        (if fromEnum lid > 0 then id else swap) lstair+      stairPoss = if length deeperStairs > length shallowerStairs+                  then deeperStairs+                  else shallowerStairs+      middlePos = Point (lxsize `div` 2) (lysize `div` 2)+  let !_A = assert (k > 0 && factionDist > 0) ()+      onStairs = reverse $ take k $ lescape ++ stairPoss+      nk = k - length onStairs+  -- Starting in the middle is too easy.+  found <- tryFind (middlePos : onStairs) nk+  return $! found ++ onStairs++-- | Apply debug options that don't need a new game.+applyDebug :: MonadServer m => m ()+applyDebug = do+  DebugModeSer{..} <- getsServer sdebugNxt+  modifyServer $ \ser ->+    ser {sdebugSer = (sdebugSer ser) { sniffIn+                                     , sniffOut+                                     , sallClear+                                     , sdbgMsgSer+                                     , snewGameSer+                                     , sdumpInitRngs+                                     , sdebugCli }}

− Game/LambdaHack/Server/StartServer.hs

@@ -1,370 +0,0 @@--- | Operations for starting and restarting the game.-module Game.LambdaHack.Server.StartServer-  ( gameReset, reinitGame, initPer, recruitActors, applyDebug, initDebug-  ) where--import Control.Applicative-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Control.Monad.State as St-import qualified Data.Char as Char-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.List-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Ord-import Data.Text (Text)-import qualified Data.Text as T-import Data.Tuple (swap)-import qualified System.Random as R--import Game.LambdaHack.Atomic-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.ClientOptions-import qualified Game.LambdaHack.Common.Color as Color-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Flavour-import qualified Game.LambdaHack.Common.HighScore as HighScore-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.ItemKind (ItemKind)-import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.RuleKind-import qualified Game.LambdaHack.Content.TileKind as TK-import Game.LambdaHack.Server.CommonServer-import qualified Game.LambdaHack.Server.DungeonGen as DungeonGen-import Game.LambdaHack.Server.Fov-import Game.LambdaHack.Server.ItemRev-import Game.LambdaHack.Server.ItemServer-import Game.LambdaHack.Server.MonadServer-import Game.LambdaHack.Server.State--initPer :: MonadServer m => m ()-initPer = do-  fovMode <- getsServer $ sfovMode . sdebugSer-  ser <- getServer-  pers <- getsState $ \s -> dungeonPerception (fromMaybe Digital fovMode) s ser-  modifyServer $ \ser1 -> ser1 {sper = pers}--reinitGame :: (MonadAtomic m, MonadServer m) => m ()-reinitGame = do-  Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops-  pers <- getsServer sper-  DebugModeSer{scurDiffSer, sknowMap, sdebugCli} <- getsServer sdebugSer-  -- This state is quite small, fit for transmition to the client.-  -- The biggest part is content, which needs to be updated-  -- at this point to keep clients in sync with server improvements.-  s <- getState-  let defLocal | sknowMap = s-               | otherwise = localFromGlobal s-  discoS <- getsServer sdiscoKind-  let sdiscoKind = let f ik = IK.Identified `elem` IK.ifeature (okind ik)-               in EM.filter f discoS-  broadcastUpdAtomic-    $ \fid -> UpdRestart fid sdiscoKind (pers EM.! fid) defLocal scurDiffSer sdebugCli-  populateDungeon--mapFromFuns :: (Bounded a, Enum a, Ord b) => [a -> b] -> M.Map b a-mapFromFuns =-  let fromFun f m1 =-        let invAssocs = map (\c -> (f c, c)) [minBound..maxBound]-            m2 = M.fromList invAssocs-        in m2 `M.union` m1-  in foldr fromFun M.empty--lowercase :: Text -> Text-lowercase = T.pack . map Char.toLower . T.unpack--createFactions :: AbsDepth -> Roster -> Rnd FactionDict-createFactions totalDepth players = do-  let rawCreate Player{..} = do-        entryLevel <- castDice (AbsDepth 0) (AbsDepth 0) fentryLevel-        initialActors <- castDice (AbsDepth $ abs entryLevel) totalDepth-                                  finitialActors-        let gplayer = Player{ fentryLevel = entryLevel-                            , finitialActors = initialActors-                            , ..}-            cmap = mapFromFuns-                     [colorToTeamName, colorToPlainName, colorToFancyName]-            nameoc = lowercase $ head $ T.words fname-            prefix = case fleaderMode of-              LeaderNull -> "Loose"-              LeaderAI _ -> "Autonomous"-              LeaderUI _ -> "Controlled"-            (gcolor, gname) = case M.lookup nameoc cmap of-              Nothing -> (Color.BrWhite, prefix <+> fname)-              Just c -> (c, prefix <+> fname <+> "Team")-        let gdipl = EM.empty  -- fixed below-            gquit = Nothing-            gleader = Nothing-            gvictims = EM.empty-            gsha = EM.empty-        return $! Faction{..}-  lUI <- mapM rawCreate $ filter fhasUI $ rosterList players-  lnoUI <- mapM rawCreate $ filter (not . fhasUI) $ rosterList players-  let lFs = reverse (zip [toEnum (-1), toEnum (-2)..] lnoUI)  -- sorted-            ++ zip [toEnum 1..] lUI-      swapIx l =-        let findPlayerName name = find ((name ==) . fname . gplayer . snd)-            f (name1, name2) =-              case (findPlayerName name1 lFs, findPlayerName name2 lFs) of-                (Just (ix1, _), Just (ix2, _)) -> (ix1, ix2)-                _ -> assert `failure` "unknown faction"-                            `twith` ((name1, name2), lFs)-            ixs = map f l-        -- Only symmetry is ensured, everything else is permitted, e.g.,-        -- a faction in alliance with two others that are at war.-        in ixs ++ map swap ixs-      mkDipl diplMode =-        let f (ix1, ix2) =-              let adj fact = fact {gdipl = EM.insert ix2 diplMode (gdipl fact)}-              in EM.adjust adj ix1-        in foldr f-      rawFs = EM.fromDistinctAscList lFs-      -- War overrides alliance, so 'warFs' second.-      allianceFs = mkDipl Alliance rawFs (swapIx (rosterAlly players))-      warFs = mkDipl War allianceFs (swapIx (rosterEnemy players))-  return $! warFs--gameReset :: MonadServer m-          => Kind.COps -> DebugModeSer -> Maybe (GroupName ModeKind)-          -> Maybe R.StdGen -> m State-gameReset cops@Kind.COps{comode=Kind.Ops{opick, okind}}-          sdebug mGameMode mrandom = do-  dungeonSeed <- getSetGen $ sdungeonRng sdebug `mplus` mrandom-  srandom <- getSetGen $ smainRng sdebug `mplus` mrandom-  scoreTable <- if sfrontendNull $ sdebugCli sdebug then-                  return HighScore.empty-                else-                  restoreScore cops-  sstart <- getsServer sstart  -- copy over from previous game-  sallTime <- getsServer sallTime  -- copy over from previous game-  sheroNames <- getsServer sheroNames  -- copy over from previous game-  let gameMode = fromMaybe "starting" $ mGameMode `mplus` sgameMode sdebug-      rnd :: Rnd (FactionDict, FlavourMap, DiscoveryKind, DiscoveryKindRev,-                  DungeonGen.FreshDungeon, Kind.Id ModeKind)-      rnd = do-        modeKindId <- fromMaybe (assert `failure` gameMode)-                      <$> opick gameMode (const True)-        let mode = okind modeKindId-            automatePS ps = ps {rosterList =-                                  map (automatePlayer True) $ rosterList ps}-            players = if sautomateAll sdebug-                      then automatePS $ mroster mode-                      else mroster mode-        sflavour <- dungeonFlavourMap cops-        (sdiscoKind, sdiscoKindRev) <- serverDiscos cops-        freshDng <- DungeonGen.dungeonGen cops $ mcaves mode-        faction <- createFactions (DungeonGen.freshTotalDepth freshDng) players-        return (faction, sflavour, sdiscoKind, sdiscoKindRev, freshDng, modeKindId)-  let (faction, sflavour, sdiscoKind, sdiscoKindRev, DungeonGen.FreshDungeon{..}, modeKindId) =-        St.evalState rnd dungeonSeed-      defState = defStateGlobal freshDungeon freshTotalDepth-                                faction cops scoreTable modeKindId-      defSer = emptyStateServer { sstart, sallTime, sheroNames, srandom-                                , srngs = RNGs (Just dungeonSeed)-                                               (Just srandom) }-  putServer defSer-  when (sbenchmark $ sdebugCli sdebug) resetGameStart-  modifyServer $ \ser -> ser {sdiscoKind, sdiscoKindRev, sflavour}-  when (sdumpInitRngs sdebug) dumpRngs-  return $! defState---- Spawn initial actors. Clients should notice this, to set their leaders.-populateDungeon :: (MonadAtomic m, MonadServer m) => m ()-populateDungeon = do-  cops@Kind.COps{cotile} <- getsState scops-  placeItemsInDungeon-  embedItemsInDungeon-  dungeon <- getsState sdungeon-  factionD <- getsState sfactionD-  sheroNames <- getsServer sheroNames-  let (minD, maxD) =-        case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of-          (Just ((s, _), _), Just ((e, _), _)) -> (s, e)-          _ -> assert `failure` "empty dungeon" `twith` dungeon-      -- Players that escape go first to be started over stairs, if possible.-      valuePlayer pl = (not $ fcanEscape pl, fname pl)-      -- Sorting, to keep games from similar game modes mutually reproducible.-      needInitialCrew = sortBy (comparing $ valuePlayer . gplayer . snd)-                        $ filter ((> 0 ) . finitialActors . gplayer . snd)-                        $ EM.assocs factionD-      getEntryLevel (_, fact) =-        max minD $ min maxD $ toEnum $ fentryLevel $ gplayer fact-      arenas = ES.toList $ ES.fromList $ map getEntryLevel needInitialCrew-      initialActors lid = do-        lvl <- getLevel lid-        let arenaFactions = filter ((== lid) . getEntryLevel) needInitialCrew-            indexff (fid, _) = findIndex ((== fid) . fst) arenaFactions-            representsAlliance ff2@(_, fact2) =-              not $ any (\ff3@(fid3, _) ->-                           indexff ff3 < indexff ff2-                           && isAllied fact2 fid3) arenaFactions-            arenaAlliances = filter representsAlliance arenaFactions-            placeAlliance ((fid3, _), ppos, timeOffset) =-              mapM_ (\(fid4, fact4) ->-                      when (isAllied fact4 fid3 || fid4 == fid3) $-                        placeActors lid ((fid4, fact4), ppos, timeOffset))-                    arenaFactions-        entryPoss <- rndToAction-                     $ findEntryPoss cops lid lvl (length arenaAlliances)-        mapM_ placeAlliance $ zip3 arenaAlliances entryPoss [0..]-      placeActors lid ((fid3, fact3), ppos, timeOffset) = do-        time <- getsState $ getLocalTime lid-        let nmult = 1 + timeOffset `mod` 4-            ntime = timeShift time (timeDeltaScale (Delta timeClip) nmult)-            validTile t = not $ Tile.hasFeature cotile TK.NoActor t-        psFree <- getsState $ nearbyFreePoints validTile ppos lid-        let ps = take (finitialActors $ gplayer fact3) $ zip [0..] psFree-        forM_ ps $ \ (n, p) -> do-          go <--            if not $ fhasNumbers $ gplayer fact3-            then recruitActors [p] lid ntime fid3-            else do-              let hNames = EM.findWithDefault [] fid3 sheroNames-              maid <- addHero fid3 p lid hNames (Just n) ntime-              case maid of-                Nothing -> return False-                Just aid -> do-                  mleader <- getsState $ gleader . (EM.! fid3) . sfactionD-                  when (isNothing mleader) $-                    execUpdAtomic-                    $ UpdLeadFaction fid3 Nothing (Just (aid, Nothing))-                  return True-          unless go $ assert `failure` "can't spawn initial actors"-                             `twith` (lid, (fid3, fact3))-  mapM_ initialActors arenas---- | Spawn actors of any specified faction, friendly or not.--- To be used for initial dungeon population and for the summon effect.-recruitActors :: (MonadAtomic m, MonadServer m)-              => [Point] -> LevelId -> Time -> FactionId-              -> m Bool-recruitActors ps lid time fid = assert (not $ null ps) $ do-  fact <- getsState $ (EM.! fid) . sfactionD-  let spawnName = fgroup $ gplayer fact-  laid <- forM ps $ \ p ->-    if fhasNumbers $ gplayer fact-    then addHero fid p lid [] Nothing time-    else addMonster spawnName fid p lid time-  case catMaybes laid of-    [] -> return False-    aid : _ -> do-      mleader <- getsState $ gleader . (EM.! fid) . sfactionD  -- just changed-      when (isNothing mleader) $-        execUpdAtomic $ UpdLeadFaction fid Nothing (Just (aid, Nothing))-      return True---- | Create a new monster on the level, at a given position--- and with a given actor kind and HP.-addMonster :: (MonadAtomic m, MonadServer m)-           => GroupName ItemKind -> FactionId -> Point -> LevelId -> Time-           -> m (Maybe ActorId)-addMonster groupName bfid ppos lid time = do-  fact <- getsState $ (EM.! bfid) . sfactionD-  pronoun <- if fhasGender $ gplayer fact-             then rndToAction $ oneOf ["he", "she"]-             else return "it"-  addActor groupName bfid ppos lid id pronoun time---- | Create a new hero on the current level, close to the given position.-addHero :: (MonadAtomic m, MonadServer m)-        => FactionId -> Point -> LevelId -> [(Int, (Text, Text))]-        -> Maybe Int -> Time-        -> m (Maybe ActorId)-addHero bfid ppos lid heroNames mNumber time = do-  Faction{gcolor, gplayer} <- getsState $ (EM.! bfid) . sfactionD-  let groupName = fgroup gplayer-  mhs <- mapM (getsState . tryFindHeroK bfid) [0..9]-  let freeHeroK = elemIndex Nothing mhs-      n = fromMaybe (fromMaybe 100 freeHeroK) mNumber-      bsymbol = if n < 1 || n > 9 then '@' else Char.intToDigit n-      nameFromNumber 0 = ("Captain", "he")-      nameFromNumber k | k `mod` 7 == 0 = ("Heroine" <+> tshow k, "she")-      nameFromNumber k = ("Hero" <+> tshow k, "he")-      (bname, pronoun) | gcolor == Color.BrWhite =-        fromMaybe (nameFromNumber n) $ lookup n heroNames-                       | otherwise =-        let (nameN, pronounN) = nameFromNumber n-        in (fname gplayer <+> nameN, pronounN)-      tweakBody b = b {bsymbol, bname, bcolor = gcolor}-  addActor groupName bfid ppos lid tweakBody pronoun time---- | Find starting postions for all factions. Try to make them distant--- from each other. Place as many of the initial factions, as possible,--- over stairs and escapes.-findEntryPoss :: Kind.COps -> LevelId -> Level -> Int -> Rnd [Point]-findEntryPoss Kind.COps{cotile}-              lid Level{ltile, lxsize, lysize, lstair, lescape} k = do-  let factionDist = max lxsize lysize - 5-      dist poss cmin l _ = all (\pos -> chessDist l pos > cmin) poss-      tryFind _ 0 = return []-      tryFind ps n = do-        np <- findPosTry 1000 ltile  -- try really hard, for skirmish fairness-                (\_ t -> Tile.isWalkable cotile t-                         && not (Tile.hasFeature cotile TK.NoActor t))-                [ dist ps $ factionDist `div` 2-                , dist ps $ factionDist `div` 3-                , const (Tile.hasFeature cotile TK.OftenActor)-                , dist ps $ factionDist `div` 3-                , dist ps $ factionDist `div` 4-                , dist ps $ factionDist `div` 5-                , dist ps $ factionDist `div` 7-                , dist ps $ factionDist `div` 10-                ]-        nps <- tryFind (np : ps) (n - 1)-        return $! np : nps-      -- Prefer deeper stairs to avoid spawners ambushing explorers.-      (deeperStairs, shallowerStairs) =-        (if fromEnum lid > 0 then id else swap) lstair-      stairPoss = (deeperStairs \\ shallowerStairs)-                  ++ lescape-                  ++ shallowerStairs-      middlePos = Point (lxsize `div` 2) (lysize `div` 2)-  let !_A = assert (k > 0 && factionDist > 0) ()-      onStairs = take k stairPoss-      nk = k - length onStairs-  found <- case nk of-    0 -> return []-    1 -> tryFind onStairs nk-    2 -> -- Make sure the first faction's pos is not chosen in the middle.-         tryFind (if null onStairs then [middlePos] else onStairs) nk-    _ -> tryFind onStairs nk-  return $! onStairs ++ found--initDebug :: MonadStateRead m => Kind.COps -> DebugModeSer -> m DebugModeSer-initDebug Kind.COps{corule} sdebugSer = do-  let stdRuleset = Kind.stdRuleset corule-  return $!-    (\dbg -> dbg {sfovMode =-        sfovMode dbg `mplus` Just (rfovMode stdRuleset)}) .-    (\dbg -> dbg {ssavePrefixSer =-        ssavePrefixSer dbg `mplus` Just (rsavePrefix stdRuleset)})-    $ sdebugSer---- | Apply debug options that don't need a new game.-applyDebug :: MonadServer m => m ()-applyDebug = do-  DebugModeSer{..} <- getsServer sdebugNxt-  modifyServer $ \ser ->-    ser {sdebugSer = (sdebugSer ser) { sniffIn-                                     , sniffOut-                                     , sallClear-                                     , sfovMode-                                     , sstopAfter-                                     , sdbgMsgSer-                                     , snewGameSer-                                     , sdumpInitRngs-                                     , sdebugCli }}

Game/LambdaHack/Server/State.hs view

@@ -2,16 +2,19 @@ module Game.LambdaHack.Server.State   ( StateServer(..), emptyStateServer   , DebugModeSer(..), defDebugModeSer-  , RNGs(..), FovCache3(..), emptyFovCache3+  , RNGs(..)+  , ActorTime, updateActorTime, ageActor   ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.HashMap.Strict as HM-import Data.Text (Text) import qualified System.Random as R-import System.Time  import Game.LambdaHack.Atomic import Game.LambdaHack.Common.Actor@@ -23,72 +26,63 @@ import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Server.Fov import Game.LambdaHack.Server.ItemRev  -- | Global, server state. data StateServer = StateServer-  { sdiscoKind    :: !DiscoveryKind     -- ^ full item kind discoveries data+  { sactorTime    :: !ActorTime         -- ^ absolute times of next actions+  , sdiscoKind    :: !DiscoveryKind     -- ^ full item kind discoveries data   , sdiscoKindRev :: !DiscoveryKindRev  -- ^ reverse map, used for item creation   , suniqueSet    :: !UniqueSet         -- ^ already generated unique items-  , sdiscoEffect  :: !DiscoveryEffect   -- ^ full item effect&Co data+  , sdiscoAspect  :: !DiscoveryAspect   -- ^ full item aspect data   , sitemSeedD    :: !ItemSeedDict  -- ^ map from item ids to item seeds   , sitemRev      :: !ItemRev       -- ^ reverse id map, used for item creation-  , sItemFovCache :: !(EM.EnumMap ItemId FovCache3)-                                    -- ^ (sight, smell, light) aspect bonus-                                    --   of the item; zeroes if not in the map   , sflavour      :: !FlavourMap    -- ^ association of flavour to items   , sacounter     :: !ActorId       -- ^ stores next actor index   , sicounter     :: !ItemId        -- ^ stores next item index   , snumSpawned   :: !(EM.EnumMap LevelId Int)-  , sprocessed    :: !(EM.EnumMap LevelId Time)-                                    -- ^ actors are processed up to this time   , sundo         :: ![CmdAtomic]   -- ^ atomic commands performed to date-  , sper          :: !Pers          -- ^ perception of all factions+  , sperFid       :: !PerFid        -- ^ perception of all factions+  , sperValidFid  :: !PerValidFid   -- ^ perception validity for all factions+  , sperCacheFid  :: !PerCacheFid   -- ^ perception cache of all factions+  , sactorAspect  :: !ActorAspect   -- ^ full actor aspect data+  , sfovLucidLid  :: !FovLucidLid   -- ^ ambient or shining light positions+  , sfovClearLid  :: !FovClearLid   -- ^ clear tiles positions+  , sfovLitLid    :: !FovLitLid     -- ^ ambient light positions+  , sarenas       :: ![LevelId]     -- ^ active arenas+  , svalidArenas  :: !Bool          -- ^ whether active arenas valid   , srandom       :: !R.StdGen      -- ^ current random generator   , srngs         :: !RNGs          -- ^ initial random generators   , squit         :: !Bool          -- ^ exit the game loop   , swriteSave    :: !Bool          -- ^ write savegame to a file now-  , sstart        :: !ClockTime     -- ^ this session start time-  , sgstart       :: !ClockTime     -- ^ this game start time-  , sallTime      :: !Time          -- ^ clips since the start of the session-  , sheroNames    :: !(EM.EnumMap FactionId [(Int, (Text, Text))])-                                    -- ^ hero names sent by clients   , sdebugSer     :: !DebugModeSer  -- ^ current debugging mode   , sdebugNxt     :: !DebugModeSer  -- ^ debugging mode for the next game   }   deriving (Show) -data FovCache3 = FovCache3-  { fovSight :: !Int-  , fovSmell :: !Int-  , fovLight :: !Int-  }-  deriving (Show, Eq)--emptyFovCache3 :: FovCache3-emptyFovCache3 = FovCache3 0 0 0- -- | Debug commands. See 'Server.debugArgs' for the descriptions. data DebugModeSer = DebugModeSer-  { sknowMap       :: !Bool-  , sknowEvents    :: !Bool-  , sniffIn        :: !Bool-  , sniffOut       :: !Bool-  , sallClear      :: !Bool-  , sgameMode      :: !(Maybe (GroupName ModeKind))-  , sautomateAll   :: !Bool-  , skeepAutomated :: !Bool-  , sstopAfter     :: !(Maybe Int)-  , sdungeonRng    :: !(Maybe R.StdGen)-  , smainRng       :: !(Maybe R.StdGen)-  , sfovMode       :: !(Maybe FovMode)-  , snewGameSer    :: !Bool-  , scurDiffSer    :: !Int-  , sdumpInitRngs  :: !Bool-  , ssavePrefixSer :: !(Maybe String)-  , sdbgMsgSer     :: !Bool-  , sdebugCli      :: !DebugModeCli  -- ^ client debug parameters+  { sknowMap         :: !Bool+  , sknowEvents      :: !Bool+  , sknowItems       :: !Bool+  , sniffIn          :: !Bool+  , sniffOut         :: !Bool+  , sallClear        :: !Bool+  , sboostRandomItem :: !Bool+  , sgameMode        :: !(Maybe (GroupName ModeKind))+  , sautomateAll     :: !Bool+  , skeepAutomated   :: !Bool+  , sdungeonRng      :: !(Maybe R.StdGen)+  , smainRng         :: !(Maybe R.StdGen)+  , snewGameSer      :: !Bool+  , scurChalSer      :: !Challenge+  , sdumpInitRngs    :: !Bool+  , ssavePrefixSer   :: !String+  , sdbgMsgSer       :: !Bool+  , sdebugCli        :: !DebugModeCli+      -- The client debug inside server debug only holds the client commandline+      -- options and is never updated with config options, etc.   }   deriving Show @@ -105,33 +99,49 @@                        startingRandomGenerator ]     in unwords args +type ActorTime =+  EM.EnumMap FactionId (EM.EnumMap LevelId (EM.EnumMap ActorId Time))++updateActorTime :: FactionId -> LevelId -> ActorId -> Time -> ActorTime+                -> ActorTime+updateActorTime !fid !lid !aid !time =+  EM.adjust (EM.adjust (EM.insert aid time) lid) fid++ageActor :: FactionId -> LevelId -> ActorId -> Delta Time -> ActorTime+         -> ActorTime+ageActor !fid !lid !aid !delta =+  EM.adjust (EM.adjust (EM.adjust (`timeShift` delta) aid) lid) fid+ -- | Initial, empty game server state. emptyStateServer :: StateServer emptyStateServer =   StateServer-    { sdiscoKind = EM.empty+    { sactorTime = EM.empty+    , sdiscoKind = EM.empty     , sdiscoKindRev = EM.empty     , suniqueSet = ES.empty-    , sdiscoEffect = EM.empty+    , sdiscoAspect = EM.empty     , sitemSeedD = EM.empty     , sitemRev = HM.empty-    , sItemFovCache = EM.empty     , sflavour = emptyFlavourMap     , sacounter = toEnum 0     , sicounter = toEnum 0     , snumSpawned = EM.empty-    , sprocessed = EM.empty     , sundo = []-    , sper = EM.empty+    , sperFid = EM.empty+    , sperValidFid = EM.empty+    , sperCacheFid = EM.empty+    , sactorAspect = EM.empty+    , sfovLucidLid = EM.empty+    , sfovClearLid = EM.empty+    , sfovLitLid = EM.empty+    , sarenas = []+    , svalidArenas = False     , srandom = R.mkStdGen 42     , srngs = RNGs { dungeonRandomGenerator = Nothing                    , startingRandomGenerator = Nothing }     , squit = False     , swriteSave = False-    , sstart = TOD 0 0-    , sgstart = TOD 0 0-    , sallTime = timeZero-    , sheroNames = EM.empty     , sdebugSer = defDebugModeSer     , sdebugNxt = defDebugModeSer     }@@ -139,113 +149,109 @@ defDebugModeSer :: DebugModeSer defDebugModeSer = DebugModeSer { sknowMap = False                                , sknowEvents = False+                               , sknowItems = False                                , sniffIn = False                                , sniffOut = False                                , sallClear = False+                               , sboostRandomItem = False                                , sgameMode = Nothing                                , sautomateAll = False                                , skeepAutomated = False-                               , sstopAfter = Nothing                                , sdungeonRng = Nothing                                , smainRng = Nothing-                               , sfovMode = Nothing                                , snewGameSer = False-                               , scurDiffSer = difficultyDefault+                               , scurChalSer = defaultChallenge+-- for debug; hard to set manually in browser:+#ifdef USE_BROWSER+                               , sdumpInitRngs = True+#else                                , sdumpInitRngs = False-                               , ssavePrefixSer = Nothing+#endif+                               , ssavePrefixSer = "save"                                , sdbgMsgSer = False                                , sdebugCli = defDebugModeCli                                }  instance Binary StateServer where   put StateServer{..} = do+    put sactorTime     put sdiscoKind     put sdiscoKindRev     put suniqueSet-    put sdiscoEffect+    put sdiscoAspect     put sitemSeedD     put sitemRev-    put sItemFovCache  -- out of laziness, but it's small     put sflavour     put sacounter     put sicounter     put snumSpawned-    put sprocessed     put sundo     put (show srandom)     put srngs-    put sheroNames     put sdebugSer   get = do+    sactorTime <- get     sdiscoKind <- get     sdiscoKindRev <- get     suniqueSet <- get-    sdiscoEffect <- get+    sdiscoAspect <- get     sitemSeedD <- get     sitemRev <- get-    sItemFovCache <- get     sflavour <- get     sacounter <- get     sicounter <- get     snumSpawned <- get-    sprocessed <- get     sundo <- get     g <- get     srngs <- get-    sheroNames <- get     sdebugSer <- get     let srandom = read g-        sper = EM.empty+        sperFid = EM.empty+        sperValidFid = EM.empty+        sperCacheFid = EM.empty+        sactorAspect = EM.empty+        sfovLucidLid = EM.empty+        sfovClearLid = EM.empty+        sfovLitLid = EM.empty+        sarenas = []+        svalidArenas = False         squit = False         swriteSave = False-        sstart = TOD 0 0-        sgstart = TOD 0 0-        sallTime = timeZero-        sdebugNxt = defDebugModeSer  -- TODO: here difficulty level, etc. from the last session is wiped out+        sdebugNxt = defDebugModeSer     return $! StateServer{..} -instance Binary FovCache3 where-  put FovCache3{..} = do-    put fovSight-    put fovSmell-    put fovLight-  get = do-    fovSight <- get-    fovSmell <- get-    fovLight <- get-    return $! FovCache3{..}- instance Binary DebugModeSer where   put DebugModeSer{..} = do     put sknowMap     put sknowEvents+    put sknowItems     put sniffIn     put sniffOut     put sallClear+    put sboostRandomItem     put sgameMode     put sautomateAll     put skeepAutomated-    put scurDiffSer-    put sfovMode+    put scurChalSer     put ssavePrefixSer     put sdbgMsgSer     put sdebugCli   get = do     sknowMap <- get     sknowEvents <- get+    sknowItems <- get     sniffIn <- get     sniffOut <- get     sallClear <- get+    sboostRandomItem <- get     sgameMode <- get     sautomateAll <- get     skeepAutomated <- get-    scurDiffSer <- get-    sfovMode <- get+    scurChalSer <- get     ssavePrefixSer <- get     sdbgMsgSer <- get     sdebugCli <- get-    let sstopAfter = Nothing-        sdungeonRng = Nothing+    let sdungeonRng = Nothing         smainRng = Nothing         snewGameSer = False         sdumpInitRngs = False

GameDefinition/Client/UI/Content/KeyKind.hs view

@@ -1,208 +1,276 @@ -- | The default game key-command mapping to be used for UI. Can be overridden -- via macros in the config file.-module Client.UI.Content.KeyKind ( standardKeys ) where+module Client.UI.Content.KeyKind+  ( standardKeys+  ) where -import Control.Arrow (first)+import Prelude () -import qualified Game.LambdaHack.Client.Key as K+import Game.LambdaHack.Common.Prelude+ import Game.LambdaHack.Client.UI.Content.KeyKind import Game.LambdaHack.Client.UI.HumanCmd import Game.LambdaHack.Common.Misc-import qualified Game.LambdaHack.Content.ItemKind as IK import qualified Game.LambdaHack.Content.TileKind as TK +-- | Description of default key-command bindings.+--+-- In addition to these commands, mouse and keys have a standard meaning+-- when navigating various menus. standardKeys :: KeyKind standardKeys = KeyKind-  { rhumanCommands = map (first K.mkKM)+  { rhumanCommands = map evalKeyDef $       -- All commands are defined here, except some movement and leader picking       -- commands. All commands are shown on help screens except debug commands       -- and macros with empty descriptions.       -- The order below determines the order on the help screens.-      -- Remember to put commands that show information (e.g., enter targeting+      -- Remember to put commands that show information (e.g., enter aiming       -- mode) first. -      -- Main Menu, which apart of these includes a few extra commands-      [ ("CTRL-x", ([CmdMenu], GameExit))-      , ("CTRL-r", ([CmdMenu], GameRestart "raid"))-      , ("CTRL-k", ([CmdMenu], GameRestart "skirmish"))-      , ("CTRL-m", ([CmdMenu], GameRestart "ambush"))-      , ("CTRL-b", ([CmdMenu], GameRestart "battle"))-      , ("CTRL-c", ([CmdMenu], GameRestart "campaign"))-      , ("CTRL-i", ([CmdDebug], GameRestart "battle survival"))-      , ("CTRL-f", ([CmdDebug], GameRestart "safari"))-      , ("CTRL-u", ([CmdDebug], GameRestart "safari survival"))-      , ("CTRL-e", ([CmdDebug], GameRestart "defense"))-      , ("CTRL-g", ([CmdDebug], GameRestart "boardgame"))-      , ("CTRL-d", ([CmdMenu], GameDifficultyCycle))+      -- Main Menu+      [ ("c", ([CmdMainMenu], "enter challenges menu>", ChallengesMenu))+      , ("n", ([CmdMainMenu], "start new game", GameRestart))+      , ("x", ([CmdMainMenu], "save and exit", GameExit))+      , ("m", ([CmdMainMenu], "enter settings menu>", SettingsMenu))+      , ("a", ([CmdMainMenu], "automate faction", Automate))+      , ("?", ([CmdMainMenu], "see command Help", Help))+      , ("Escape", ([CmdMainMenu], "back to playing", Cancel)) -      -- Movement and terrain alteration-      , ("less", ([CmdMove, CmdMinimal], TriggerTile-           [ TriggerFeature { verb = "ascend"-                            , object = "a level"-                            , feature = TK.Cause (IK.Ascend 1) }-           , TriggerFeature { verb = "escape"-                            , object = "dungeon"-                            , feature = TK.Cause (IK.Escape 1) } ]))-      , ("CTRL-less", ([CmdMove], TriggerTile-           [ TriggerFeature { verb = "ascend"-                            , object = "10 levels"-                            , feature = TK.Cause (IK.Ascend 10) } ]))-      , ("greater", ([CmdMove, CmdMinimal], TriggerTile-           [ TriggerFeature { verb = "descend"-                            , object = "a level"-                            , feature = TK.Cause (IK.Ascend (-1)) }-           , TriggerFeature { verb = "escape"-                            , object = "dungeon"-                            , feature = TK.Cause (IK.Escape (-1)) } ]))-      , ("CTRL-greater", ([CmdMove], TriggerTile-           [ TriggerFeature { verb = "descend"-                            , object = "10 levels"-                            , feature = TK.Cause (IK.Ascend (-10)) } ]))-      , ("semicolon",-         ( [CmdMove]-         , Macro "go to crosshair for 100 steps"-                 ["CTRL-semicolon", "CTRL-period", "V"] ))-      , ("colon",-         ( [CmdMove]-         , Macro "run selected to crosshair for 100 steps"-                 ["CTRL-colon", "CTRL-period", "V"] ))-      , ("x",-         ( [CmdMove]-         , Macro "explore the closest unknown spot"-                 [ "CTRL-question"  -- no semicolon-                 , "CTRL-period", "V" ] ))-      , ("X",-         ( [CmdMove]-         , Macro "autoexplore 100 times"-                 ["'", "CTRL-question", "CTRL-period", "'", "V"] ))-      , ("CTRL-X",-         ( [CmdMove]-         , Macro "autoexplore 25 times"-                 ["'", "CTRL-question", "CTRL-period", "'", "CTRL-V"] ))-      , ("R", ([CmdMove], Macro "rest (wait 100 times)"-                                ["KP_Begin", "V"]))-      , ("CTRL-R", ([CmdMove], Macro "rest (wait 25 times)"-                                     ["KP_Begin", "CTRL-V"]))-      , ("c", ([CmdMove, CmdMinimal], AlterDir-           [ AlterFeature { verb = "close"-                          , object = "door"-                          , feature = TK.CloseTo "vertical closed door Lit" }-           , AlterFeature { verb = "close"-                          , object = "door"-                          , feature = TK.CloseTo "horizontal closed door Lit" }-           , AlterFeature { verb = "close"-                          , object = "door"-                          , feature = TK.CloseTo "vertical closed door Dark" }-           , AlterFeature { verb = "close"-                          , object = "door"-                          , feature = TK.CloseTo "horizontal closed door Dark" }-           ]))+      -- Item use, 1st part+      , ("g", addCmdCategory CmdMinimal $ grabItems "grab item(s)")+      , ("comma", grabItems "")+      , ("d", dropItems "drop item(s)")+      , ("period", dropItems "")+      , ("f", addCmdCategory CmdItemMenu $ projectA flingTs)+      , ("C-f", addCmdCategory CmdItemMenu+                $ replaceDesc "fling without aiming" $ projectI flingTs)+      , ("a", addCmdCategory CmdItemMenu $ applyI [ApplyItem+                { verb = "apply"+                , object = "consumable"+                , symbol = ' ' }])+      , ("C-a", addCmdCategory CmdItemMenu+                $ replaceDesc "apply and keep choice" $ applyIK [ApplyItem+                  { verb = "apply"+                  , object = "consumable"+                  , symbol = ' ' }]) -      -- Item use-      , ("E", ([CmdItem, CmdMinimal], DescribeItem $ MStore CEqp))-      , ("P", ([CmdItem], DescribeItem $ MStore CInv))-      , ("S", ([CmdItem], DescribeItem $ MStore CSha))-      , ("A", ([CmdItem], DescribeItem MOwned))-      , ("G", ([CmdItem], DescribeItem $ MStore CGround))-      , ("@", ([CmdItem], DescribeItem $ MStore COrgan))-      , ("exclam", ([CmdItem], DescribeItem MStats))-      , ("g", ([CmdItem, CmdMinimal],-               MoveItem [CGround] CEqp (Just "get") "items" True))-      , ("d", ([CmdItem], MoveItem [CEqp, CInv, CSha] CGround-                                   Nothing "items" False))-      , ("e", ([CmdItem], MoveItem [CGround, CInv, CSha] CEqp-                                   Nothing "items" False))-      , ("p", ([CmdItem], MoveItem [CGround, CEqp, CSha] CInv-                                   Nothing "items into inventory"-                                   False))-      , ("s", ([CmdItem], MoveItem [CGround, CInv, CEqp] CSha-                                   Nothing "and share items" False))-      , ("a", ([CmdItem, CmdMinimal], Apply-           [ ApplyItem { verb = "apply"-                       , object = "consumable"-                       , symbol = ' ' }-           , ApplyItem { verb = "quaff"-                       , object = "potion"-                       , symbol = '!' }-           , ApplyItem { verb = "read"-                       , object = "scroll"-                       , symbol = '?' }-           ]))-      , ("q", ([CmdItem], Apply [ApplyItem { verb = "quaff"-                                           , object = "potion"-                                           , symbol = '!' }]))-      , ("r", ([CmdItem], Apply [ApplyItem { verb = "read"-                                           , object = "scroll"-                                           , symbol = '?' }]))-      , ("f", ([CmdItem, CmdMinimal], Project-           [ApplyItem { verb = "fling"-                      , object = "projectile"-                      , symbol = ' ' }]))-      , ("t", ([CmdItem], Project [ApplyItem { verb = "throw"-                                             , object = "missile"-                                             , symbol = '|' }]))---      , ("z", ([CmdItem], Project [ApplyItem { verb = "zap"---                                             , object = "wand"---                                             , symbol = '/' }]))+      -- Terrain exploration and alteration+      , ("semicolon", ( [CmdMove]+                      , "go to x-hair for 25 steps"+                      , Macro ["C-semicolon", "C-/", "C-V"] ))+      , ("colon", ( [CmdMove]+                  , "run to x-hair collectively for 25 steps"+                  , Macro ["C-colon", "C-/", "C-V"] ))+      , ("x", ( [CmdMove]+              , "explore nearest unknown spot"+              , autoexploreCmd ))+      , ("X", ( [CmdMove]+              , "autoexplore 25 times"+              , autoexplore25Cmd ))+      , ("R", ([CmdMove], "rest (wait 25 times)", Macro ["KP_5", "C-V"]))+      , ("C-R", ( [CmdMove], "lurk (wait 0.1 turns 100 times)"+                , Macro ["C-KP_5", "V"] ))+      , ("c", ( [CmdMove, CmdMinimal]+              , descTs closeDoorTriggers+              , AlterDir closeDoorTriggers )) -      -- Targeting-      , ("KP_Multiply", ([CmdTgt], TgtEnemy))-      , ("backslash", ([CmdTgt], Macro "" ["KP_Multiply"]))-      , ("KP_Divide", ([CmdTgt], TgtFloor))-      , ("bar", ([CmdTgt], Macro "" ["KP_Divide"]))-      , ("plus", ([CmdTgt, CmdMinimal], EpsIncr True))-      , ("minus", ([CmdTgt], EpsIncr False))-      , ("CTRL-question", ([CmdTgt], CursorUnknown))-      , ("CTRL-I", ([CmdTgt], CursorItem))-      , ("CTRL-braceleft", ([CmdTgt], CursorStair True))-      , ("CTRL-braceright", ([CmdTgt], CursorStair False))-      , ("BackSpace", ([CmdTgt], TgtClear))+      -- Item use, continued+      , ("^", ( [CmdItem], "sort items by kind and stats", SortSlots))+      , ("p", moveItemTriple [CGround, CEqp, CSha] CInv+                             "item" False)+      , ("e", moveItemTriple [CGround, CInv, CSha] CEqp+                             "item" False)+      , ("s", moveItemTriple [CGround, CInv, CEqp] CSha+                             "and share item" False)+      , ("P", ( [CmdMinimal, CmdItem]+              , "manage item pack of the leader"+              , ChooseItemMenu (MStore CInv) ))+      , ("G", ( [CmdItem]+              , "manage items on the ground"+              , ChooseItemMenu (MStore CGround) ))+      , ("E", ( [CmdItem]+              , "manage equipment of the leader"+              , ChooseItemMenu (MStore CEqp) ))+      , ("S", ( [CmdItem]+              , "manage the shared party stash"+              , ChooseItemMenu (MStore CSha) ))+      , ("A", ( [CmdItem]+              , "manage all owned items"+              , ChooseItemMenu MOwned ))+      , ("@", ( [CmdItem]+              , "describe organs of the leader"+              , ChooseItemMenu (MStore COrgan) ))+      , ("#", ( [CmdItem]+              , "show stat summary of the leader"+              , ChooseItemMenu MStats ))+      , ("~", ( [CmdItem]+              , "display known lore"+              , ChooseItemMenu MLoreItem ))+      , ("q", addCmdCategory CmdItem $ applyI [ApplyItem+                { verb = "quaff"+                , object = "potion"+                , symbol = '!' }])+      , ("r", addCmdCategory CmdItem $ applyI [ApplyItem+                { verb = "read"+                , object = "scroll"+                , symbol = '?' }]) -      -- Automation-      , ("equal", ([CmdAuto], SelectActor))-      , ("underscore", ([CmdAuto], SelectNone))-      , ("v", ([CmdAuto], Repeat 1))-      , ("V", ([CmdAuto], Repeat 100))-      , ("CTRL-v", ([CmdAuto], Repeat 1000))-      , ("CTRL-V", ([CmdAuto], Repeat 25))-      , ("apostrophe", ([CmdAuto], Record))-      , ("CTRL-T", ([CmdAuto], Tactic))-      , ("CTRL-A", ([CmdAuto], Automate))+      , ("t", addCmdCategory CmdItem $ projectA+                [ ApplyItem { verb = "throw"+                            , object = "missile"+                            , symbol = '|' } ])+--      , ("z", projectA [ApplyItem { verb = "zap"+--                                  , object = "wand"+--                                  , symbol = '/' }]) +      -- Aiming+      , ("KP_Multiply", ( [CmdAim, CmdMinimal]+                        , "cycle x-hair among enemies", AimEnemy ))+          -- not really minimal, because flinging from Item Menu enters aiming+          -- mode, first screen mentions aiming mode not in fling context+      , ("!", ([CmdAim], "", AimEnemy))+      , ("KP_Divide", ([CmdAim], "cycle x-hair among items", AimItem))+      , ("/", ([CmdAim], "", AimItem))+      , ("\\", ([CmdAim], "cycle aiming modes", AimFloor))+      , ("+", ([CmdAim, CmdMinimal], "swerve the aiming line", EpsIncr True))+      , ("-", ([CmdAim], "unswerve the aiming line", EpsIncr False))+      , ("C-?", ( [CmdAim]+                , "set x-hair to nearest unknown spot"+                , XhairUnknown ))+      , ("C-I", ( [CmdAim]+                , "set x-hair to nearest item"+                , XhairItem ))+      , ("C-{", ( [CmdAim]+                , "set x-hair to nearest upstairs"+                , XhairStair True ))+      , ("C-}", ( [CmdAim]+                , "set x-hair to nearest downstairs"+                , XhairStair False ))+      , ("<", ([CmdAim], "move aiming one level higher" , AimAscend 1))+      , ("C-<", ( [CmdNoHelp], "move aiming 10 levels higher"+                , AimAscend 10) )+      , (">", ([CmdAim], "move aiming one level lower", AimAscend (-1)))+      , ("C->", ( [CmdNoHelp], "move aiming 10 levels lower"+                , AimAscend (-10)) )+      , ("BackSpace" , ( [CmdAim]+                     , "clear chosen item and target"+                     , ComposeUnlessError ItemClear TgtClear ))+      , ("Escape", ( [CmdAim, CmdMinimal]+                   , "cancel aiming/open Main Menu"+                   , ByAimMode {exploration = MainMenu, aiming = Cancel} ))+      , ("Return", ( [CmdAim, CmdMinimal]+                   , "accept target/open Help"+                   , ByAimMode {exploration = Help, aiming = Accept} ))+       -- Assorted-      , ("question", ([CmdMeta], Help))-      , ("D", ([CmdMeta, CmdMinimal], History))-      , ("T", ([CmdMeta, CmdMinimal], MarkSuspect))-      , ("Z", ([CmdMeta], MarkVision))-      , ("C", ([CmdMeta], MarkSmell))-      , ("Tab", ([CmdMeta], MemberCycle))-      , ("ISO_Left_Tab", ([CmdMeta, CmdMinimal], MemberBack))-      , ("space", ([CmdMeta], Clear))-      , ("Escape", ([CmdMeta, CmdMinimal], Cancel))-      , ("Return", ([CmdMeta, CmdTgt], Accept))+      , ("space", ( [CmdMinimal, CmdMeta]+                  , "clear messages/display history", Clear ))+      , ("?", ([CmdMeta], "display Help", Help))+      , ("F1", ([CmdMeta], "", Help))+      , ("Tab", ( [CmdMeta]+                , "cycle among party members on the level"+                , MemberCycle ))+      , ("BackTab", ( [CmdMeta, CmdMinimal]+                  , "cycle among all party members"+                  , MemberBack ))+      , ("=", ( [CmdMinimal, CmdMeta]+              , "select (or deselect) party member", SelectActor) )+      , ("_", ([CmdMeta], "deselect (or select) all on the level", SelectNone))+      , ("v", ([CmdMeta], "voice again the recorded commands", Repeat 1))+      , ("V", repeatTriple 100)+      , ("C-v", repeatTriple 1000)+      , ("C-V", repeatTriple 25)+      , ("'", ([CmdMeta], "start recording commands", Record))        -- Mouse-      , ("LeftButtonPress",-         ([CmdMouse], macroLeftButtonPress))-      , ("SHIFT-LeftButtonPress",-         ([CmdMouse], macroShiftLeftButtonPress))-      , ("MiddleButtonPress", ([CmdMouse], CursorPointerEnemy))-      , ("SHIFT-MiddleButtonPress", ([CmdMouse], CursorPointerFloor))-      , ("CTRL-MiddleButtonPress",-         ([CmdInternal], Macro "" ["SHIFT-MiddleButtonPress"]))-      , ("RightButtonPress", ([CmdMouse], TgtPointerEnemy))+      , ("LeftButtonRelease", mouseLMB)+      , ("RightButtonRelease", mouseRMB)+      , ("C-LeftButtonRelease", replaceDesc "" mouseRMB)  -- Mac convention+      , ( "C-RightButtonRelease"+        , ( [CmdMouse]+          , "open or close door"+          , AlterWithPointer $ closeDoorTriggers ++ openDoorTriggers ) )+      , ("MiddleButtonRelease", mouseMMB)+      , ("WheelNorth", ([CmdMouse], "swerve the aiming line", Macro ["+"]))+      , ("WheelSouth", ([CmdMouse], "unswerve the aiming line", Macro ["-"]))        -- Debug and others not to display in help screens-      , ("CTRL-S", ([CmdDebug], GameSave))-      , ("CTRL-semicolon", ([CmdInternal], MoveOnceToCursor))-      , ("CTRL-colon", ([CmdInternal], RunOnceToCursor))-      , ("CTRL-period", ([CmdInternal], ContinueToCursor))-      , ("CTRL-comma", ([CmdInternal], RunOnceAhead))-      , ("CTRL-LeftButtonPress",-         ([CmdInternal], Macro "" ["SHIFT-LeftButtonPress"]))-      , ("CTRL-MiddleButtonPress",-         ([CmdInternal], Macro "" ["SHIFT-MiddleButtonPress"]))-      , ("ALT-space", ([CmdInternal], StopIfTgtMode))-      , ("ALT-minus", ([CmdInternal], SelectWithPointer))-     ]+      , ("C-S", ([CmdDebug], "save game", GameSave))+      , ("C-semicolon", ( [CmdNoHelp]+                        , "move one step towards the x-hair"+                        , MoveOnceToXhair ))+      , ("C-colon", ( [CmdNoHelp]+                    , "run collectively one step towards the x-hair"+                    , RunOnceToXhair ))+      , ("C-/", ( [CmdNoHelp]+                , "continue towards the x-hair"+                , ContinueToXhair ))+      , ("C-comma", ([CmdNoHelp], "run once ahead", RunOnceAhead))+      , ("safe1", ( [CmdInternal]+                  , "go to pointer for 25 steps"+                  , goToCmd ))+      , ("safe2", ( [CmdInternal]+                  , "run to pointer collectively"+                  , runToAllCmd ))+      , ("safe3", ( [CmdInternal]+                  , "pick new leader on screen"+                  , PickLeaderWithPointer ))+      , ("safe4", ( [CmdInternal]+                  , "select party member on screen"+                  , SelectWithPointer ))+      , ("safe5", ( [CmdInternal]+                  , "set x-hair to enemy"+                  , AimPointerEnemy ))+      , ("safe6", ( [CmdInternal]+                  , "fling at enemy under pointer"+                  , aimFlingCmd ))+      , ("safe7", ( [CmdInternal]+                  , "open Main Menu"+                  , MainMenu ))+      , ("safe8", ( [CmdInternal]+                  , "cancel aiming"+                  , Cancel ))+      , ("safe9", ( [CmdInternal]+                  , "accept target"+                  , Accept ))+      , ("safe10", ( [CmdInternal]+                   , "wait a turn, bracing for impact"+                   , Wait ))+      , ("safe11", ( [CmdInternal]+                   , "wait 0.1 of a turn"+                   , Wait10 ))+      ]+      ++ map defaultHeroSelect [0..6]   }++closeDoorTriggers :: [Trigger]+closeDoorTriggers =+  [ AlterFeature { verb = "close"+                 , object = "door"+                 , feature = TK.CloseTo "closed vertical door Lit" }+  , AlterFeature { verb = "close"+                 , object = "door"+                 , feature = TK.CloseTo "closed horizontal door Lit" }+  , AlterFeature { verb = "close"+                 , object = "door"+                 , feature = TK.CloseTo "closed vertical door Dark" }+  , AlterFeature { verb = "close"+                 , object = "door"+                 , feature = TK.CloseTo "closed horizontal door Dark" }+  ]++openDoorTriggers :: [Trigger]+openDoorTriggers =+  [ AlterFeature { verb = "open"+                 , object = "door"+                 , feature = TK.OpenTo "open vertical door Lit" }+  , AlterFeature { verb = "open"+                 , object = "door"+                 , feature = TK.OpenTo "open horizontal door Lit" }+  , AlterFeature { verb = "open"+                 , object = "door"+                 , feature = TK.OpenTo "open vertical door Dark" }+  , AlterFeature { verb = "open"+                 , object = "door"+                 , feature = TK.OpenTo "open horizontal door Dark" }+  ]

GameDefinition/Content/CaveKind.hs view

@@ -1,6 +1,12 @@ -- | Cave layouts.-module Content.CaveKind ( cdefs ) where+module Content.CaveKind+  ( cdefs+  ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Data.Ratio  import Game.LambdaHack.Common.ContentDef@@ -15,31 +21,33 @@   , getFreq = cfreq   , validateSingle = validateSingleCaveKind   , validateAll = validateAllCaveKind-  , content =-      [rogue, arena, empty, noise, shallow1rogue, battle, skirmish, ambush, safari1, safari2, safari3, rogueLit, boardgame]+  , content = contentFromList+      [rogue, arena, arena2, laboratory, empty, noise, noise2, shallow2rogue, shallow1rogue, raid, brawl, shootout, escape, zoo, ambush, battle, safari1, safari2, safari3]   }-rogue,        arena, empty, noise, shallow1rogue, battle, skirmish, ambush, safari1, safari2, safari3, rogueLit, boardgame :: CaveKind+rogue,        arena, arena2, laboratory, empty, noise, noise2, shallow2rogue, shallow1rogue, raid, brawl, shootout, escape, zoo, ambush, battle, safari1, safari2, safari3 :: CaveKind  rogue = CaveKind   { csymbol       = 'R'   , cname         = "A maze of twisty passages"-  , cfreq         = [("campaign random", 100), ("caveRogue", 1)]+  , cfreq         = [ ("default random", 100), ("deep random", 100)+                    , ("caveRogue", 1) ]   , cxsize        = fst normalLevelBound + 1   , cysize        = snd normalLevelBound + 1-  , cgrid         = DiceXY (3 * d 2) (d 2 + 2)-  , cminPlaceSize = DiceXY (2 * d 2 + 2) 4+  , cgrid         = DiceXY (3 * d 2) 4+  , cminPlaceSize = DiceXY (2 * d 2 + 4) 5   , cmaxPlaceSize = DiceXY 15 10   , cdarkChance   = d 54 + dl 20   , cnightChance  = 51  -- always night-  , cauxConnects  = 1%3+  , cauxConnects  = 1%2   , cmaxVoid      = 1%6-  , cminStairDist = 30-  , cdoorChance   = 1%2-  , copenChance   = 1%10-  , chidden       = 8+  , cminStairDist = 15+  , cextraStairs  = 1 + d 2+  , cdoorChance   = 3%4+  , copenChance   = 1%5+  , chidden       = 7   , cactorCoeff   = 130  -- the maze requires time to explore   , cactorFreq    = [("monster", 60), ("animal", 40)]-  , citemNum      = 10 * d 2+  , citemNum      = 5 * d 5   , citemFreq     = [("useful", 50), ("treasure", 50)]   , cplaceFreq    = [("rogue", 100)]   , cpassable     = False@@ -50,50 +58,92 @@   , couterFenceTile = "basic outer fence"   , clegendDarkTile = "legendDark"   , clegendLitTile  = "legendLit"-  }+  , cescapeGroup    = Nothing+  , cstairFreq      = [("staircase", 100)]+  }  -- no lit corridor alternative, because both lit # and . look bad here arena = rogue   { csymbol       = 'A'-  , cname         = "Underground library"-  , cfreq         = [("campaign random", 50), ("caveArena", 1)]-  , cgrid         = DiceXY (2 * d 2) (2 * d 2)-  , cminPlaceSize = DiceXY (2 * d 2 + 3) 4-  , cdarkChance   = d 100 - dl 50-  -- Trails provide enough light for fun stealth. Light is not too deadly,-  -- because not many obstructions, so foes visible from far away.-  , cnightChance  = d 50 + dl 50-  , cmaxVoid      = 1%4-  , chidden       = 1000+  , cname         = "Dusty underground library"+  , cfreq         = [ ("default random", 40), ("deep random", 30)+                    , ("caveArena", 1) ]+  , cgrid         = DiceXY (2 + d 2) (d 3)+  , cminPlaceSize = DiceXY (2 * d 2 + 4) 6+  , cmaxPlaceSize = DiceXY 16 12+  , cdarkChance   = 49 + d 10  -- almost all rooms dark (1 in 10 lit)+  -- Light is not too deadly, because not many obstructions and so+  -- foes visible from far away and few foes have ranged combat.+  , cnightChance  = 0  -- always day+  , cauxConnects  = 1+  , cmaxVoid      = 1%8+  , cextraStairs  = d 3+  , chidden       = 0   , cactorCoeff   = 100   , cactorFreq    = [("monster", 30), ("animal", 70)]-  , citemNum      = 9 * d 2  -- few rooms+  , citemNum      = 4 * d 5  -- few rooms   , citemFreq     = [("useful", 20), ("treasure", 30), ("any scroll", 50)]+  , cplaceFreq    = [("arena", 100)]   , cpassable     = True-  , cdefTile      = "arenaSet"-  , cdarkCorTile  = "trailLit"  -- let trails give off light+  , cdefTile      = "arenaSetLit"   , clitCorTile   = "trailLit"   }+arena2 = arena+  { cname         = "Smoking rooms"+  , cfreq         = [("deep random", 10)]+  , cdarkChance   = 41 + d 10  -- almost all rooms lit (1 in 10 dark)+  -- Trails provide enough light for fun stealth.+  , cnightChance  = 51  -- always night+  , citemNum      = 6 * d 5  -- rare, so make it exciting+  , citemFreq     = [("useful", 20), ("treasure", 30), ("any vial", 50)]+  , cdefTile      = "arenaSetDark"+  , cdarkCorTile  = "trailLit"  -- let trails give off light+  }+laboratory = arena2+  { csymbol       = 'L'+  , cname         = "Burnt laboratory"+  , cfreq         = [("deep random", 20), ("caveLaboratory", 1)]+  , cgrid         = DiceXY (2 * d 2 + 7) 3+  , cminPlaceSize = DiceXY (3 * d 2 + 4) 5+  , cdarkChance   = d 54 + dl 20  -- most rooms lit, to compensate for corridors+  , cnightChance  = 0  -- always day+  , cauxConnects  = 1%10+  , cmaxVoid      = 1%10+  , cextraStairs  = d 2+  , cdoorChance   = 1+  , copenChance   = 1%2+  , chidden       = 7+  , citemNum      = 6 * d 5  -- reward difficulty+  , citemFreq     = [("useful", 20), ("treasure", 30), ("any vial", 50)]+  , cplaceFreq    = [("laboratory", 100)]+  , cpassable     = False+  , cdefTile      = "fillerWall"+  , clitCorTile   = "labTrailLit"+  } empty = rogue   { csymbol       = 'E'   , cname         = "Tall cavern"   , cfreq         = [("caveEmpty", 1)]-  , cgrid         = DiceXY (d 2 + 1) 1-  , cminPlaceSize = DiceXY 10 10-  , cmaxPlaceSize = DiceXY 24 12-  , cdarkChance   = d 80 + dl 80+  , cgrid         = DiceXY 1 1+  , cminPlaceSize = DiceXY 12 12+  , cmaxPlaceSize = DiceXY 48 32  -- favour large rooms+  , cdarkChance   = d 100 + dl 100   , cnightChance  = 0  -- always day-  , cauxConnects  = 1-  , cmaxVoid      = 1%2-  , cminStairDist = 50-  , chidden       = 1000-  , cactorCoeff   = 3-  , cactorFreq    = [("monster", 2), ("animal", 8), ("immobile vents", 90)]-      -- The healing geysers on lvl 3 act like HP resets. They are needed to avoid+  , cauxConnects  = 3%2+  , cminStairDist = 30+  , cmaxVoid      = 0  -- too few rooms to have void and fog common anyway+  , cextraStairs  = d 2+  , cdoorChance   = 0+  , copenChance   = 0+  , chidden       = 0+  , cactorCoeff   = 10+  , cactorFreq    = [("animal", 5), ("immobile animal", 95)]+      -- The healing geysers on lvl 3 act like HP resets. Needed to avoid       -- cascading failure, if the particular starting conditions were-      -- very hard. The items are not reset, even if the are bad, which provides+      -- very hard. Items are not reset, even if they are bad, which provides       -- enough of a continuity. Gyesers on lvl 3 are not OP and can't be-      -- abused, because they spawn less and less often and they don't heal over-      -- max HP.-  , citemNum      = 7 * d 2  -- few rooms+      -- abused, because they spawn less and less often and also HP doesn't+      -- effectively accumulate over max.+  , citemNum      = 3 * d 5  -- few rooms and geysers are the boon+  , cplaceFreq    = [("empty", 100)]   , cpassable     = True   , cdefTile      = "emptySet"   , cdarkCorTile  = "floorArenaDark"@@ -101,143 +151,242 @@   } noise = rogue   { csymbol       = 'N'-  , cname         = "Leaky, burrowed sediment"-  , cfreq         = [("campaign random", 20), ("caveNoise", 1)]-  , cgrid         = DiceXY (2 + d 2) 3-  , cminPlaceSize = DiceXY 12 5-  , cmaxPlaceSize = DiceXY 24 12-  , cdarkChance   = 0  -- few rooms, so all lit+  , cname         = "Leaky burrowed sediment"+  , cfreq         = [("default random", 10), ("caveNoise", 1)]+  , cgrid         = DiceXY (2 + d 3) 3+  , cminPlaceSize = DiceXY 8 5+  , cmaxPlaceSize = DiceXY 20 10+  , cdarkChance   = 51   -- Light is deadly, because nowhere to hide and pillars enable spawning-  -- very close to heroes, so deep down light should be rare.-  , cnightChance  = dl 300-  , cauxConnects  = 0-  , cmaxVoid      = 0-  , chidden       = 1000+  -- very close to heroes.+  , cnightChance  = 0  -- harder variant, but looks cheerful+  , cauxConnects  = 1%10+  , cmaxVoid      = 1%100+  , cextraStairs  = d 4+  , cdoorChance   = 1  -- to avoid lit quasi-door tiles+  , chidden       = 0   , cactorCoeff   = 160  -- the maze requires time to explore   , cactorFreq    = [("monster", 80), ("animal", 20)]-  , citemNum      = 12 * d 2  -- an incentive to explore the labyrinth+  , citemNum      = 6 * d 5  -- an incentive to explore the labyrinth   , cpassable     = True   , cplaceFreq    = [("noise", 100)]   , cdefTile      = "noiseSet"+  , couterFenceTile = "noise fence"  -- ensures no cut-off parts from collapsed   , cdarkCorTile  = "floorArenaDark"   , clitCorTile   = "floorArenaLit"   }-shallow1rogue = rogue-  { csymbol       = 'D'-  , cname         = "Entrance to the dungeon"-  , cfreq         = [("shallow random 1", 100)]-  , cdarkChance   = 0+noise2 = noise+  { cname         = "Frozen derelict mine"+  , cfreq         = [("caveNoise2", 1)]+  , cnightChance  = 51  -- easier variant, but looks sinister+  , cplaceFreq    = [("noise", 1), ("mine", 99)]+  , cstairFreq    = [("gated staircase", 100)]+  }+shallow2rogue = rogue+  { cfreq         = [("shallow random 2", 100)]+  , cextraStairs  = 1  -- ensure heroes meet initial monsters and their loot+  }+shallow1rogue = shallow2rogue+  { csymbol       = 'B'+  , cname         = "Cave entrance"+  , cfreq         = [("outermost", 100)]+  , cdarkChance   = 0  -- all rooms lit, for a gentle start+  , cextraStairs  = 1   , cactorFreq    = filter ((/= "monster") . fst) $ cactorFreq rogue-  , citemNum      = 15 * d 2  -- lure them in with loot+  , citemNum      = 8 * d 5  -- lure them in with loot   , citemFreq     = filter ((/= "treasure") . fst) $ citemFreq rogue+  , cescapeGroup  = Just "escape up"   }-battle = rogue  -- few lights and many solids, to help the less numerous heroes-  { csymbol       = 'B'-  , cname         = "Old battle ground"-  , cfreq         = [("caveBattle", 1)]-  , cgrid         = DiceXY (2 * d 2 + 1) 3-  , cminPlaceSize = DiceXY 4 4-  , cmaxPlaceSize = DiceXY 9 7-  , cdarkChance   = 0-  , cnightChance  = 51  -- always night-  , cmaxVoid      = 0-  , cdoorChance   = 2%10-  , copenChance   = 9%10-  , chidden       = 1000-  , cactorFreq    = []-  , citemNum      = 20 * d 2-  , citemFreq     = [("useful", 100), ("light source", 200)]-  , cplaceFreq    = [("battle", 50), ("rogue", 50)]-  , cpassable     = True-  , cdefTile      = "battleSet"-  , cdarkCorTile  = "trailLit"  -- let trails give off light-  , clitCorTile   = "trailLit"+raid = rogue+  { csymbol       = 'T'+  , cname         = "Typing den"+  , cfreq         = [("caveRaid", 1)]+  , cdarkChance   = 0  -- all rooms lit, for a gentle start+  , cmaxVoid      = 1%10+  , cactorCoeff   = 1000  -- deep level with no kit, so slow spawning+  , cactorFreq    = [("animal", 100)]+  , citemNum      = 6 * d 8  -- just one level, hard enemies, treasure+  , citemFreq     = [("useful", 33), ("gem", 33), ("currency", 33)]+  , cescapeGroup  = Just "escape up"   }-skirmish = rogue  -- many random solid tiles, to break LOS, since it's a day-  { csymbol       = 'S'+brawl = rogue  -- many random solid tiles, to break LOS, since it's a day+               -- and this scenario is not focused on ranged combat;+               -- also, sanctuaries against missiles in shadow under trees+  { csymbol       = 'b'   , cname         = "Sunny woodland"-  , cfreq         = [("caveSkirmish", 1)]-  , cgrid         = DiceXY (2 * d 2 + 2) (d 2 + 2)+  , cfreq         = [("caveBrawl", 1)]+  , cgrid         = DiceXY (2 * d 2 + 2) 3   , cminPlaceSize = DiceXY 3 3   , cmaxPlaceSize = DiceXY 7 5-  , cdarkChance   = 100+  , cdarkChance   = 51   , cnightChance  = 0   , cdoorChance   = 1   , copenChance   = 0-  , chidden       = 1000+  , cextraStairs  = 1+  , chidden       = 0   , cactorFreq    = []-  , citemNum      = 20 * d 2+  , citemNum      = 5 * d 8   , citemFreq     = [("useful", 100)]-  , cplaceFreq    = [("skirmish", 60), ("rogue", 40)]+  , cplaceFreq    = [("brawl", 60), ("rogue", 40)]   , cpassable     = True-  , cdefTile      = "skirmishSet"+  , cdefTile      = "brawlSetLit"   , cdarkCorTile  = "floorArenaLit"   , clitCorTile   = "floorArenaLit"   }-ambush = rogue  -- lots of lights, to give a chance to snipe+shootout = rogue  -- a scenario with strong missiles;+                  -- few solid tiles, but only translucent tiles or walkable+                  -- opaque tiles, to make scouting and sniping more interesting+                  -- and to avoid obstructing view too much, since this+                  -- scenario is about ranged combat at long range+  { csymbol       = 'S'+  , cname         = "Misty meadow"+  , cfreq         = [("caveShootout", 1)]+  , cgrid         = DiceXY (d 2 + 7) 3+  , cminPlaceSize = DiceXY 3 3+  , cmaxPlaceSize = DiceXY 3 4+  , cdarkChance   = 51+  , cnightChance  = 0+  , cdoorChance   = 1+  , copenChance   = 0+  , cextraStairs  = 1+  , chidden       = 0+  , cactorFreq    = []+  , citemNum      = 5 * d 16+                      -- less items in inventory, more to be picked up,+                      -- to reward explorer and aggressor and punish camper+  , citemFreq     = [ ("useful", 30)+                    , ("any arrow", 400), ("harpoon", 300)+                    , ("any vial", 60) ]+                      -- Many consumable buffs are needed in symmetric maps+                      -- so that aggresor prepares them in advance and camper+                      -- needs to waste initial turns to buff for the defence.+  , cplaceFreq    = [("shootout", 100)]+  , cpassable     = True+  , cdefTile      = "shootoutSetLit"+  , cdarkCorTile  = "floorArenaLit"+  , clitCorTile   = "floorArenaLit"+  }+escape = rogue  -- a scenario with weak missiles, because heroes don't depend+                -- on them; dark, so solid obstacles are to hide from missiles,+                -- not view; obstacles are not lit, to frustrate the AI;+                -- lots of small lights to cross, to have some risks+  { csymbol       = 'E'+  , cname         = "Metropolitan park at dusk"  -- "night" didn't fit+  , cfreq         = [("caveEscape", 1)]+  , cgrid         = DiceXY -- (2 * d 2 + 3) 4  -- park, so lamps in lines+                           (2 * d 2 + 6) 3   -- for now, to fit larger places+  , cminPlaceSize = DiceXY 3 3+  , cmaxPlaceSize = DiceXY 9 9  -- bias towards larger lamp areas+  , cdarkChance   = 51  -- colonnade rooms should always be dark+  , cnightChance  = 51  -- always night+  , cauxConnects  = 3%2+  , cmaxVoid      = 1%20+  , cextraStairs  = 1+  , chidden       = 0+  , cactorFreq    = []+  , citemNum      = 5 * d 8+  , citemFreq     = [ ("useful", 30), ("treasure", 30), ("gem", 100)+                    , ("weak arrow", 500), ("harpoon", 400) ]+  , cplaceFreq    = [("park", 100)]  -- the same rooms as in ambush+  , cpassable     = True+  , cdefTile      = "escapeSetDark"  -- different tiles, not burning yet+  , cdarkCorTile  = "trailLit"  -- let trails give off light+  , clitCorTile   = "trailLit"+  , cescapeGroup  = Just "escape outdoor down"+  }+zoo = rogue  -- few lights and many solids, to help the less numerous heroes+  { csymbol       = 'Z'+  , cname         = "Menagerie in flames"+  , cfreq         = [("caveZoo", 1)]+  , cgrid         = DiceXY (2 * d 2 + 6) 3+  , cminPlaceSize = DiceXY 4 4+  , cmaxPlaceSize = DiceXY 12 12+  , cdarkChance   = 51  -- always dark rooms+  , cnightChance  = 51  -- always night+  , cauxConnects  = 1%4+  , cmaxVoid      = 1%20+  , cdoorChance   = 2%10+  , copenChance   = 9%10+  , cextraStairs  = 1+  , chidden       = 0+  , cactorFreq    = []+  , citemNum      = 7 * d 8+  , citemFreq     = [("useful", 100), ("light source", 1000)]+  , cplaceFreq    = [("zoo", 50)]+  , cpassable     = True+  , cdefTile      = "zooSet"+  , cdarkCorTile  = "trailLit"  -- let trails give off light+  , clitCorTile   = "trailLit"+  }+ambush = rogue  -- a scenario with strong missiles;+                -- dark, so solid obstacles are to hide from missiles,+                -- not view, and they are all lit, because stopped missiles+                -- are frustrating, while a few LOS-only obstacles are not lit;+                -- lots of small lights to cross, to give a chance to snipe;+                -- a crucial difference wrt shootout is that trajectories+                -- of missiles are usually not seen, so enemy can't be guessed;+                -- camping doesn't pay off, because enemies can sneak and only+                -- active scouting, throwing flares and shooting discovers them   { csymbol       = 'M'-  , cname         = "Public garden at night"+  , cname         = "Burning metropolitan park"   , cfreq         = [("caveAmbush", 1)]-  , cgrid         = DiceXY (2 * d 2 + 3) (d 2 + 2)+  , cgrid         = DiceXY -- (2 * d 2 + 3) 4  -- park, so lamps in lines+                           (2 * d 2 + 5) 3   -- for now, to fit larger places   , cminPlaceSize = DiceXY 3 3-  , cmaxPlaceSize = DiceXY 5 5-  , cdarkChance   = 0+  , cmaxPlaceSize = DiceXY 9 9  -- bias towards larger lamp areas+  , cdarkChance   = 51  -- colonnade rooms should always be dark   , cnightChance  = 51  -- always night-  , cauxConnects  = 1-  , cdoorChance   = 1%10-  , copenChance   = 9%10-  , chidden       = 1000+  , cauxConnects  = 3%2+  , cmaxVoid      = 1%20+  , cextraStairs  = 1+  , chidden       = 0   , cactorFreq    = []-  , citemNum      = 22 * d 2-  , citemFreq     = [("useful", 100)]-  , cplaceFreq    = [("ambush", 100)]+  , citemNum      = 5 * d 8+  , citemFreq     = [("useful", 30), ("any arrow", 400), ("harpoon", 300)]+  , cplaceFreq    = [("park", 100)]   , cpassable     = True   , cdefTile      = "ambushSet"   , cdarkCorTile  = "trailLit"  -- let trails give off light   , clitCorTile   = "trailLit"   }-safari1 = ambush {cfreq = [("caveSafari1", 1)]}-safari2 = battle {cfreq = [("caveSafari2", 1)]}-safari3 = skirmish {cfreq = [("caveSafari3", 1)]}-rogueLit = rogue-  { csymbol       = 'S'-  , cname         = "Typing den"-  , cfreq         = [("caveRogueLit", 1)]-  , cdarkChance   = 0-  , cmaxVoid      = 1%10-  , cactorCoeff   = 1000  -- deep level with no eqp, so slow spawning-  , cactorFreq    = [("animal", 100)]-  , citemNum      = 30 * d 2  -- just one level, hard enemies, treasure-  , citemFreq     = [("useful", 33), ("gem", 33), ("currency", 33)]-  }-boardgame = CaveKind+battle = rogue  -- few lights and many solids, to help the less numerous heroes   { csymbol       = 'B'-  , cname         = "A boardgame"-  , cfreq         = [("caveBoardgame", 1)]-  , cxsize        = fst normalLevelBound + 1-  , cysize        = snd normalLevelBound + 1-  , cgrid         = DiceXY 1 1-  , cminPlaceSize = DiceXY 10 10-  , cmaxPlaceSize = DiceXY 10 10+  , cname         = "Old battle ground"+  , cfreq         = [("caveBattle", 1)]+  , cgrid         = DiceXY (2 * d 2 + 1) 3+  , cminPlaceSize = DiceXY 4 4+  , cmaxPlaceSize = DiceXY 9 7   , cdarkChance   = 0-  , cnightChance  = 0-  , cauxConnects  = 0-  , cmaxVoid      = 0-  , cminStairDist = 0-  , cdoorChance   = 0-  , copenChance   = 0+  , cnightChance  = 51  -- always night+  , cauxConnects  = 1%4+  , cmaxVoid      = 1%20+  , cdoorChance   = 2%10+  , copenChance   = 9%10+  , cextraStairs  = 1   , chidden       = 0-  , cactorCoeff   = 0   , cactorFreq    = []-  , citemNum      = 0-  , citemFreq     = []-  , cplaceFreq    = [("boardgame", 1)]-  , cpassable     = False-  , cdefTile        = "fillerWall"-  , cdarkCorTile    = "floorCorridorDark"-  , clitCorTile     = "floorCorridorLit"-  , cfillerTile     = "fillerWall"-  , couterFenceTile = "basic outer fence"-  , clegendDarkTile = "legendDark"-  , clegendLitTile  = "legendLit"+  , citemNum      = 5 * d 8+  , citemFreq     = [("useful", 100), ("light source", 200)]+  , cplaceFreq    = [("battle", 50), ("rogue", 50)]+  , cpassable     = True+  , cdefTile      = "battleSet"+  , cdarkCorTile  = "trailLit"  -- let trails give off light+  , clitCorTile   = "trailLit"+  , couterFenceTile = "noise fence"  -- ensures no cut-off parts from collapsed+  }+safari1 = brawl+  { cname = "Hunam habitat"+  , cfreq = [("caveSafari1", 1)]+  , cescapeGroup = Nothing+  , cstairFreq = [("staircase outdoor", 1)]+  }+safari2 = ambush+  { cname = "Hunting grounds"+  , cfreq = [("caveSafari2", 1)]+  , cstairFreq = [("staircase outdoor", 1)]+  }+safari3 = zoo+  { cfreq = [("caveSafari3", 1)]+  , cescapeGroup = Just "escape outdoor down"+  , cstairFreq = [("staircase outdoor", 1)]   }

GameDefinition/Content/ItemKind.hs view

@@ -1,993 +1,1237 @@ -- | Item and treasure definitions.-module Content.ItemKind ( cdefs ) where--import qualified Data.EnumMap.Strict as EM-import Data.List--import Content.ItemKindActor-import Content.ItemKindBlast-import Content.ItemKindOrgan-import Content.ItemKindTemporary-import Game.LambdaHack.Common.Ability-import Game.LambdaHack.Common.Color-import Game.LambdaHack.Common.ContentDef-import Game.LambdaHack.Common.Dice-import Game.LambdaHack.Common.Flavour-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Content.ItemKind--cdefs :: ContentDef ItemKind-cdefs = ContentDef-  { getSymbol = isymbol-  , getName = iname-  , getFreq = ifreq-  , validateSingle = validateSingleItemKind-  , validateAll = validateAllItemKind-  , content = items ++ organs ++ blasts ++ actors ++ temporaries-  }--items :: [ItemKind]-items =-  [dart, dart200, paralizingProj, harpoon, net, jumpingPole, sharpeningTool, seeingItem, light1, light2, light3, gorget, necklace1, necklace2, necklace3, necklace4, necklace5, necklace6, necklace7, necklace8, necklace9, sightSharpening, ring1, ring2, ring3, ring4, ring5, ring6, ring7, ring8, potion1, potion2, potion3, potion4, potion5, potion6, potion7, potion8, potion9, flask1, flask2, flask3, flask4, flask5, flask6, flask7, flask8, flask9, flask10, flask11, flask12, flask13, flask14, scroll1, scroll2, scroll3, scroll4, scroll5, scroll6, scroll7, scroll8, scroll9, scroll10, scroll11, armorLeather, armorMail, gloveFencing, gloveGauntlet, gloveJousting, buckler, shield, dagger, daggerDropBestWeapon, hammer, hammerParalyze, hammerSpark, sword, swordImpress, swordNullify, halberd, halberdPushActor, wand1, wand2, gem1, gem2, gem3, gem4, currency]--dart,    dart200, paralizingProj, harpoon, net, jumpingPole, sharpeningTool, seeingItem, light1, light2, light3, gorget, necklace1, necklace2, necklace3, necklace4, necklace5, necklace6, necklace7, necklace8, necklace9, sightSharpening, ring1, ring2, ring3, ring4, ring5, ring6, ring7, ring8, potion1, potion2, potion3, potion4, potion5, potion6, potion7, potion8, potion9, flask1, flask2, flask3, flask4, flask5, flask6, flask7, flask8, flask9, flask10, flask11, flask12, flask13, flask14, scroll1, scroll2, scroll3, scroll4, scroll5, scroll6, scroll7, scroll8, scroll9, scroll10, scroll11, armorLeather, armorMail, gloveFencing, gloveGauntlet, gloveJousting, buckler, shield, dagger, daggerDropBestWeapon, hammer, hammerParalyze, hammerSpark, sword, swordImpress, swordNullify, halberd, halberdPushActor, wand1, wand2, gem1, gem2, gem3, gem4, currency :: ItemKind--necklace, ring, potion, flask, scroll, wand, gem :: ItemKind  -- generic templates---- * Item group symbols, partially from Nethack--symbolProjectile, _symbolLauncher, symbolLight, symbolTool, symbolGem, symbolGold, symbolNecklace, symbolRing, symbolPotion, symbolFlask, symbolScroll, symbolTorsoArmor, symbolMiscArmor, _symbolClothes, symbolShield, symbolPolearm, symbolEdged, symbolHafted, symbolWand, _symbolStaff, _symbolFood :: Char--symbolProjectile = '|'-_symbolLauncher  = '}'-symbolLight      = '('-symbolTool       = '('-symbolGem        = '*'-symbolGold       = '$'-symbolNecklace   = '"'-symbolRing       = '='-symbolPotion     = '!'  -- concoction, bottle, jar, vial, canister-symbolFlask      = '!'-symbolScroll     = '?'  -- book, note, tablet, remote-symbolTorsoArmor = '['-symbolMiscArmor  = '['-_symbolClothes   = '('-symbolShield     = '['-symbolPolearm    = ')'-symbolEdged      = ')'-symbolHafted     = ')'-symbolWand       = '/'  -- magical rod, transmitter, pistol, rifle-_symbolStaff     = '_'  -- scanner-_symbolFood      = ','  -- too easy to miss?---- * Thrown weapons--dart = ItemKind-  { isymbol  = symbolProjectile-  , iname    = "dart"-  , ifreq    = [("useful", 100), ("any arrow", 100)]-  , iflavour = zipPlain [Cyan]-  , icount   = 4 * d 3-  , irarity  = [(1, 10), (10, 20)]-  , iverbHit = "nick"-  , iweight  = 50-  , iaspects = [AddHurtRanged (d 3 + dl 6 |*| 20)]-  , ieffects = [Hurt (2 * d 1)]-  , ifeature = [Identified]-  , idesc    = "Little, but sharp and sturdy."  -- "Much inferior to arrows though, especially given the contravariance problems."  --- funny, but destroy the suspension of disbelief; this is supposed to be a Lovecraftian horror and any hilarity must ensue from the failures in making it so and not from actively trying to be funny; also, mundane objects are not supposed to be scary or transcendental; the scare is in horrors from the abstract dimension visiting our ordinary reality; without the contrast there's no horror and no wonder, so also the magical items must be contrasted with ordinary XIX century and antique items-  , ikit     = []-  }-dart200 = ItemKind-  { isymbol  = symbolProjectile-  , iname    = "fine dart"-  , ifreq    = [("useful", 100), ("any arrow", 50)]  -- TODO: until arrows added-  , iflavour = zipPlain [BrRed]-  , icount   = 4 * d 3-  , irarity  = [(1, 20), (10, 10)]-  , iverbHit = "prick"-  , iweight  = 50-  , iaspects = [AddHurtRanged (d 3 + dl 6 |*| 20)]-  , ieffects = [Hurt (1 * d 1)]-  , ifeature = [toVelocity 200, Identified]-  , idesc    = "Finely balanced for throws of great speed."-  , ikit     = []-  }---- * Exotic thrown weapons--paralizingProj = ItemKind-  { isymbol  = symbolProjectile-  , iname    = "bolas set"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [BrYellow]-  , icount   = dl 4-  , irarity  = [(5, 5), (10, 5)]-  , iverbHit = "entangle"-  , iweight  = 500-  , iaspects = []-  , ieffects = [Hurt (2 * d 1), Paralyze (5 + d 5), DropBestWeapon]-  , ifeature = [Identified]-  , idesc    = "Wood balls tied with hemp rope. The target enemy is tripped and bound to drop the main weapon, while fighting for balance."-  , ikit     = []-  }-harpoon = ItemKind-  { isymbol  = symbolProjectile-  , iname    = "harpoon"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [Brown]-  , icount   = dl 5-  , irarity  = [(10, 10)]-  , iverbHit = "hook"-  , iweight  = 4000-  , iaspects = [AddHurtRanged (d 2 + dl 5 |*| 20)]-  , ieffects = [Hurt (4 * d 1), PullActor (ThrowMod 200 50)]-  , ifeature = [Identified]-  , idesc    = "The cruel, barbed head lodges in its victim so painfully that the weakest tug of the thin line sends the victim flying."-  , ikit     = []-  }-net = ItemKind-  { isymbol  = symbolProjectile-  , iname    = "net"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [White]-  , icount   = dl 3-  , irarity  = [(3, 5), (10, 4)]-  , iverbHit = "entangle"-  , iweight  = 1000-  , iaspects = []-  , ieffects = [ toOrganGameTurn "slow 10" (3 + d 3)-               , DropItem CEqp "torso armor" False ]-  , ifeature = [Identified]-  , idesc    = "A wide net with weights along the edges. Entangles armor and restricts movement."-  , ikit     = []-  }---- * Assorted tools--jumpingPole = ItemKind-  { isymbol  = symbolTool-  , iname    = "jumping pole"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [White]-  , icount   = 1-  , irarity  = [(1, 2)]-  , iverbHit = "prod"-  , iweight  = 10000-  , iaspects = [Timeout $ d 2 + 2 - dl 2 |*| 10]-  , ieffects = [Recharging (toOrganActorTurn "fast 20" 1)]-  , ifeature = [Durable, Applicable, Identified]-  , idesc    = "Makes you vulnerable at take-off, but then you are free like a bird."-  , ikit     = []-  }-sharpeningTool = ItemKind-  { isymbol  = symbolTool-  , iname    = "whetstone"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [Blue]-  , icount   = 1-  , irarity  = [(10, 10)]-  , iverbHit = "smack"-  , iweight  = 400-  , iaspects = [AddHurtMelee $ d 10 |*| 3]-  , ieffects = []-  , ifeature = [EqpSlot EqpSlotAddHurtMelee "", Identified]-  , idesc    = "A portable sharpening stone that lets you fix your weapons between or even during fights, without the need to set up camp, fish out tools and assemble a proper sharpening workshop."-  , ikit     = []-  }-seeingItem = ItemKind-  { isymbol  = '%'-  , iname    = "pupil"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [Red]-  , icount   = 1-  , irarity  = [(1, 1)]-  , iverbHit = "gaze at"-  , iweight  = 100-  , iaspects = [ AddSight 10, AddMaxCalm 60, AddLight 2-               , Periodic, Timeout $ 1 + d 2 ]-  , ieffects = [ Recharging (toOrganNone "poisoned")-               , Recharging (Summon [("mobile monster", 1)] 1) ]-  , ifeature = [Identified]-  , idesc    = "A slimy, dilated green pupil torn out from some giant eye. Clear and focused, as if still alive."-  , ikit     = []-  }---- * Lights--light1 = ItemKind-  { isymbol  = symbolLight-  , iname    = "wooden torch"-  , ifreq    = [("useful", 100), ("light source", 100)]-  , iflavour = zipPlain [Brown]-  , icount   = d 2-  , irarity  = [(1, 10)]-  , iverbHit = "scorch"-  , iweight  = 1200-  , iaspects = [ AddLight 3       -- not only flashes, but also sparks-               , AddSight (-2) ]  -- unused by AI due to the mixed blessing-  , ieffects = [Burn 2]-  , ifeature = [EqpSlot EqpSlotAddLight "", Identified]-  , idesc    = "A smoking, heavy wooden torch, burning in an unsteady glow."-  , ikit     = []-  }-light2 = ItemKind-  { isymbol  = symbolLight-  , iname    = "oil lamp"-  , ifreq    = [("useful", 100), ("light source", 100)]-  , iflavour = zipPlain [BrYellow]-  , icount   = 1-  , irarity  = [(6, 7)]-  , iverbHit = "burn"-  , iweight  = 1000-  , iaspects = [AddLight 3, AddSight (-1)]-  , ieffects = [Burn 3, Paralyze 3, OnSmash (Explode "burning oil 3")]-  , ifeature = [ toVelocity 70  -- hard not to spill the oil while throwing-               , Fragile, EqpSlot EqpSlotAddLight "", Identified ]-  , idesc    = "A clay lamp filled with plant oil feeding a tiny wick."-  , ikit     = []-  }-light3 = ItemKind-  { isymbol  = symbolLight-  , iname    = "brass lantern"-  , ifreq    = [("useful", 100), ("light source", 100)]-  , iflavour = zipPlain [BrWhite]-  , icount   = 1-  , irarity  = [(10, 5)]-  , iverbHit = "burn"-  , iweight  = 2400-  , iaspects = [AddLight 4, AddSight (-1)]-  , ieffects = [Burn 4, Paralyze 4, OnSmash (Explode "burning oil 4")]-  , ifeature = [ toVelocity 70  -- hard to throw so that it opens and burns-               , Fragile, EqpSlot EqpSlotAddLight "", Identified ]-  , idesc    = "Very bright and very heavy brass lantern."-  , ikit     = []-  }---- * Periodic jewelry--gorget = ItemKind-  { isymbol  = symbolNecklace-  , iname    = "Old Gorget"-  , ifreq    = [("useful", 100)]-  , iflavour = zipFancy [BrCyan]-  , icount   = 1-  , irarity  = [(4, 3), (10, 3)]  -- weak, shallow-  , iverbHit = "whip"-  , iweight  = 30-  , iaspects = [ Unique-               , Periodic-               , Timeout $ 1 + d 2-               , AddArmorMelee $ 2 + d 3-               , AddArmorRanged $ 2 + d 3 ]-  , ieffects = [Recharging (RefillCalm 1)]-  , ifeature = [ Durable, Precious, EqpSlot EqpSlotPeriodic ""-               , Identified, toVelocity 50 ]  -- not dense enough-  , idesc    = "Highly ornamental, cold, large, steel medallion on a chain. Unlikely to offer much protection as an armor piece, but the old, worn engraving reassures you."-  , ikit     = []-  }-necklace = ItemKind-  { isymbol  = symbolNecklace-  , iname    = "necklace"-  , ifreq    = [("useful", 100)]-  , iflavour = zipFancy stdCol ++ zipPlain brightCol-  , icount   = 1-  , irarity  = [(10, 2)]-  , iverbHit = "whip"-  , iweight  = 30-  , iaspects = [Periodic]-  , ieffects = []-  , ifeature = [ Precious, EqpSlot EqpSlotPeriodic ""-               , toVelocity 50 ]  -- not dense enough-  , idesc    = "Menacing Greek symbols shimmer with increasing speeds along a chain of fine encrusted links. After a tense build-up, a prismatic arc shoots towards the ground and the iridescence subdues, becomes ordered and resembles a harmless ornament again, for a time."-  , ikit     = []-  }-necklace1 = necklace-  { ifreq    = [("treasure", 100)]-  , iaspects = [Unique, Timeout $ d 3 + 4 - dl 3 |*| 10]-               ++ iaspects necklace-  , ieffects = [NoEffect "of Aromata", Recharging (RefillHP 1)]-  , ifeature = Durable : ifeature necklace-  , idesc    = "A cord of freshly dried herbs and healing berries."-  }-necklace2 = necklace-  { ifreq    = [("treasure", 100)]  -- just too nasty to call it useful-  , irarity  = [(1, 1)]-  , iaspects = (Timeout $ d 3 + 3 - dl 3 |*| 10) : iaspects necklace-  , ieffects = [ Recharging Impress-               , Recharging (DropItem COrgan "temporary conditions" True)-               , Recharging (Summon [("mobile animal", 1)] $ 1 + dl 2)-               , Recharging (Explode "waste") ]-  }-necklace3 = necklace-  { iaspects = (Timeout $ d 3 + 3 - dl 3 |*| 10) : iaspects necklace-  , ieffects = [Recharging (Paralyze $ 5 + d 5 + dl 5)]-  }-necklace4 = necklace-  { iaspects = (Timeout $ d 4 + 4 - dl 4 |*| 2) : iaspects necklace-  , ieffects = [Recharging (Teleport $ d 2 * 3)]-  }-necklace5 = necklace-  { iaspects = (Timeout $ d 3 + 4 - dl 3 |*| 10) : iaspects necklace-  , ieffects = [Recharging (Teleport $ 14 + d 3 * 3)]-  }-necklace6 = necklace-  { iaspects = (Timeout $ d 4 |*| 10) : iaspects necklace-  , ieffects = [Recharging (PushActor (ThrowMod 100 50))]-  }-necklace7 = necklace  -- TODO: teach AI to wear only for fight-  { ifreq    = [("treasure", 100)]-  , iaspects = [ Unique, AddMaxHP $ 10 + d 10-               , AddArmorMelee 20, AddArmorRanged 20-               , Timeout $ d 2 + 5 - dl 3 ]-               ++ iaspects necklace-  , ieffects = [ NoEffect "of Overdrive"-               , Recharging (InsertMove $ 1 + d 2)-               , Recharging (RefillHP (-1))-               , Recharging (RefillCalm (-1)) ]-  , ifeature = Durable : ifeature necklace-  }-necklace8 = necklace-  { iaspects = (Timeout $ d 3 + 3 - dl 3 |*| 5) : iaspects necklace-  , ieffects = [Recharging $ Explode "spark"]-  }-necklace9 = necklace-  { iaspects = (Timeout $ d 3 + 3 - dl 3 |*| 5) : iaspects necklace-  , ieffects = [Recharging $ Explode "fragrance"]-  }---- * Non-periodic jewelry--sightSharpening = ItemKind-  { isymbol  = symbolRing-  , iname    = "Sharp Monocle"-  , ifreq    = [("treasure", 100)]-  , iflavour = zipPlain [White]-  , icount   = 1-  , irarity  = [(7, 3), (10, 3)]  -- medium weak, medium shallow-  , iverbHit = "rap"-  , iweight  = 50-  , iaspects = [Unique, AddSight $ 1 + d 2, AddHurtMelee $ d 2 |*| 3]-  , ieffects = []-  , ifeature = [ Precious, Identified, Durable-               , EqpSlot EqpSlotAddSight "" ]-  , idesc    = "Let's you better focus your weaker eye."-  , ikit     = []-  }--- Don't add standard effects to rings, because they go in and out--- of eqp and so activating them would require UI tedium: looking for--- them in eqp and inv or even activating a wrong item via letter by mistake.-ring = ItemKind-  { isymbol  = symbolRing-  , iname    = "ring"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain stdCol ++ zipFancy darkCol-  , icount   = 1-  , irarity  = [(10, 3)]-  , iverbHit = "knock"-  , iweight  = 15-  , iaspects = []-  , ieffects = [Explode "blast 20"]-  , ifeature = [Precious, Identified]-  , idesc    = "It looks like an ordinary object, but it's in fact a generator of exceptional effects: adding to some of your natural abilities and subtracting from others. You'd profit enormously if you could find a way to multiply such generators."-  , ikit     = []-  }-ring1 = ring-  { irarity  = [(10, 2)]-  , iaspects = [AddSpeed $ 1 + d 2, AddMaxHP $ dl 7 - 7 - d 7]-  , ieffects = [Explode "distortion"]  -- strong magic-  , ifeature = ifeature ring ++ [EqpSlot EqpSlotAddSpeed ""]-  }-ring2 = ring-  { irarity  = [(10, 5)]-  , iaspects = [AddMaxHP $ 10 + dl 10, AddMaxCalm $ dl 5 - 20 - d 5]-  , ifeature = ifeature ring ++ [EqpSlot EqpSlotAddMaxHP ""]-  }-ring3 = ring-  { irarity  = [(10, 5)]-  , iaspects = [AddMaxCalm $ 29 + dl 10]-  , ifeature = ifeature ring ++ [EqpSlot EqpSlotAddMaxCalm ""]-  , idesc    = "Cold, solid to the touch, perfectly round, engraved with solemn, strangely comforting, worn out words."-  }-ring4 = ring-  { irarity  = [(3, 3), (10, 5)]-  , iaspects = [AddHurtMelee $ d 5 + dl 5 |*| 3, AddMaxHP $ dl 3 - 5 - d 3]-  , ifeature = ifeature ring ++ [EqpSlot EqpSlotAddHurtMelee ""]-  }-ring5 = ring  -- by the time it's found, probably no space in eqp-  { irarity  = [(5, 0), (10, 2)]-  , iaspects = [AddLight $ d 2]-  , ieffects = [Explode "distortion"]  -- strong magic-  , ifeature = ifeature ring ++ [EqpSlot EqpSlotAddLight ""]-  , idesc    = "A sturdy ring with a large, shining stone."-  }-ring6 = ring-  { ifreq    = [("treasure", 100)]-  , irarity  = [(10, 2)]-  , iaspects = [ Unique, AddSpeed $ 3 + d 4-               , AddMaxCalm $ - 20 - d 20, AddMaxHP $ - 20 - d 20 ]-  , ieffects = [NoEffect "of Rush"]  -- no explosion, because Durable-  , ifeature = ifeature ring ++ [Durable, EqpSlot EqpSlotAddSpeed ""]-  }-ring7 = ring-  { ifreq    = [("useful", 100), ("ring of opportunity sniper", 1) ]-  , irarity  = [(1, 1)]-  , iaspects = [AddSkills $ EM.fromList [(AbProject, 8)]]-  , ieffects = [ NoEffect "of opportunity sniper"-               , Explode "distortion" ]  -- strong magic-  , ifeature = ifeature ring ++ [EqpSlot (EqpSlotAddSkills AbProject) ""]-  }-ring8 = ring-  { ifreq    = [("useful", 1), ("ring of opportunity grenadier", 1) ]-  , irarity  = [(1, 1)]-  , iaspects = [AddSkills $ EM.fromList [(AbProject, 11)]]-  , ieffects = [ NoEffect "of opportunity grenadier"-               , Explode "distortion" ]  -- strong magic-  , ifeature = ifeature ring ++ [EqpSlot (EqpSlotAddSkills AbProject) ""]-  }---- * Ordinary exploding consumables, often intended to be thrown--potion = ItemKind-  { isymbol  = symbolPotion-  , iname    = "potion"-  , ifreq    = [("useful", 100)]-  , iflavour = zipLiquid brightCol ++ zipPlain brightCol ++ zipFancy brightCol-  , icount   = 1-  , irarity  = [(1, 12), (10, 9)]-  , iverbHit = "splash"-  , iweight  = 200-  , iaspects = []-  , ieffects = []-  , ifeature = [ toVelocity 50  -- oily, bad grip-               , Applicable, Fragile ]-  , idesc    = "A vial of bright, frothing concoction."  -- purely natural; no maths, no magic-  , ikit     = []-  }-potion1 = potion-  { ieffects = [ NoEffect "of rose water", Impress, RefillCalm (-3)-               , OnSmash ApplyPerfume, OnSmash (Explode "fragrance") ]-  }-potion2 = potion-  { ifreq    = [("treasure", 100)]-  , irarity  = [(6, 10), (10, 10)]-  , iaspects = [Unique]-  , ieffects = [ NoEffect "of Attraction", Impress, OverfillCalm (-20)-               , OnSmash (Explode "pheromone") ]-  }-potion3 = potion-  { irarity  = [(1, 10)]-  , ieffects = [ RefillHP 5, DropItem COrgan "poisoned" True-               , OnSmash (Explode "healing mist") ]-  }-potion4 = potion-  { irarity  = [(10, 10)]-  , ieffects = [ RefillHP 10, DropItem COrgan "poisoned" True-               , OnSmash (Explode "healing mist 2") ]-  }-potion5 = potion-  { ieffects = [ OneOf [ OverfillHP 10, OverfillHP 5, Burn 5-                       , toOrganActorTurn "strengthened" (20 + d 5) ]-               , OnSmash (OneOf [ Explode "healing mist"-                                , Explode "wounding mist"-                                , Explode "fragrance"-                                , Explode "smelly droplet"-                                , Explode "blast 10" ]) ]-  }-potion6 = potion-  { irarity  = [(3, 3), (10, 6)]-  , ieffects = [ Impress-               , OneOf [ OverfillCalm (-60)-                       , OverfillHP 20, OverfillHP 10, Burn 10-                       , toOrganActorTurn "fast 20" (20 + d 5) ]-               , OnSmash (OneOf [ Explode "healing mist 2"-                                , Explode "calming mist"-                                , Explode "distressing odor"-                                , Explode "eye drop"-                                , Explode "blast 20" ]) ]-  }-potion7 = potion-  { irarity  = [(1, 15), (10, 5)]-  , ieffects = [ DropItem COrgan "poisoned" True-               , OnSmash (Explode "antidote mist") ]-  }-potion8 = potion-  { irarity  = [(1, 5), (10, 15)]-  , ieffects = [ DropItem COrgan "temporary conditions" True-               , OnSmash (Explode "blast 10") ]-  }-potion9 = potion-  { ifreq    = [("treasure", 100)]-  , irarity  = [(10, 5)]-  , iaspects = [Unique]-  , ieffects = [ NoEffect "of Love", OverfillHP 60-               , Impress, OverfillCalm (-60)-               , OnSmash (Explode "healing mist 2")-               , OnSmash (Explode "pheromone") ]-  }---- * Exploding consumables with temporary aspects, can be thrown--- TODO: dip projectiles in those--- TODO: add flavour and realism as in, e.g., "flask of whiskey",--- which is more flavourful and believable than "flask of strength"--flask = ItemKind-  { isymbol  = symbolFlask-  , iname    = "flask"-  , ifreq    = [("useful", 100), ("flask", 100)]-  , iflavour = zipLiquid darkCol ++ zipPlain darkCol ++ zipFancy darkCol-  , icount   = 1-  , irarity  = [(1, 9), (10, 6)]-  , iverbHit = "splash"-  , iweight  = 500-  , iaspects = []-  , ieffects = []-  , ifeature = [ toVelocity 50  -- oily, bad grip-               , Applicable, Fragile ]-  , idesc    = "A flask of oily liquid of a suspect color."-  , ikit     = []-  }-flask1 = flask-  { irarity  = [(10, 5)]-  , ieffects = [ NoEffect "of strength brew"-               , toOrganActorTurn "strengthened" (20 + d 5)-               , toOrganNone "regenerating"-               , OnSmash (Explode "strength mist") ]-  }-flask2 = flask-  { ieffects = [ NoEffect "of weakness brew"-               , toOrganGameTurn "weakened" (20 + d 5)-               , OnSmash (Explode "weakness mist") ]-  }-flask3 = flask-  { ieffects = [ NoEffect "of protecting balm"-               , toOrganActorTurn "protected" (20 + d 5)-               , OnSmash (Explode "protecting balm") ]-  }-flask4 = flask-  { ieffects = [ NoEffect "of PhD defense questions"-               , toOrganGameTurn "defenseless" (20 + d 5)-               , OnSmash (Explode "PhD defense question") ]-  }-flask5 = flask-  { irarity  = [(10, 5)]-  , ieffects = [ NoEffect "of haste brew"-               , toOrganActorTurn "fast 20" (20 + d 5)-               , OnSmash (Explode "haste spray") ]-  }-flask6 = flask-  { ieffects = [ NoEffect "of lethargy brew"-               , toOrganGameTurn "slow 10" (20 + d 5)-               , toOrganNone "regenerating"-               , RefillCalm 3-               , OnSmash (Explode "slowness spray") ]-  }-flask7 = flask  -- sight can be reduced from Calm, drunk, etc.-  { irarity  = [(10, 7)]-  , ieffects = [ NoEffect "of eye drops"-               , toOrganActorTurn "far-sighted" (20 + d 5)-               , OnSmash (Explode "blast 10") ]-  }-flask8 = flask-  { irarity  = [(10, 3)]-  , ieffects = [ NoEffect "of smelly concoction"-               , toOrganActorTurn "keen-smelling" (20 + d 5)-               , OnSmash (Explode "blast 10") ]-  }-flask9 = flask-  { ieffects = [ NoEffect "of bait cocktail"-               , toOrganActorTurn "drunk" (5 + d 5)-               , OnSmash (Summon [("mobile animal", 1)] $ 1 + dl 2)-               , OnSmash (Explode "waste") ]-  }-flask10 = flask-  { ieffects = [ NoEffect "of whiskey"-               , toOrganActorTurn "drunk" (20 + d 5)-               , Impress, Burn 2, RefillHP 4-               , OnSmash (Explode "whiskey spray") ]-  }-flask11 = flask-  { irarity  = [(1, 20), (10, 10)]-  , ieffects = [ NoEffect "of regeneration brew"-               , toOrganNone "regenerating"-               , OnSmash (Explode "healing mist") ]-  }-flask12 = flask  -- but not flask of Calm depletion, since Calm reduced often-  { ieffects = [ NoEffect "of poison"-               , toOrganNone "poisoned"-               , OnSmash (Explode "wounding mist") ]-  }-flask13 = flask-  { irarity  = [(10, 5)]-  , ieffects = [ NoEffect "of slow resistance"-               , toOrganNone "slow resistant"-               , OnSmash (Explode "anti-slow mist") ]-  }-flask14 = flask-  { irarity  = [(10, 5)]-  , ieffects = [ NoEffect "of poison resistance"-               , toOrganNone "poison resistant"-               , OnSmash (Explode "antidote mist") ]-  }---- * Non-exploding consumables, not specifically designed for throwing--scroll = ItemKind-  { isymbol  = symbolScroll-  , iname    = "scroll"-  , ifreq    = [("useful", 100), ("any scroll", 100)]-  , iflavour = zipFancy stdCol ++ zipPlain darkCol  -- arcane and old-  , icount   = 1-  , irarity  = [(1, 15), (10, 12)]-  , iverbHit = "thump"-  , iweight  = 50-  , iaspects = []-  , ieffects = []-  , ifeature = [ toVelocity 25  -- bad shape, even rolled up-               , Applicable ]-  , idesc    = "Scraps of haphazardly scribbled mysteries from beyond. Is this equation an alchemical recipe? Is this diagram an extradimensional map? Is this formula a secret call sign?"-  , ikit     = []-  }-scroll1 = scroll-  { ifreq    = [("treasure", 100)]-  , irarity  = [(5, 10), (10, 10)]  -- mixed blessing, so available early-  , iaspects = [Unique]-  , ieffects = [ NoEffect "of Reckless Beacon"-               , CallFriend 1, Summon standardSummon (2 + d 2) ]-  }-scroll2 = scroll-  { irarity  = []-  , ieffects = []-  }-scroll3 = scroll-  { irarity  = [(1, 5), (10, 3)]-  , ieffects = [Ascend (-1)]-  }-scroll4 = scroll-  { ieffects = [OneOf [ Teleport 5, RefillCalm 5, RefillCalm (-5)-                      , InsertMove 5, Paralyze 10 ]]-  }-scroll5 = scroll-  { irarity  = [(10, 15)]-  , ieffects = [ Impress-               , OneOf [ Teleport 20, Ascend (-1), Ascend 1-                       , Summon standardSummon 2, CallFriend 1-                       , RefillCalm 5, OverfillCalm (-60)-                       , CreateItem CGround "useful" TimerNone ] ]-  }-scroll6 = scroll-  { ieffects = [Teleport 5]-  }-scroll7 = scroll-  { ieffects = [Teleport 20]-  }-scroll8 = scroll-  { irarity  = [(10, 3)]-  , ieffects = [InsertMove $ 1 + d 2 + dl 2]-  }-scroll9 = scroll  -- TODO: remove Calm when server can tell if anything IDed-  { irarity  = [(1, 15), (10, 10)]-  , ieffects = [ NoEffect "of scientific explanation"-               , Identify, OverfillCalm 3 ]-  }-scroll10 = scroll  -- TODO: firecracker only if an item really polymorphed?-                   -- But currently server can't tell.-  { irarity  = [(10, 10)]-  , ieffects = [ NoEffect "transfiguration"-               , PolyItem, Explode "firecracker 7" ]-  }-scroll11 = scroll-  { ifreq    = [("treasure", 100)]-  , irarity  = [(6, 10), (10, 10)]-  , iaspects = [Unique]-  , ieffects = [NoEffect "of Prisoner Release", CallFriend 1]-  }--standardSummon :: Freqs ItemKind-standardSummon = [("mobile monster", 30), ("mobile animal", 70)]---- * Armor--armorLeather = ItemKind-  { isymbol  = symbolTorsoArmor-  , iname    = "leather armor"-  , ifreq    = [("useful", 100), ("torso armor", 1)]-  , iflavour = zipPlain [Brown]-  , icount   = 1-  , irarity  = [(1, 9), (10, 3)]-  , iverbHit = "thud"-  , iweight  = 7000-  , iaspects = [ AddHurtMelee (-3)-               , AddArmorMelee $ 1 + d 2 + dl 2 |*| 5-               , AddArmorRanged $ 1 + d 2 + dl 2 |*| 5 ]-  , ieffects = []-  , ifeature = [ toVelocity 30  -- unwieldy to throw and blunt-               , Durable, EqpSlot EqpSlotAddArmorMelee "", Identified ]-  , idesc    = "A stiff jacket formed from leather boiled in bee wax. Smells much better than the rest of your garment."-  , ikit     = []-  }-armorMail = armorLeather-  { iname    = "mail armor"-  , iflavour = zipPlain [Cyan]-  , irarity  = [(6, 9), (10, 3)]-  , iweight  = 12000-  , iaspects = [ AddHurtMelee (-3)-               , AddArmorMelee $ 2 + d 2 + dl 3 |*| 5-               , AddArmorRanged $ 2 + d 2 + dl 3 |*| 5 ]-  , idesc    = "A long shirt woven from iron rings. Discourages foes from attacking your torso, making it harder for them to land a blow."-  }-gloveFencing = ItemKind-  { isymbol  = symbolMiscArmor-  , iname    = "leather gauntlet"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [BrYellow]-  , icount   = 1-  , irarity  = [(5, 9), (10, 9)]-  , iverbHit = "flap"-  , iweight  = 100-  , iaspects = [ AddHurtMelee $ (d 2 + dl 10) |*| 3-               , AddArmorRanged $ d 2 |*| 5 ]-  , ieffects = []-  , ifeature = [ toVelocity 30  -- flaps and flutters-               , Durable, EqpSlot EqpSlotAddArmorRanged "", Identified ]-  , idesc    = "A fencing glove from rough leather ensuring a good grip. Also quite effective in deflecting or even catching slow projectiles."-  , ikit     = []-  }-gloveGauntlet = gloveFencing-  { iname    = "steel gauntlet"-  , iflavour = zipPlain [BrCyan]-  , irarity  = [(1, 9), (10, 3)]-  , iweight  = 300-  , iaspects = [ AddArmorMelee $ 1 + dl 2 |*| 5-               , AddArmorRanged $ 1 + dl 2 |*| 5 ]-  , idesc    = "Long leather gauntlet covered in overlapping steel plates."-  }-gloveJousting = gloveFencing-  { iname    = "Tournament Gauntlet"-  , iflavour = zipFancy [BrRed]-  , irarity  = [(1, 3), (10, 3)]-  , iweight  = 500-  , iaspects = [ Unique-               , AddHurtMelee $ dl 4 - 6 |*| 3-               , AddArmorMelee $ 2 + dl 2 |*| 5-               , AddArmorRanged $ 2 + dl 2 |*| 5 ]-  , idesc    = "Rigid, steel, jousting handgear. If only you had a lance. And a horse."-  }---- * Shields---- Shield doesn't protect against ranged attacks to prevent--- micromanagement: walking with shield, melee without.-buckler = ItemKind-  { isymbol  = symbolShield-  , iname    = "buckler"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [Blue]-  , icount   = 1-  , irarity  = [(4, 6)]-  , iverbHit = "bash"-  , iweight  = 2000-  , iaspects = [ AddArmorMelee 40-               , AddHurtMelee (-30)-               , Timeout $ d 3 + 3 - dl 3 |*| 2 ]-  , ieffects = [ Hurt (1 * d 1)  -- to display xdy everywhre in Hurt-               , Recharging (PushActor (ThrowMod 200 50)) ]-  , ifeature = [ toVelocity 40  -- unwieldy to throw-               , Durable, EqpSlot EqpSlotAddArmorMelee "", Identified ]-  , idesc    = "Heavy and unwieldy. Absorbs a percentage of melee damage, both dealt and sustained. Too small to intercept projectiles with."-  , ikit     = []-  }-shield = buckler-  { iname    = "shield"-  , irarity  = [(8, 3)]-  , iflavour = zipPlain [Green]-  , iweight  = 3000-  , iaspects = [ AddArmorMelee 80-               , AddHurtMelee (-70)-               , Timeout $ d 6 + 6 - dl 6 |*| 2 ]-  , ieffects = [Hurt (1 * d 1), Recharging (PushActor (ThrowMod 400 50))]-  , ifeature = [ toVelocity 30  -- unwieldy to throw-               , Durable, EqpSlot EqpSlotAddArmorMelee "", Identified ]-  , idesc    = "Large and unwieldy. Absorbs a percentage of melee damage, both dealt and sustained. Too heavy to intercept projectiles with."-  }---- * Weapons--dagger = ItemKind-  { isymbol  = symbolEdged-  , iname    = "dagger"-  , ifreq    = [("useful", 100), ("starting weapon", 100)]-  , iflavour = zipPlain [BrCyan]-  , icount   = 1-  , irarity  = [(1, 20)]-  , iverbHit = "stab"-  , iweight  = 1000-  , iaspects = [ AddHurtMelee $ d 3 + dl 3 |*| 3-               , AddArmorMelee $ d 2 |*| 5-               , AddHurtRanged (-60) ]  -- as powerful as a dart-  , ieffects = [Hurt (6 * d 1)]-  , ifeature = [ toVelocity 40  -- ensuring it hits with the tip costs speed-               , Durable, EqpSlot EqpSlotWeapon "", Identified ]-  , idesc    = "A short dagger for thrusting and parrying blows. Does not penetrate deeply, but is hard to block. Especially useful in conjunction with a larger weapon."-  , ikit     = []-  }-daggerDropBestWeapon = dagger-  { iname    = "Double Dagger"-  , ifreq    = [("treasure", 20)]-  , irarity  = [(1, 2), (10, 4)]-  -- The timeout has to be small, so that the player can count on the effect-  -- occuring consistently in any longer fight. Otherwise, the effect will be-  -- absent in some important fights, leading to the feeling of bad luck,-  -- but will manifest sometimes in fights where it doesn't matter,-  -- leading to the feeling of wasted power.-  -- If the effect is very powerful and so the timeout has to be significant,-  -- let's make it really large, for the effect to occur only once in a fight:-  -- as soon as the item is equipped, or just on the first strike.-  , iaspects = [Unique, Timeout $ d 3 + 4 - dl 3 |*| 2]-  , ieffects = ieffects dagger-               ++ [Recharging DropBestWeapon, Recharging $ RefillCalm (-3)]-  , idesc    = "A double dagger that a focused fencer can use to catch and twist an opponent's blade occasionally."-  }-hammer = ItemKind-  { isymbol  = symbolHafted-  , iname    = "war hammer"-  , ifreq    = [("useful", 100), ("starting weapon", 100)]-  , iflavour = zipPlain [BrMagenta]-  , icount   = 1-  , irarity  = [(5, 15)]-  , iverbHit = "club"-  , iweight  = 1500-  , iaspects = [ AddHurtMelee $ d 2 + dl 2 |*| 3-               , AddHurtRanged (-80) ]  -- as powerful as a dart-  , ieffects = [Hurt (8 * d 1)]-  , ifeature = [ toVelocity 20  -- ensuring it hits with the sharp tip costs-               , Durable, EqpSlot EqpSlotWeapon "", Identified ]-  , idesc    = "It may not cause grave wounds, but neither does it glance off nor ricochet. Great sidearm for opportunistic blows against armored foes."-  , ikit     = []-  }-hammerParalyze = hammer-  { iname    = "Concussion Hammer"-  , ifreq    = [("treasure", 20)]-  , irarity  = [(5, 2), (10, 4)]-  , iaspects = [Unique, Timeout $ d 2 + 3 - dl 2 |*| 2]-  , ieffects = ieffects hammer ++ [Recharging $ Paralyze 5]-  }-hammerSpark = hammer-  { iname    = "Grand Smithhammer"-  , ifreq    = [("treasure", 20)]-  , irarity  = [(5, 2), (10, 4)]-  , iaspects = [Unique, Timeout $ d 4 + 4 - dl 4 |*| 2]-  , ieffects = ieffects hammer ++ [Recharging $ Explode "spark"]-  }-sword = ItemKind-  { isymbol  = symbolEdged-  , iname    = "sword"-  , ifreq    = [("useful", 100), ("starting weapon", 100)]-  , iflavour = zipPlain [BrBlue]-  , icount   = 1-  , irarity  = [(4, 1), (5, 15)]-  , iverbHit = "slash"-  , iweight  = 2000-  , iaspects = []-  , ieffects = [Hurt (10 * d 1)]-  , ifeature = [ toVelocity 5  -- ensuring it hits with the tip costs speed-               , Durable, EqpSlot EqpSlotWeapon "", Identified ]-  , idesc    = "Difficult to master; deadly when used effectively. The steel is particularly hard and keen, but rusts quickly without regular maintenance."-  , ikit     = []-  }-swordImpress = sword-  { iname    = "Master's Sword"-  , ifreq    = [("treasure", 20)]-  , irarity  = [(5, 1), (10, 4)]-  , iaspects = [Unique, Timeout $ d 4 + 5 - dl 4 |*| 2]-  , ieffects = ieffects sword ++ [Recharging Impress]-  , idesc    = "A particularly well-balance blade, lending itself to impressive shows of fencing skill."-  }-swordNullify = sword-  { iname    = "Gutting Sword"-  , ifreq    = [("treasure", 20)]-  , irarity  = [(5, 1), (10, 4)]-  , iaspects = [Unique, Timeout $ d 4 + 5 - dl 4 |*| 2]-  , ieffects = ieffects sword-               ++ [ Recharging $ DropItem COrgan "temporary conditions" True-                  , Recharging $ RefillHP (-2) ]-  , idesc    = "Cold, thin blade that pierces deeply and sends its victim into abrupt, sobering shock."-  }-halberd = ItemKind-  { isymbol  = symbolPolearm-  , iname    = "war scythe"-  , ifreq    = [("useful", 100), ("starting weapon", 1)]-  , iflavour = zipPlain [BrYellow]-  , icount   = 1-  , irarity  = [(7, 1), (10, 10)]-  , iverbHit = "impale"-  , iweight  = 3000-  , iaspects = [AddArmorMelee $ 1 + dl 3 |*| 5]-  , ieffects = [Hurt (12 * d 1)]-  , ifeature = [ toVelocity 5  -- not balanced-               , Durable, EqpSlot EqpSlotWeapon "", Identified ]-  , idesc    = "An improvised but deadly weapon made of a blade from a scythe attached to a long pole."-  , ikit     = []-  }-halberdPushActor = halberd-  { iname    = "Swiss Halberd"-  , ifreq    = [("treasure", 20)]-  , irarity  = [(7, 1), (10, 4)]-  , iaspects = [Unique, Timeout $ d 5 + 5 - dl 5 |*| 2]-  , ieffects = ieffects halberd ++ [Recharging (PushActor (ThrowMod 400 25))]-  , idesc    = "A versatile polearm, with great reach and leverage. Foes are held at a distance."-  }---- * Wands--wand = ItemKind-  { isymbol  = symbolWand-  , iname    = "wand"-  , ifreq    = [("useful", 100)]-  , iflavour = zipFancy brightCol-  , icount   = 1-  , irarity  = []  -- TODO: add charges, etc.-  , iverbHit = "club"-  , iweight  = 300-  , iaspects = [AddLight 1, AddSpeed (-1)]  -- pulsing with power, distracts-  , ieffects = []-  , ifeature = [ toVelocity 125  -- magic-               , Applicable, Durable ]-  , idesc    = "Buzzing with dazzling light that shines even through appendages that handle it."  -- TODO: add math flavour-  , ikit     = []-  }-wand1 = wand-  { ieffects = []  -- TODO: emit a cone of sound shrapnel that makes enemy cover his ears and so drop '|' and '{'-  }-wand2 = wand-  { ieffects = []-  }---- * Treasure--gem = ItemKind-  { isymbol  = symbolGem-  , iname    = "gem"-  , ifreq    = [("treasure", 100), ("gem", 100)]-  , iflavour = zipPlain $ delete BrYellow brightCol  -- natural, so not fancy-  , icount   = 1-  , irarity  = []-  , iverbHit = "tap"-  , iweight  = 50-  , iaspects = [AddLight 1, AddSpeed (-1)]-                 -- reflects strongly, distracts; so it glows in the dark,-                 -- is visible on dark floor, but not too tempting to wear-  , ieffects = []-  , ifeature = [Precious]-  , idesc    = "Useless, and still worth around 100 gold each. Would gems of thought and pearls of artful design be valued that much in our age of Science and Progress!"-  , ikit     = []-  }-gem1 = gem-  { irarity  = [(2, 0), (10, 12)]-  }-gem2 = gem-  { irarity  = [(4, 0), (10, 14)]-  }-gem3 = gem-  { irarity  = [(6, 0), (10, 16)]-  }-gem4 = gem-  { iname    = "elixir"-  , iflavour = zipPlain [BrYellow]-  , irarity  = [(1, 40), (10, 40)]-  , iaspects = []-  , ieffects = [NoEffect "of youth", OverfillCalm 5, OverfillHP 15]-  , ifeature = [Identified, Applicable, Precious]  -- TODO: only heal humans-  , idesc    = "A crystal vial of amber liquid, supposedly granting eternal youth and fetching 100 gold per piece. The main effect seems to be mild euphoria, but it admittedly heals minor ailments rather well."-  }-currency = ItemKind-  { isymbol  = symbolGold-  , iname    = "gold piece"-  , ifreq    = [("treasure", 100), ("currency", 100)]-  , iflavour = zipPlain [BrYellow]-  , icount   = 10 + d 20 + dl 20-  , irarity  = [(1, 25), (10, 10)]-  , iverbHit = "tap"-  , iweight  = 31+module Content.ItemKind+  ( cdefs, items, otherItemContent+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Content.ItemKindActor+import Content.ItemKindBlast+import Content.ItemKindEmbed+import Content.ItemKindOrgan+import Content.ItemKindTemporary+import Game.LambdaHack.Common.Ability+import Game.LambdaHack.Common.Color+import Game.LambdaHack.Common.ContentDef+import Game.LambdaHack.Common.Dice+import Game.LambdaHack.Common.Flavour+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Content.ItemKind++cdefs :: ContentDef ItemKind+cdefs = ContentDef+  { getSymbol = isymbol+  , getName = iname+  , getFreq = ifreq+  , validateSingle = validateSingleItemKind+  , validateAll = validateAllItemKind+  , content = contentFromList []  -- filled out later on+  }++otherItemContent :: [ItemKind]+otherItemContent = embeds ++ actors ++ organs ++ blasts ++ temporaries++items :: [ItemKind]+items =+  [sandstoneRock, dart, spike, slingStone, slingBullet, paralizingProj, harpoon, net, light1, light2, light3, blanket, flask1, flask2, flask3, flask4, flask5, flask6, flask7, flask8, flask9, flask10, flask11, flask12, flask13, flask14, flask15, flask16, flask17, flask18, flask19, flask20, potion1, potion2, potion3, potion4, potion5, potion6, potion7, potion8, potion9, potion10, scroll1, scroll2, scroll3, scroll4, scroll5, scroll6, scroll7, scroll8, scroll9, scroll10, scroll11, scroll12, scroll13, jumpingPole, sharpeningTool, seeingItem, motionScanner, gorget, necklace1, necklace2, necklace3, necklace4, necklace5, necklace6, necklace7, necklace8, necklace9, imageItensifier, sightSharpening, ring1, ring2, ring3, ring4, ring5, ring6, ring7, ring8, armorLeather, armorMail, gloveFencing, gloveGauntlet, gloveJousting, buckler, shield, dagger, daggerDropBestWeapon, hammer, hammerParalyze, hammerSpark, sword, swordImpress, swordNullify, halberd, halberdPushActor, wand1, wand2, gem1, gem2, gem3, gem4, currency]++sandstoneRock,    dart, spike, slingStone, slingBullet, paralizingProj, harpoon, net, light1, light2, light3, blanket, flask1, flask2, flask3, flask4, flask5, flask6, flask7, flask8, flask9, flask10, flask11, flask12, flask13, flask14, flask15, flask16, flask17, flask18, flask19, flask20, potion1, potion2, potion3, potion4, potion5, potion6, potion7, potion8, potion9, potion10, scroll1, scroll2, scroll3, scroll4, scroll5, scroll6, scroll7, scroll8, scroll9, scroll10, scroll11, scroll12, scroll13, jumpingPole, sharpeningTool, seeingItem, motionScanner, gorget, necklace1, necklace2, necklace3, necklace4, necklace5, necklace6, necklace7, necklace8, necklace9, imageItensifier, sightSharpening, ring1, ring2, ring3, ring4, ring5, ring6, ring7, ring8, armorLeather, armorMail, gloveFencing, gloveGauntlet, gloveJousting, buckler, shield, dagger, daggerDropBestWeapon, hammer, hammerParalyze, hammerSpark, sword, swordImpress, swordNullify, halberd, halberdPushActor, wand1, wand2, gem1, gem2, gem3, gem4, currency :: ItemKind++necklace, ring, potion, flask, scroll, wand, gem :: ItemKind  -- generic templates++-- * Item group symbols, partially from Nethack++symbolProjectile, _symbolLauncher, symbolLight, symbolTool, symbolGem, symbolGold, symbolNecklace, symbolRing, symbolPotion, symbolFlask, symbolScroll, symbolTorsoArmor, symbolMiscArmor, _symbolClothes, symbolShield, symbolPolearm, symbolEdged, symbolHafted, symbolWand, _symbolStaff, _symbolFood :: Char++symbolProjectile = '|'+_symbolLauncher  = '}'+symbolLight      = '('+symbolTool       = '('+symbolGem        = '*'+symbolGold       = '$'+symbolNecklace   = '"'+symbolRing       = '='+symbolPotion     = '!'  -- concoction, bottle, jar, vial, canister+symbolFlask      = '!'+symbolScroll     = '?'  -- book, note, tablet, remote, chip, card+symbolTorsoArmor = '['+symbolMiscArmor  = '['+_symbolClothes   = '['+symbolShield     = ']'+symbolPolearm    = ')'+symbolEdged      = ')'+symbolHafted     = ')'+symbolWand       = '/'  -- magical rod, transmitter, pistol, rifle+_symbolStaff     = '_'  -- scanner+_symbolFood      = ','  -- distinct from floor, because middle dots used++-- * Thrown weapons++sandstoneRock = ItemKind+  { isymbol  = symbolProjectile+  , iname    = "sandstone rock"+  , ifreq    = [("sandstone rock", 1), ("weak arrow", 10)]+  , iflavour = zipPlain [Green]+  , icount   = 1 * d 2+  , irarity  = [(1, 50), (10, 1)]+  , iverbHit = "hit"+  , iweight  = 300+  , idamage  = toDmg $ 1 * d 1+  , iaspects = [AddHurtMelee (-16 |*| 5)]+  , ieffects = []+  , ifeature = [toVelocity 70, Fragile, Identified]  -- not dense, irregular+  , idesc    = "A lump of brittle sandstone rock."+  , ikit     = []+  }+dart = ItemKind+  { isymbol  = symbolProjectile+  , iname    = "dart"+  , ifreq    = [("useful", 100), ("any arrow", 50), ("weak arrow", 50)]+  , iflavour = zipPlain [BrRed]+  , icount   = 4 * d 3+  , irarity  = [(1, 20), (10, 10)]+  , iverbHit = "prick"+  , iweight  = 40+  , idamage  = toDmg $ 1 * d 1+  , iaspects = [AddHurtMelee (-14 + d 2 + dl 4 |*| 5)]  -- only leather-piercing+  , ieffects = []+  , ifeature = [Identified]+  , idesc    = "A sharp delicate dart with fins."+  , ikit     = []+  }+spike = ItemKind+  { isymbol  = symbolProjectile+  , iname    = "spike"+  , ifreq    = [("useful", 100), ("any arrow", 50), ("weak arrow", 50)]+  , iflavour = zipPlain [Cyan]+  , icount   = 4 * d 3+  , irarity  = [(1, 10), (10, 20)]+  , iverbHit = "nick"+  , iweight  = 150+  , idamage  = toDmg $ 2 * d 1+  , iaspects = [AddHurtMelee (-10 + d 2 + dl 4 |*| 5)]  -- heavy vs armor+  , ieffects = [ Explode "single spark"  -- when hitting enemy+               , OnSmash (Explode "single spark") ]  -- at wall hit+  , ifeature = [toVelocity 70, Identified]  -- hitting with tip costs speed+  , idesc    = "A cruel long nail with small head."  -- "Much inferior to arrows though, especially given the contravariance problems."  --- funny, but destroy the suspension of disbelief; this is supposed to be a Lovecraftian horror and any hilarity must ensue from the failures in making it so and not from actively trying to be funny; also, mundane objects are not supposed to be scary or transcendental; the scare is in horrors from the abstract dimension visiting our ordinary reality; without the contrast there's no horror and no wonder, so also the magical items must be contrasted with ordinary XIX century and antique items+  , ikit     = []+  }+slingStone = ItemKind+  { isymbol  = symbolProjectile+  , iname    = "sling stone"+  , ifreq    = [("useful", 5), ("any arrow", 100)]+  , iflavour = zipPlain [Blue]+  , icount   = 3 * d 3+  , irarity  = [(1, 1), (10, 20)]+  , iverbHit = "hit"+  , iweight  = 200+  , idamage  = toDmg $ 1 * d 1+  , iaspects = [AddHurtMelee (-10 + d 2 + dl 4 |*| 5)]  -- heavy vs armor+  , ieffects = [ Explode "single spark"  -- when hitting enemy+               , OnSmash (Explode "single spark") ]  -- at wall hit+  , ifeature = [toVelocity 150, Identified]+  , idesc    = "A round stone, carefully sized and smoothed to fit the pouch of a standard string and cloth sling."+  , ikit     = []+  }+slingBullet = ItemKind+  { isymbol  = symbolProjectile+  , iname    = "sling bullet"+  , ifreq    = [("useful", 5), ("any arrow", 100)]+  , iflavour = zipPlain [BrBlack]+  , icount   = 6 * d 3+  , irarity  = [(1, 1), (10, 15)]+  , iverbHit = "hit"+  , iweight  = 28+  , idamage  = toDmg $ 1 * d 1+  , iaspects = [AddHurtMelee (-17 + d 2 + dl 4 |*| 5)]  -- not armor-piercing+  , ieffects = []+  , ifeature = [toVelocity 200, Identified]+  , idesc    = "Small almond-shaped leaden projectile that weighs more than the sling used to tie the bag. It doesn't drop out of the sling's pouch when swung and doesn't snag when released."+  , ikit     = []+  }++-- * Exotic thrown weapons++-- Identified, because shape (and name) says it all. Detailed stats id by use.+paralizingProj = ItemKind+  { isymbol  = symbolProjectile+  , iname    = "bolas set"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [BrYellow]+  , icount   = dl 4+  , irarity  = [(5, 5), (10, 5)]+  , iverbHit = "entangle"+  , iweight  = 500+  , idamage  = toDmg $ 1 * d 1+  , iaspects = [AddHurtMelee (-14 |*| 5)]+  , ieffects = [Paralyze 15, DropBestWeapon]+  , ifeature = [Identified]+  , idesc    = "Wood balls tied with hemp rope. The target enemy is tripped and bound to drop the main weapon, while fighting for balance."+  , ikit     = []+  }+harpoon = ItemKind+  { isymbol  = symbolProjectile+  , iname    = "harpoon"+  , ifreq    = [("useful", 100), ("harpoon", 100)]+  , iflavour = zipPlain [Brown]+  , icount   = dl 5+  , irarity  = [(10, 10)]+  , iverbHit = "hook"+  , iweight  = 750+  , idamage  = [(99, 5 * d 1), (1, 10 * d 1)]+  , iaspects = [AddHurtMelee (-10 + d 2 + dl 4 |*| 5)]+  , ieffects = [PullActor (ThrowMod 200 50)]+  , ifeature = [Identified]+  , idesc    = "The cruel, barbed head lodges in its victim so painfully that the weakest tug of the thin line sends the victim flying."+  , ikit     = []+  }+net = ItemKind+  { isymbol  = symbolProjectile+  , iname    = "net"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [White]+  , icount   = dl 3+  , irarity  = [(3, 5), (10, 4)]+  , iverbHit = "entangle"+  , iweight  = 1000+  , idamage  = toDmg $ 2 * d 1+  , iaspects = [AddHurtMelee (-14 |*| 5)]+  , ieffects = [ toOrganGameTurn "slowed" (3 + d 3)+               , DropItem maxBound 1 CEqp "torso armor" ]+  , ifeature = [Identified]+  , idesc    = "A wide net with weights along the edges. Entangles armor and restricts movement."+  , ikit     = []+  }++-- * Lights++light1 = ItemKind+  { isymbol  = symbolLight+  , iname    = "wooden torch"+  , ifreq    = [("useful", 100), ("light source", 100), ("wooden torch", 1)]+  , iflavour = zipPlain [Brown]+  , icount   = d 2+  , irarity  = [(1, 10)]+  , iverbHit = "scorch"+  , iweight  = 1000+  , idamage  = toDmg 0+  , iaspects = [ AddShine 3       -- not only flashes, but also sparks,+               , AddSight (-2) ]  -- so unused by AI due to the mixed blessing+  , ieffects = [Burn 1, EqpSlot EqpSlotLightSource]+  , ifeature = [Lobable, Identified, Equipable]  -- not Fragile; reusable flare+  , idesc    = "A smoking, heavy wooden torch, burning in an unsteady glow."+  , ikit     = []+  }+light2 = ItemKind+  { isymbol  = symbolLight+  , iname    = "oil lamp"+  , ifreq    = [("useful", 100), ("light source", 100)]+  , iflavour = zipPlain [BrYellow]+  , icount   = 1+  , irarity  = [(6, 7)]+  , iverbHit = "burn"+  , iweight  = 1500+  , idamage  = toDmg $ 1 * d 1+  , iaspects = [AddShine 3, AddSight (-1)]+  , ieffects = [ Burn 1, Paralyze 6, OnSmash (Explode "burning oil 2")+               , EqpSlot EqpSlotLightSource ]+  , ifeature = [Lobable, Fragile, Identified, Equipable]+  , idesc    = "A clay lamp filled with plant oil feeding a tiny wick."+  , ikit     = []+  }+light3 = ItemKind+  { isymbol  = symbolLight+  , iname    = "brass lantern"+  , ifreq    = [("useful", 100), ("light source", 100)]+  , iflavour = zipPlain [BrWhite]+  , icount   = 1+  , irarity  = [(10, 5)]+  , iverbHit = "burn"+  , iweight  = 3000+  , idamage  = toDmg $ 4 * d 1+  , iaspects = [AddShine 4, AddSight (-1)]+  , ieffects = [ Burn 1, Paralyze 8, OnSmash (Explode "burning oil 4")+               , EqpSlot EqpSlotLightSource ]+  , ifeature = [Lobable, Fragile, Identified, Equipable]+  , idesc    = "Very bright and very heavy brass lantern."+  , ikit     = []+  }+blanket = ItemKind+  { isymbol  = symbolLight+  , iname    = "wool blanket"+  , ifreq    = [("useful", 100), ("light source", 100), ("blanket", 1)]+  , iflavour = zipPlain [BrBlack]+  , icount   = 1+  , irarity  = [(1, 5)]+  , iverbHit = "swoosh"+  , iweight  = 1000+  , idamage  = toDmg 0+  , iaspects = [ AddShine (-10)  -- douses torch, lamp and lantern in one action+               , AddArmorMelee 1, AddMaxCalm 2 ]+  , ieffects = []+  , ifeature = [Lobable, Identified, Equipable]  -- not Fragile; reusable douse+  , idesc    = ""+  , ikit     = []+  }++-- * Exploding consumables, often intended to be thrown.++-- Not identified, because they are perfect for the id-by-use fun,+-- due to effects. They are fragile and upon hitting the ground explode+-- for effects roughly corresponding to their normal effects.+-- Whether to hit with them or explode them close to the tartget+-- is intended to be an interesting tactical decision.+--+-- Flasks are often not natural; maths, magic, distillery.+-- In reality, they just cover all temporary effects, which in turn matches+-- all aspects.+--+-- No flask nor temporary organ of Calm depletion, since Calm reduced often.+flask = ItemKind+  { isymbol  = symbolFlask+  , iname    = "flask"+  , ifreq    = [("useful", 100), ("flask", 100), ("any vial", 100)]+  , iflavour = zipLiquid darkCol ++ zipPlain darkCol ++ zipFancy darkCol+               ++ zipLiquid brightCol+  , icount   = 1+  , irarity  = [(1, 7), (10, 4)]+  , iverbHit = "splash"+  , iweight  = 500+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = []+  , ifeature = [Applicable, Lobable, Fragile, toVelocity 50]  -- oily, bad grip+  , idesc    = "A flask of oily liquid of a suspect color. Something seems to be moving inside."+  , ikit     = []+  }+flask1 = flask+  { irarity  = [(10, 4)]+  , ieffects = [ ELabel "of strength renewal brew"+               , toOrganActorTurn "strengthened" (20 + d 5)+               , toOrganNone "regenerating"+               , OnSmash (Explode "dense shower") ]+  }+flask2 = flask+  { ieffects = [ ELabel "of weakness brew"+               , toOrganGameTurn "weakened" (20 + d 5)+               , OnSmash (Explode "sparse shower") ]+  }+flask3 = flask+  { ieffects = [ ELabel "of melee protective balm"+               , toOrganActorTurn "protected from melee" (20 + d 5)+               , OnSmash (Explode "melee protective balm") ]+  }+flask4 = flask+  { ieffects = [ ELabel "of ranged protective balm"+               , toOrganActorTurn "protected from ranged" (20 + d 5)+               , OnSmash (Explode "ranged protective balm") ]+  }+flask5 = flask+  { ieffects = [ ELabel "of PhD defense questions"+               , toOrganGameTurn "defenseless" (20 + d 5)+               , Impress+               , DetectExit 20+               , OnSmash (Explode "PhD defense question") ]+  }+flask6 = flask+  { irarity  = [(10, 9)]+  , ieffects = [ ELabel "of resolution"+               , toOrganActorTurn "resolute" (200 + d 50)+                   -- long, for scouting and has to recharge+               , OnSmash (Explode "resolution dust") ]+  }+flask7 = flask+  { irarity  = [(10, 4)]+  , ieffects = [ ELabel "of haste brew"+               , toOrganActorTurn "hasted" (20 + d 5)+               , OnSmash (Explode "blast 20")+               , OnSmash (Explode "haste spray") ]+  }+flask8 = flask+  { irarity  = [(1, 14), (10, 4)]+  , ieffects = [ ELabel "of lethargy brew"+               , toOrganGameTurn "slowed" (20 + d 5)+               , toOrganNone "regenerating", toOrganNone "regenerating"  -- x2+               , RefillCalm 5+               , OnSmash (Explode "slowness mist") ]+  }+flask9 = flask+  { irarity  = [(10, 4)]+  , ieffects = [ ELabel "of eye drops"+               , toOrganActorTurn "far-sighted" (40 + d 10)+               , OnSmash (Explode "eye drop") ]+  }+flask10 = flask+  { irarity  = [(10, 2)]+  , ieffects = [ ELabel "of smelly concoction"+               , toOrganActorTurn "keen-smelling" (40 + d 10)+               , DetectActor 5+               , OnSmash (Explode "smelly droplet") ]+  }+flask11 = flask+  { irarity  = [(10, 4)]+  , ieffects = [ ELabel "of cat tears"+               , toOrganActorTurn "shiny-eyed" (40 + d 10)+               , OnSmash (Explode "eye shine") ]+  }+flask12 = flask+  { irarity  = [(1, 14), (10, 10)]+  , ieffects = [ ELabel "of whiskey"+               , toOrganActorTurn "drunk" (20 + d 5)+               , Burn 1, RefillHP 3+               , OnSmash (Explode "whiskey spray") ]+  }+flask13 = flask+  { ieffects = [ ELabel "of bait cocktail"+               , toOrganActorTurn "drunk" (20 + d 5)+               , Burn 1, RefillHP 3+               , Summon "mobile animal" 1+               , OnSmash (Summon "mobile animal" 1)+               , OnSmash Impress+               , OnSmash (Explode "waste") ]+  }+-- The player has full control over throwing the flask at his party,+-- so he can milk the explosion, so it has to be much weaker, so a weak+-- healing effect is enough. OTOH, throwing a harmful flask at many enemies+-- at once is not easy to arrange, so these explostions can stay powerful.+flask14 = flask+  { irarity  = [(1, 4), (10, 14)]+  , ieffects = [ ELabel "of regeneration brew"+               , toOrganNone "regenerating", toOrganNone "regenerating"  -- x2+               , OnSmash (Explode "healing mist") ]+  }+flask15 = flask+  { ieffects = [ ELabel "of poison"+               , toOrganNone "poisoned", toOrganNone "poisoned"  -- x2+               , OnSmash (Explode "poison cloud") ]+  }+flask16 = flask+  { irarity  = [(1, 14), (10, 4)]+  , ieffects = [ ELabel "of weak poison"+               , toOrganNone "poisoned"+               , OnSmash (Explode "poison cloud") ]+  }+flask17 = flask+  { irarity  = [(10, 4)]+  , ieffects = [ ELabel "of slow resistance"+               , toOrganNone "slow resistant"+               , OnSmash (Explode "blast 10")+               , OnSmash (Explode "anti-slow mist") ]+  }+flask18 = flask+  { irarity  = [(10, 4)]+  , ieffects = [ ELabel "of poison resistance"+               , toOrganNone "poison resistant"+               , OnSmash (Explode "antidote mist") ]+  }+flask19 = flask+  { ieffects = [ ELabel "of blindness"+               , toOrganGameTurn "blind" (40 + d 10)+               , OnSmash (Explode "iron filing") ]+  }+flask20 = flask+  { ieffects = [ ELabel "of calamity"+               , toOrganNone "poisoned"+               , toOrganGameTurn "weakened" (20 + d 5)+               , toOrganGameTurn "defenseless" (20 + d 5)+               , OnSmash (Explode "poison cloud") ]+  }++-- Potions are often natura. Various configurations of effects.+-- A different class of effects is on scrolls and/or mechanical items.+-- Some are shared.++potion = ItemKind+  { isymbol  = symbolPotion+  , iname    = "potion"+  , ifreq    = [("useful", 100), ("potion", 100), ("any vial", 100)]+  , iflavour = zipLiquid brightCol ++ zipPlain brightCol ++ zipFancy brightCol+  , icount   = 1+  , irarity  = [(1, 10), (10, 7)]+  , iverbHit = "splash"+  , iweight  = 200+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = []+  , ifeature = [Applicable, Lobable, Fragile, toVelocity 50]  -- oily, bad grip+  , idesc    = "A vial of bright, frothing concoction. The best that nature has to offer."+  , ikit     = []+  }+potion1 = potion+  { ieffects = [ ELabel "of rose water", Impress, RefillCalm (-5)+               , OnSmash ApplyPerfume, OnSmash (Explode "fragrance") ]+  }+potion2 = potion+  { ifreq    = [("treasure", 100)]+  , irarity  = [(6, 9), (10, 9)]+  , ieffects = [ Unique, ELabel "of Attraction", Impress, RefillCalm (-20)+               , OnSmash (Explode "pheromone") ]+  }+potion3 = potion+  { ieffects = [ RefillHP 5, DropItem 1 maxBound COrgan "poisoned"+               , OnSmash (Explode "healing mist") ]+  }+potion4 = potion+  { irarity  = [(1, 7), (10, 10)]+  , ieffects = [ RefillHP 10, DropItem 1 maxBound COrgan "poisoned"+               , OnSmash (Explode "healing mist 2") ]+  }+potion5 = potion+  { ieffects = [ OneOf [ RefillHP 10, RefillHP 5, Burn 5+                       , toOrganActorTurn "strengthened" (20 + d 5) ]+               , OnSmash (OneOf [ Explode "dense shower"+                                , Explode "sparse shower"+                                , Explode "melee protective balm"+                                , Explode "ranged protective balm"+                                , Explode "PhD defense question"+                                , Explode "blast 10" ]) ]+  }+potion6 = potion+  { irarity  = [(3, 2), (10, 5)]+  , ieffects = [ Impress+               , OneOf [ RefillCalm (-60)+                       , RefillHP 20, RefillHP 10, Burn 10+                       , toOrganActorTurn "hasted" (20 + d 5) ]+               , OnSmash (OneOf [ Explode "healing mist 2"+                                , Explode "wounding mist"+                                , Explode "distressing odor"+                                , Explode "haste spray"+                                , Explode "slowness mist"+                                , Explode "fragrance"+                                , Explode "blast 20" ]) ]+  }+potion7 = potion+  { irarity  = [(1, 11), (10, 4)]+  , ieffects = [ DropItem 1 maxBound COrgan "poisoned"+               , OnSmash (Explode "antidote mist") ]+  }+potion8 = potion+  { irarity  = [(1, 9)]+  , ieffects = [ DropItem 1 maxBound COrgan "temporary condition"+               , OnSmash (Explode "blast 10") ]+  }+potion9 = potion+  { irarity  = [(10, 9)]+  , ieffects = [ DropItem maxBound maxBound COrgan "temporary condition"+               , OnSmash (Explode "blast 20") ]+  }+potion10 = potion+  { ifreq    = [("treasure", 100)]+  , irarity  = [(10, 4)]+  , ieffects = [ Unique, ELabel "of Love", RefillHP 60+               , Impress, RefillCalm (-60)+               , OnSmash (Explode "healing mist 2")+               , OnSmash (Explode "pheromone") ]+  }++-- * Non-exploding consumables, not specifically designed for throwing++scroll = ItemKind+  { isymbol  = symbolScroll+  , iname    = "scroll"+  , ifreq    = [("useful", 100), ("any scroll", 100)]+  , iflavour = zipFancy stdCol ++ zipPlain darkCol  -- arcane and old+  , icount   = 1+  , irarity  = [(1, 14), (10, 11)]+  , iverbHit = "thump"+  , iweight  = 50+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = []+  , ifeature = [ toVelocity 30  -- bad shape, even rolled up+               , Applicable ]+  , idesc    = "Scraps of haphazardly scribbled mysteries from beyond. Is this equation an alchemical recipe? Is this diagram an extradimensional map? Is this formula a secret call sign?"+  , ikit     = []+  }+scroll1 = scroll+  { ifreq    = [("treasure", 100)]+  , irarity  = [(5, 9), (10, 9)]  -- mixed blessing, so available early+  , ieffects = [ Unique, ELabel "of Reckless Beacon"+               , Summon "hero" 1, Summon "mobile animal" (2 + d 2) ]+  }+scroll2 = scroll+  { irarity  = [(1, 2)]+  , ieffects = [ ELabel "of greed", Teleport 20, DetectItem 10+               , RefillCalm (-100) ]+  }+scroll3 = scroll+  { irarity  = [(1, 4), (10, 2)]+  , ieffects = [Ascend False]+  }+scroll4 = scroll+  { ieffects = [OneOf [ Teleport 5, RefillCalm 5, InsertMove 5+                      , DetectActor 10, DetectItem 10 ]]+  }+scroll5 = scroll+  { irarity  = [(10, 14)]+  , ieffects = [ Impress+               , OneOf [ Teleport 20, Ascend False, Ascend True+                       , Summon "hero" 1, Summon "mobile animal" 2+                       , Detect 20, RefillCalm (-100)+                       , CreateItem CGround "useful" TimerNone ] ]+  }+scroll6 = scroll+  { ieffects = [Teleport 5]+  }+scroll7 = scroll+  { ieffects = [Teleport 20]+  }+scroll8 = scroll+  { irarity  = [(10, 2)]+  , ieffects = [InsertMove $ 1 + d 2 + dl 2]+  }+scroll9 = scroll+  { ieffects = [ELabel "of scientific explanation", Identify]+  }+scroll10 = scroll+  { irarity  = [(10, 20)]+  , ieffects = [ ELabel "transfiguration"+               , PolyItem, Explode "firecracker 7" ]+  }+scroll11 = scroll+  { ifreq    = [("treasure", 100)]+  , irarity  = [(6, 9), (10, 9)]+  , ieffects = [Unique, ELabel "of Prisoner Release", Summon "hero" 1]+  }+scroll12 = scroll+  { irarity  = [(1, 9), (10, 4)]+  , ieffects = [DetectHidden 10]+  }+scroll13 = scroll+  { ieffects = [ELabel "of acute hearing", DetectActor 7]+  }++-- * Assorted tools++jumpingPole = ItemKind+  { isymbol  = symbolTool+  , iname    = "jumping pole"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [White]+  , icount   = 1+  , irarity  = [(1, 2)]+  , iverbHit = "prod"+  , iweight  = 10000+  , idamage  = toDmg 0+  , iaspects = [Timeout $ d 2 + 2 - dl 2 |*| 10]+  , ieffects = [Recharging (toOrganActorTurn "hasted" 1)]+  , ifeature = [Durable, Applicable, Identified]+  , idesc    = "Makes you vulnerable at take-off, but then you are free like a bird."+  , ikit     = []+  }+sharpeningTool = ItemKind+  { isymbol  = symbolTool+  , iname    = "whetstone"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [Blue]+  , icount   = 1+  , irarity  = [(10, 10)]+  , iverbHit = "smack"+  , iweight  = 400+  , idamage  = toDmg 0+  , iaspects = [AddHurtMelee $ d 10 |*| 3]+  , ieffects = [EqpSlot EqpSlotAddHurtMelee]+  , ifeature = [Identified, Equipable]+  , idesc    = "A portable sharpening stone that lets you fix your weapons between or even during fights, without the need to set up camp, fish out tools and assemble a proper sharpening workshop."+  , ikit     = []+  }+seeingItem = ItemKind+  { isymbol  = '%'+  , iname    = "pupil"+  , ifreq    = [("useful", 30)]  -- spooky and wierd, so rare+  , iflavour = zipPlain [Red]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "gaze at"+  , iweight  = 100+  , idamage  = toDmg 0+  , iaspects = [ AddSight 10, AddMaxCalm 30, AddShine 2+               , Timeout $ 1 + d 2 ]+  , ieffects = [ Periodic+               , Recharging (toOrganNone "poisoned")+               , Recharging (Summon "mobile monster" 1) ]+  , ifeature = [Identified]+  , idesc    = "A slimy, dilated green pupil torn out from some giant eye. Clear and focused, as if still alive."+  , ikit     = []+  }+motionScanner = ItemKind+  { isymbol  = symbolTool+  , iname    = "draft detector"+  , ifreq    = [("useful", 100), ("add nocto 1", 20)]+  , iflavour = zipPlain [BrRed]+  , icount   = 1+  , irarity  = [(6, 2), (10, 2)]+  , iverbHit = "jingle"+  , iweight  = 300+  , idamage  = toDmg 0+  , iaspects = [ AddNocto 1+               , AddArmorMelee (dl 5 - 10), AddArmorRanged (dl 5 - 10) ]+  , ieffects = [EqpSlot EqpSlotMiscBonus]+  , ifeature = [Identified, Equipable]+  , idesc    = "A silk flag with a bell for detecting sudden draft changes. May indicate a nearby corridor crossing or a fast enemy approaching in the dark. Is also very noisy."+  , ikit     = []+  }++-- * Periodic jewelry++gorget = ItemKind+  { isymbol  = symbolNecklace+  , iname    = "Old Gorget"+  , ifreq    = [("useful", 25), ("treasure", 25)]+  , iflavour = zipFancy [BrCyan]+  , icount   = 1+  , irarity  = [(4, 3), (10, 3)]  -- weak, shallow+  , iverbHit = "whip"+  , iweight  = 30+  , idamage  = toDmg 0+  , iaspects = [ Timeout $ 1 + d 2+               , AddArmorMelee $ 2 + d 3+               , AddArmorRanged $ d 3 ]+  , ieffects = [ Unique, Periodic+               , Recharging (RefillCalm 1), EqpSlot EqpSlotMiscBonus ]+  , ifeature = [Durable, Precious, Identified, Equipable]+  , idesc    = "Highly ornamental, cold, large, steel medallion on a chain. Unlikely to offer much protection as an armor piece, but the old, worn engraving reassures you."+  , ikit     = []+  }+-- Not idenfified, because the id by use, e.g., via periodic activations. Fun.+necklace = ItemKind+  { isymbol  = symbolNecklace+  , iname    = "necklace"+  , ifreq    = [("useful", 100)]+  , iflavour = zipFancy stdCol ++ zipPlain brightCol+  , icount   = 1+  , irarity  = [(10, 2)]+  , iverbHit = "whip"+  , iweight  = 30+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = [Periodic]+  , ifeature = [Precious, toVelocity 50, Equipable]  -- not dense enough+  , idesc    = "Menacing Greek symbols shimmer with increasing speeds along a chain of fine encrusted links. After a tense build-up, a prismatic arc shoots towards the ground and the iridescence subdues, becomes ordered and resembles a harmless ornament again, for a time."+  , ikit     = []+  }+necklace1 = necklace+  { ifreq    = [("treasure", 100)]+  , iaspects = [Timeout $ d 3 + 4 - dl 3 |*| 10]+  , ieffects = [ Unique, ELabel "of Aromata", EqpSlot EqpSlotMiscBonus+               , Recharging (RefillHP 1) ]+               ++ ieffects necklace+  , ifeature = Durable : ifeature necklace+  , idesc    = "A cord of freshly dried herbs and healing berries."+  }+necklace2 = necklace+  { ifreq    = [("treasure", 100)]  -- just too nasty to call it useful+  , irarity  = [(1, 1)]+  , iaspects = [Timeout $ d 3 + 3 - dl 3 |*| 10]+  , ieffects = [ Recharging (Summon "mobile animal" $ 1 + dl 2)+               , Recharging (Explode "waste")+               , Recharging Impress+               , Recharging (DropItem 1 maxBound COrgan "temporary condition") ]+               ++ ieffects necklace+  }+necklace3 = necklace+  { iaspects = [Timeout $ d 3 + 4 - dl 3 |*| 5]+  , ieffects = [ ELabel "of fearful listening"+               , Recharging (DetectActor 10)+               , Recharging (RefillCalm (-20)) ]+               ++ ieffects necklace+  }+necklace4 = necklace+  { iaspects = [Timeout $ d 4 + 4 - dl 4 |*| 2]+  , ieffects = [Recharging (Teleport $ d 2 * 3)]+               ++ ieffects necklace+  }+necklace5 = necklace+  { iaspects = [Timeout $ d 3 + 4 - dl 3 |*| 10]+  , ieffects = [ ELabel "of escape"+               , Recharging (Teleport $ 14 + d 3 * 3)+               , Recharging (DetectExit 20)+               , Recharging (RefillHP (-2)) ]  -- prevent micromanagement+               ++ ieffects necklace+  }+necklace6 = necklace+  { iaspects = [Timeout $ d 3 + 1 |*| 2]+  , ieffects = [Recharging (PushActor (ThrowMod 100 50))]+               ++ ieffects necklace+  }+necklace7 = necklace+  { ifreq    = [("treasure", 100)]+  , iaspects = [ AddMaxHP $ 10 + d 10+               , AddArmorMelee 20, AddArmorRanged 10+               , Timeout $ d 2 + 5 - dl 3 ]+  , ieffects = [ Unique, ELabel "of Overdrive", EqpSlot EqpSlotAddSpeed+               , Recharging (InsertMove $ 1 + d 2)+               , Recharging (RefillHP (-1))+               , Recharging (RefillCalm (-1)) ]  -- fake "hears something" :)+               ++ ieffects necklace+  , ifeature = Durable : ifeature necklace+  }+necklace8 = necklace+  { iaspects = [Timeout $ d 3 + 3 - dl 3 |*| 5]+  , ieffects = [Recharging $ Explode "spark"]+               ++ ieffects necklace+  }+necklace9 = necklace+  { iaspects = [Timeout $ d 3 + 3 - dl 3 |*| 5]+  , ieffects = [Recharging $ Explode "fragrance"]+               ++ ieffects necklace+  }++-- * Non-periodic jewelry++imageItensifier = ItemKind+  { isymbol  = symbolRing+  , iname    = "light cone"+  , ifreq    = [("treasure", 100), ("add nocto 1", 80)]+  , iflavour = zipFancy [BrYellow]+  , icount   = 1+  , irarity  = [(7, 2), (10, 2)]+  , iverbHit = "bang"+  , iweight  = 500+  , idamage  = toDmg 0+  , iaspects = [AddNocto 1, AddSight (-1), AddArmorMelee $ 1 + dl 3 |*| 3]+  , ieffects = [EqpSlot EqpSlotMiscBonus]+  , ifeature = [Precious, Identified, Durable, Equipable]+  , idesc    = "Contraption of lenses and mirrors on a polished brass headband for capturing and strengthening light in dark environment. Hampers vision in daylight. Stackable."+  , ikit     = []+  }+sightSharpening = ItemKind+  { isymbol  = symbolRing+  , iname    = "sharp monocle"+  , ifreq    = [("treasure", 10), ("add sight", 1)]  -- not unique, so very rare+  , iflavour = zipPlain [White]+  , icount   = 1+  , irarity  = [(7, 1), (10, 5)]+  , iverbHit = "rap"+  , iweight  = 50+  , idamage  = toDmg 0+  , iaspects = [AddSight $ 1 + d 2, AddHurtMelee $ d 2 |*| 3]+  , ieffects = [EqpSlot EqpSlotAddSight]+  , ifeature = [Precious, Identified, Durable, Equipable]+  , idesc    = "Let's you better focus your weaker eye."+  , ikit     = []+  }+-- Don't add standard effects to rings, because they go in and out+-- of eqp and so activating them would require UI tedium: looking for+-- them in eqp and inv or even activating a wrong item by mistake.+--+-- However, rings have the explosion effect.+-- They explode on use (and throw), for the fun of hitting everything+-- around without the risk of being hit. In case of teleportation explosion+-- this can also be used to immediately teleport close friends, as opposed+-- to throwing the ring, which takes time.+--+-- Rings should have @Identified@, so that they fully identify upon picking up.+-- Effects of many of them are seen in character sheet, so it would be silly+-- not to identify them. Necklaces provide the fun of id-by-use, because they+-- have effects and when they are triggered, they id.+ring = ItemKind+  { isymbol  = symbolRing+  , iname    = "ring"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain stdCol ++ zipFancy darkCol+  , icount   = 1+  , irarity  = [(10, 3)]+  , iverbHit = "knock"+  , iweight  = 15+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = []+  , ifeature = [Precious, Identified, Equipable]+  , idesc    = "It looks like an ordinary object, but it's in fact a generator of exceptional effects: adding to some of your natural abilities and subtracting from others. You'd profit enormously if you could find a way to multiply such generators."+  , ikit     = []+  }+ring1 = ring+  { irarity  = [(10, 2)]+  , iaspects = [AddSpeed $ 1 + d 2, AddMaxHP $ dl 7 - 7 - d 7]+  , ieffects = [ Explode "distortion"  -- strong magic+               , EqpSlot EqpSlotAddSpeed ]+  }+ring2 = ring+  { irarity  = [(10, 5)]+  , iaspects = [AddMaxHP $ 10 + dl 10, AddMaxCalm $ dl 5 - 20 - d 5]+  , ieffects = [Explode "blast 20", EqpSlot EqpSlotAddMaxHP]+  }+ring3 = ring+  { irarity  = [(10, 5)]+  , iaspects = [AddMaxCalm $ 29 + dl 10]+  , ieffects = [Explode "blast 20", EqpSlot EqpSlotMiscBonus]+  , idesc    = "Cold, solid to the touch, perfectly round, engraved with solemn, strangely comforting, worn out words."+  }+ring4 = ring+  { irarity  = [(3, 3), (10, 5)]+  , iaspects = [AddHurtMelee $ d 5 + dl 5 |*| 3, AddMaxHP $ dl 3 - 5 - d 3]+  , ieffects = [Explode "blast 20", EqpSlot EqpSlotAddHurtMelee]+  }+ring5 = ring  -- by the time it's found, probably no space in eqp+  { irarity  = [(5, 0), (10, 2)]+  , iaspects = [AddShine $ d 2]+  , ieffects = [ Explode "distortion"  -- strong magic+               , EqpSlot EqpSlotLightSource ]+  , idesc    = "A sturdy ring with a large, shining stone."+  }+ring6 = ring+  { ifreq    = [("treasure", 100)]+  , irarity  = [(10, 2)]+  , iaspects = [ AddSpeed $ 3 + d 4+               , AddMaxCalm $ - 20 - d 20, AddMaxHP $ - 20 - d 20 ]+  , ieffects = [ Unique, ELabel "of Rush"  -- no explosion, because Durable+               , EqpSlot EqpSlotAddSpeed ]+  , ifeature = Durable : ifeature ring+  }+ring7 = ring+  { ifreq    = [("useful", 10), ("ring of opportunity sniper", 1) ]+  , irarity  = [(10, 5)]+  , iaspects = [AddAbility AbProject 8]+  , ieffects = [ ELabel "of opportunity sniper"+               , Explode "distortion"  -- strong magic+               , EqpSlot EqpSlotAbProject ]+  }+ring8 = ring+  { ifreq    = [("useful", 1), ("ring of opportunity grenadier", 1) ]+  , irarity  = [(1, 1)]+  , iaspects = [AddAbility AbProject 11]+  , ieffects = [ ELabel "of opportunity grenadier"+               , Explode "distortion"  -- strong magic+               , EqpSlot EqpSlotAbProject ]+  }++-- * Armor++armorLeather = ItemKind+  { isymbol  = symbolTorsoArmor+  , iname    = "leather armor"+  , ifreq    = [("useful", 100), ("torso armor", 1)]+  , iflavour = zipPlain [Brown]+  , icount   = 1+  , irarity  = [(1, 9), (10, 3)]+  , iverbHit = "thud"+  , iweight  = 7000+  , idamage  = toDmg 0+  , iaspects = [ AddHurtMelee (-2)+               , AddArmorMelee $ 1 + d 2 + dl 2 |*| 5+               , AddArmorRanged $ dl 3 |*| 3 ]+  , ieffects = [EqpSlot EqpSlotAddArmorMelee]+  , ifeature = [Durable, Identified, Equipable]+  , idesc    = "A stiff jacket formed from leather boiled in bee wax, padded linen and horse hair. Protects from anything that is not too sharp. Smells much better than the rest of your garment."+  , ikit     = []+  }+armorMail = armorLeather+  { iname    = "mail armor"+  , ifreq    = [("useful", 100), ("torso armor", 1), ("armor ranged", 50) ]+  , iflavour = zipPlain [Cyan]+  , irarity  = [(6, 9), (10, 3)]+  , iweight  = 12000+  , idamage  = toDmg 0+  , iaspects = [ AddHurtMelee (-3)+               , AddArmorMelee $ 1 + d 2 + dl 2 |*| 5+               , AddArmorRanged $ 2 + d 2 + dl 3 |*| 3 ]+  , ieffects = [EqpSlot EqpSlotAddArmorRanged]+  , ifeature = [Durable, Identified, Equipable]+  , idesc    = "A long shirt woven from iron rings that are hard to pierce through. Discourages foes from attacking your torso, making it harder for them to hit you."+  }+gloveFencing = ItemKind+  { isymbol  = symbolMiscArmor+  , iname    = "leather glove"+  , ifreq    = [("useful", 100), ("armor ranged", 50)]+  , iflavour = zipPlain [BrYellow]+  , icount   = 1+  , irarity  = [(5, 9), (10, 9)]+  , iverbHit = "flap"+  , iweight  = 100+  , idamage  = toDmg $ 1 * d 1+  , iaspects = [ AddHurtMelee $ d 2 + dl 7 |*| 3+               , AddArmorRanged $ dl 2 |*| 3 ]+  , ieffects = [EqpSlot EqpSlotAddHurtMelee]+  , ifeature = [ toVelocity 50  -- flaps and flutters+               , Durable, Identified, Equipable ]+  , idesc    = "A fencing glove from rough leather ensuring a good grip. Also quite effective in deflecting or even catching slow projectiles."+  , ikit     = []+  }+gloveGauntlet = gloveFencing+  { iname    = "steel gauntlet"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [BrCyan]+  , irarity  = [(1, 9), (10, 3)]+  , iweight  = 300+  , idamage  = toDmg $ 2 * d 1+  , iaspects = [ AddArmorMelee $ 2 + dl 2 |*| 5+               , AddArmorRanged $ dl 1 |*| 3 ]+  , ieffects = [EqpSlot EqpSlotAddArmorMelee]+  , idesc    = "Long leather gauntlet covered in overlapping steel plates."+  }+gloveJousting = gloveFencing+  { iname    = "Tournament Gauntlet"+  , ifreq    = [("useful", 100)]+  , iflavour = zipFancy [BrRed]+  , irarity  = [(1, 3), (10, 3)]+  , iweight  = 500+  , idamage  = toDmg $ 4 * d 1+  , iaspects = [ AddHurtMelee $ dl 4 - 6 |*| 3+               , AddArmorMelee $ 2 + d 2 + dl 2 |*| 5+               , AddArmorRanged $ dl 2 |*| 3 ]+  , ieffects = [Unique, EqpSlot EqpSlotAddArmorMelee]+  , idesc    = "Rigid, steel, jousting handgear. If only you had a lance. And a horse."+  }++-- * Shields++-- Shield doesn't protect against ranged attacks to prevent+-- micromanagement: walking with shield, melee without.+-- Note that AI will pick them up but never wear and will use them at most+-- as a way to push itself (but they won't recharge, not being in eqp).+-- Being @Meleeable@ they will not be use as weapons either.+-- This is OK, using shields smartly is totally beyond AI.+buckler = ItemKind+  { isymbol  = symbolShield+  , iname    = "buckler"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [Blue]+  , icount   = 1+  , irarity  = [(4, 6)]+  , iverbHit = "bash"+  , iweight  = 2000+  , idamage  = [(96, 2 * d 1), (3, 4 * d 1), (1, 8 * d 1)]+  , iaspects = [ AddArmorMelee 40  -- not enough to compensate; won't be in eqp+               , AddHurtMelee (-30)  -- too harmful; won't be wielded as weapon+               , Timeout $ d 3 + 3 - dl 3 |*| 2 ]+  , ieffects = [ Recharging (PushActor (ThrowMod 200 50))+               , EqpSlot EqpSlotAddArmorMelee ]+  , ifeature = [ toVelocity 50  -- unwieldy to throw+               , Durable, Identified, Meleeable ]+  , idesc    = "Heavy and unwieldy. Absorbs a percentage of melee damage, both dealt and sustained. Too small to intercept projectiles with."+  , ikit     = []+  }+shield = buckler+  { iname    = "shield"+  , irarity  = [(8, 3)]+  , iflavour = zipPlain [Green]+  , iweight  = 3000+  , idamage  = [(96, 4 * d 1), (3, 8 * d 1), (1, 16 * d 1)]+  , iaspects = [ AddArmorMelee 80  -- not enough to compensate; won't be in eqp+               , AddHurtMelee (-70)  -- too harmful; won't be wielded as weapon+               , Timeout $ d 6 + 6 - dl 6 |*| 2 ]+  , ieffects = [ Recharging (PushActor (ThrowMod 400 50))+               , EqpSlot EqpSlotAddArmorMelee ]+  , ifeature = [ toVelocity 50  -- unwieldy to throw+               , Durable, Identified, Meleeable ]+  , idesc    = "Large and unwieldy. Absorbs a percentage of melee damage, both dealt and sustained. Too heavy to intercept projectiles with."+  }++-- * Weapons++dagger = ItemKind+  { isymbol  = symbolEdged+  , iname    = "dagger"+  , ifreq    = [("useful", 100), ("starting weapon", 100)]+  , iflavour = zipPlain [BrCyan]+  , icount   = 1+  , irarity  = [(1, 40), (5, 1)]+  , iverbHit = "stab"+  , iweight  = 800+  , idamage  = toDmg $ 6 * d 1+  , iaspects = [ AddHurtMelee $ d 3 + dl 3 |*| 3+               , AddArmorMelee $ d 2 |*| 5 ]+  , ieffects = [EqpSlot EqpSlotWeapon]+  , ifeature = [ toVelocity 40  -- ensuring it hits with the tip costs speed+               , Durable, Identified, Meleeable ]+  , idesc    = "A short dagger for thrusting and parrying blows. Does not penetrate deeply, but is hard to block. Especially useful in conjunction with a larger weapon."+  , ikit     = []+  }+daggerDropBestWeapon = dagger+  { iname    = "Double Dagger"+  , ifreq    = [("treasure", 20)]+  , irarity  = [(1, 2), (10, 4)]+  -- The timeout has to be small, so that the player can count on the effect+  -- occuring consistently in any longer fight. Otherwise, the effect will be+  -- absent in some important fights, leading to the feeling of bad luck,+  -- but will manifest sometimes in fights where it doesn't matter,+  -- leading to the feeling of wasted power.+  -- If the effect is very powerful and so the timeout has to be significant,+  -- let's make it really large, for the effect to occur only once in a fight:+  -- as soon as the item is equipped, or just on the first strike.+  , iaspects = iaspects dagger ++ [Timeout $ d 3 + 4 - dl 3 |*| 2]+  , ieffects = ieffects dagger+               ++ [ Unique+                  , Recharging DropBestWeapon, Recharging $ RefillCalm (-3) ]+  , idesc    = "A double dagger that a focused fencer can use to catch and twist an opponent's blade occasionally."+  }+hammer = ItemKind+  { isymbol  = symbolHafted+  , iname    = "war hammer"+  , ifreq    = [("useful", 100), ("starting weapon", 100)]+  , iflavour = zipFancy [BrMagenta]  -- avoid "pink"+  , icount   = 1+  , irarity  = [(5, 20), (8, 1)]+  , iverbHit = "club"+  , iweight  = 1600+  , idamage  = [(96, 8 * d 1), (3, 12 * d 1), (1, 16 * d 1)]+  , iaspects = [AddHurtMelee $ d 2 + dl 2 |*| 3]+  , ieffects = [EqpSlot EqpSlotWeapon]+  , ifeature = [ toVelocity 40  -- ensuring it hits with the tip costs speed+               , Durable, Identified, Meleeable ]+  , idesc    = "It may not cause grave wounds, but neither does it glance off nor ricochet. Great sidearm for opportunistic blows against armored foes."+  , ikit     = []+  }+hammerParalyze = hammer+  { iname    = "Concussion Hammer"+  , ifreq    = [("treasure", 20)]+  , irarity  = [(5, 2), (10, 4)]+  , idamage  = toDmg $ 8 * d 1+  , iaspects = iaspects hammer ++ [Timeout $ d 2 + 3 - dl 2 |*| 2]+  , ieffects = ieffects hammer ++ [Unique, Recharging $ Paralyze 10]+  }+hammerSpark = hammer+  { iname    = "Grand Smithhammer"+  , ifreq    = [("treasure", 20)]+  , irarity  = [(5, 2), (10, 4)]+  , idamage  = toDmg $ 8 * d 1+  , iaspects = iaspects hammer ++ [Timeout $ d 4 + 4 - dl 4 |*| 2]+  , ieffects = ieffects hammer ++ [Unique, Recharging $ Explode "spark"]+  }+sword = ItemKind+  { isymbol  = symbolEdged+  , iname    = "sword"+  , ifreq    = [("useful", 100), ("starting weapon", 10)]+  , iflavour = zipPlain [BrBlue]+  , icount   = 1+  , irarity  = [(4, 1), (5, 15)]+  , iverbHit = "slash"+  , iweight  = 2000+  , idamage  = toDmg $ 10 * d 1+  , iaspects = []+  , ieffects = [EqpSlot EqpSlotWeapon]+  , ifeature = [ toVelocity 40  -- ensuring it hits with the tip costs speed+               , Durable, Identified, Meleeable ]+  , idesc    = "Difficult to master; deadly when used effectively. The steel is particularly hard and keen, but rusts quickly without regular maintenance."+  , ikit     = []+  }+swordImpress = sword+  { iname    = "Master's Sword"+  , ifreq    = [("treasure", 20)]+  , irarity  = [(5, 1), (10, 4)]+  , iaspects = [Timeout $ d 4 + 5 - dl 4 |*| 2]+  , ieffects = ieffects sword+               ++ [Unique, Recharging Impress, Recharging (DetectActor 3)]+  , idesc    = "A particularly well-balance blade, lending itself to impressive shows of fencing skill. Master sees enemies reflected on its mirror-like surface."+  }+swordNullify = sword+  { iname    = "Gutting Sword"+  , ifreq    = [("treasure", 20)]+  , irarity  = [(5, 1), (10, 4)]+  , iaspects = [Timeout $ d 4 + 5 - dl 4 |*| 2]+  , ieffects = ieffects sword+               ++ [ Unique+                  , Recharging $ DropItem 1 maxBound COrgan+                                          "temporary condition"+                  , Recharging $ RefillCalm (-10) ]+  , idesc    = "Cold, thin blade that pierces deeply and sends its victim into abrupt, sobering shock."+  }+halberd = ItemKind+  { isymbol  = symbolPolearm+  , iname    = "war scythe"+  , ifreq    = [("useful", 100), ("starting weapon", 20)]+  , iflavour = zipPlain [BrYellow]+  , icount   = 1+  , irarity  = [(8, 1), (9, 40)]+  , iverbHit = "impale"+  , iweight  = 3000+  , idamage  = [(96, 12 * d 1), (3, 18 * d 1), (1, 24 * d 1)]+  , iaspects = [ AddHurtMelee (-20)  -- just benign enough to be used+               , AddArmorMelee $ 1 + dl 3 |*| 5 ]+  , ieffects = [EqpSlot EqpSlotWeapon]+  , ifeature = [ toVelocity 20  -- not balanced+               , Durable, Identified, Meleeable ]+  , idesc    = "An improvised but deadly weapon made of a blade from a scythe attached to a long pole."+  , ikit     = []+  }+halberdPushActor = halberd+  { iname    = "Swiss Halberd"+  , ifreq    = [("treasure", 20)]+  , irarity  = [(8, 1), (9, 20)]+  , idamage  = toDmg $ 12 * d 1+  , iaspects = iaspects halberd ++ [Timeout $ d 5 + 5 - dl 5 |*| 2]+  , ieffects = ieffects halberd+               ++ [Unique, Recharging (PushActor (ThrowMod 400 25))]+  , idesc    = "A versatile polearm, with great reach and leverage. Foes are held at a distance."+  }++-- * Wands++wand = ItemKind+  { isymbol  = symbolWand+  , iname    = "wand"+  , ifreq    = [("useful", 100)]+  , iflavour = zipFancy brightCol+  , icount   = 1+  , irarity  = []+  , iverbHit = "club"+  , iweight  = 300+  , idamage  = toDmg 0+  , iaspects = [AddShine 1, AddSpeed (-1)]  -- pulsing with power, distracts+  , ieffects = []+  , ifeature = [ toVelocity 125  -- magic+               , Applicable, Durable ]+  , idesc    = "Buzzing with dazzling light that shines even through appendages that handle it."  -- will have math flavour+  , ikit     = []+  }+wand1 = wand+  { ieffects = []  -- will be: emit a cone of sound shrapnel that makes enemy cover his ears and so drop '|' and '{'+  }+wand2 = wand+  { ieffects = []+  }++-- * Treasure++gem = ItemKind+  { isymbol  = symbolGem+  , iname    = "gem"+  , ifreq    = [("treasure", 100), ("gem", 100)]+  , iflavour = zipPlain $ delete BrYellow brightCol  -- natural, so not fancy+  , icount   = 1+  , irarity  = []+  , iverbHit = "tap"+  , iweight  = 50+  , idamage  = toDmg 0+  , iaspects = [AddShine 1, AddSpeed (-1)]+                 -- reflects strongly, distracts; so it glows in the dark,+                 -- is visible on dark floor, but not too tempting to wear+  , ieffects = []+  , ifeature = [Precious]  -- no @Identified@ and no effects, so never ided+  , idesc    = "Useless, and still worth around 100 gold each. Would gems of thought and pearls of artful design be valued that much in our age of Science and Progress!"+  , ikit     = []+  }+gem1 = gem+  { irarity  = [(2, 0), (10, 12)]+  }+gem2 = gem+  { irarity  = [(4, 0), (10, 14)]+  }+gem3 = gem+  { irarity  = [(6, 0), (10, 16)]+  }+gem4 = gem+  { iname    = "elixir"+  , iflavour = zipPlain [BrYellow]+  , irarity  = [(1, 40), (10, 40)]+  , iaspects = []+  , ieffects = [ELabel "of youth", RefillCalm 5, RefillHP 15]+  , ifeature = [Identified, Applicable, Precious]+  , idesc    = "A crystal vial of amber liquid, supposedly granting eternal youth and fetching 100 gold per piece. The main effect seems to be mild euphoria, but it admittedly heals minor ailments rather well."+  }+currency = ItemKind+  { isymbol  = symbolGold+  , iname    = "gold piece"+  , ifreq    = [("treasure", 100), ("currency", 100)]+  , iflavour = zipPlain [BrYellow]+  , icount   = 10 + d 20 + dl 20+  , irarity  = [(1, 25), (10, 10)]+  , iverbHit = "tap"+  , iweight  = 31+  , idamage  = toDmg 0   , iaspects = []   , ieffects = []   , ifeature = [Identified, Precious]

GameDefinition/Content/ItemKindActor.hs view

@@ -1,8 +1,12 @@ -- | Actor (or rather actor body trunk) definitions.-module Content.ItemKindActor ( actors ) where+module Content.ItemKindActor+  ( actors+  ) where -import qualified Data.EnumMap.Strict as EM+import Prelude () +import Game.LambdaHack.Common.Prelude+ import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Flavour@@ -11,28 +15,32 @@  actors :: [ItemKind] actors =-  [warrior, warrior2, warrior3, warrior4, warrior5, soldier, sniper, civilian, civilian2, civilian3, civilian4, civilian5, eye, fastEye, nose, elbow, torsor, goldenJackal, griffonVulture, skunk, armadillo, gilaMonster, rattlesnake, komodoDragon, hyena, alligator, rhinoceros, beeSwarm, hornetSwarm, thornbush, geyserBoiling, geyserArsenic, geyserSulfur]+  [warrior, warrior2, warrior3, warrior4, warrior5, scout, ranger, escapist, ambusher, soldier, civilian, civilian2, civilian3, civilian4, civilian5, eye, fastEye, nose, elbow, torsor, goldenJackal, griffonVulture, skunk, armadillo, gilaMonster, rattlesnake, komodoDragon, hyena, alligator, rhinoceros, beeSwarm, hornetSwarm, thornbush,+   geyserBoiling, geyserArsenic, geyserSulfur] -warrior,    warrior2, warrior3, warrior4, warrior5, soldier, sniper, civilian, civilian2, civilian3, civilian4, civilian5, eye, fastEye, nose, elbow, torsor, goldenJackal, griffonVulture, skunk, armadillo, gilaMonster, rattlesnake, komodoDragon, hyena, alligator, rhinoceros, beeSwarm, hornetSwarm, thornbush, geyserBoiling, geyserArsenic, geyserSulfur :: ItemKind+warrior,    warrior2, warrior3, warrior4, warrior5, scout, ranger, escapist, ambusher, soldier, civilian, civilian2, civilian3, civilian4, civilian5, eye, fastEye, nose, elbow, torsor, goldenJackal, griffonVulture, skunk, armadillo, gilaMonster, rattlesnake, komodoDragon, hyena, alligator, rhinoceros, beeSwarm, hornetSwarm, thornbush,+   geyserBoiling, geyserArsenic, geyserSulfur :: ItemKind  -- * Hunams  warrior = ItemKind   { isymbol  = '@'-  , iname    = "warrior"  -- modified if in hero faction-  , ifreq    = [("hero", 100), ("civilian", 100), ("mobile", 1)]-  , iflavour = zipPlain [BrBlack]  -- modified if in hero faction+  , iname    = "warrior"  -- modified if initial actors in hero faction+  , ifreq    = [("hero", 100), ("mobile", 1)]+  , iflavour = zipPlain [BrWhite]   , icount   = 1   , irarity  = [(1, 5)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 60  -- partially from clothes and assumed first aid-               , AddMaxCalm 60, AddSpeed 20-               , AddSkills $ EM.fromList [(AbProject, 2), (AbApply, 1)] ]+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 80  -- partially from clothes and assumed first aid+               , AddMaxCalm 70, AddSpeed 20, AddNocto 2+               , AddAbility AbProject 2, AddAbility AbApply 1+               , AddAbility AbAlter 2 ]   , ieffects = []   , ifeature = [Durable, Identified]   , idesc    = ""-  , ikit     = [ ("fist", COrgan), ("foot", COrgan), ("eye 5", COrgan)+  , ikit     = [ ("fist", COrgan), ("foot", COrgan), ("eye 6", COrgan)                , ("sapient brain", COrgan) ]   } warrior2 = warrior@@ -44,25 +52,48 @@ warrior5 = warrior   { iname    = "scientist" } -soldier = warrior-  { iname    = "soldier"-  , ifreq    = [("soldier", 100), ("mobile", 1)]-  , ikit     = ikit warrior ++ [("starting weapon", CEqp)]+scout = warrior+  { iname    = "scout"+  , ifreq    = [("scout hero", 100), ("mobile", 1)]+  , ikit     = ikit warrior+               ++ [ ("add sight", CEqp)+                  , ("armor ranged", CEqp)+                  , ("add nocto 1", CInv) ]   }-sniper = warrior-  { iname    = "sniper"-  , ifreq    = [("sniper", 100), ("mobile", 1)]+ranger = warrior+  { iname    = "ranger"+  , ifreq    = [("ranger hero", 100), ("mobile", 1)]+  , ikit     = ikit warrior ++ [("weak arrow", CInv), ("armor ranged", CEqp)]+  }+escapist = warrior+  { iname    = "escapist"+  , ifreq    = [("escapist hero", 100), ("mobile", 1)]   , ikit     = ikit warrior+               ++ [ ("add sight", CEqp)+                  , ("weak arrow", CInv)  -- mostly for probing+                  , ("armor ranged", CEqp)+                  , ("flask", CInv)+                  , ("light source", CInv)+                  , ("blanket", CInv) ]+  }+ambusher = warrior+  { iname    = "ambusher"+  , ifreq    = [("ambusher hero", 100), ("mobile", 1)]+  , ikit     = ikit warrior  -- dark and numerous, so more kit without exploring                ++ [ ("ring of opportunity sniper", CEqp)-                  , ("any arrow", CSha), ("any arrow", CInv)-                  , ("any arrow", CInv), ("any arrow", CInv)-                  , ("flask", CInv), ("light source", CSha)-                  , ("light source", CInv), ("light source", CInv) ]+                  , ("light source", CEqp), ("wooden torch", CInv)+                  , ("weak arrow", CInv), ("any arrow", CSha), ("flask", CSha) ]   }+soldier = warrior+  { iname    = "soldier"+  , ifreq    = [("soldier hero", 100), ("mobile", 1)]+  , ikit     = ikit warrior ++ [("starting weapon", CEqp)]+  }  civilian = warrior   { iname    = "clerk"-  , ifreq    = [("civilian", 100), ("mobile", 1)] }+  , ifreq    = [("civilian", 100), ("mobile", 1)]+  , iflavour = zipPlain [BrBlack] } civilian2 = civilian   { iname    = "hairdresser" } civilian3 = civilian@@ -74,17 +105,23 @@  -- * Monsters +-- They have bright colours, because they are not natural.+ eye = ItemKind   { isymbol  = 'e'   , iname    = "reducible eye"-  , ifreq    = [("monster", 100), ("horror", 100), ("mobile monster", 100)]+  , ifreq    = [ ("monster", 100), ("mobile", 1)+               , ("mobile monster", 100), ("scout monster", 10) ]   , iflavour = zipFancy [BrRed]   , icount   = 1   , irarity  = [(1, 10), (10, 6)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 16, AddMaxCalm 60, AddSpeed 20-               , AddSkills $ EM.fromList [(AbProject, 2), (AbApply, 1)] ]+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 16, AddMaxCalm 70, AddSpeed 20, AddNocto 2+               , AddAggression 1+               , AddAbility AbProject 2, AddAbility AbApply 1+               , AddAbility AbAlter 2 ]   , ieffects = []   , ifeature = [Durable, Identified]   , idesc    = "Under your stare, it reduces to the bits that define its essence. Under introspection, the bits slow down and solidify into an arbitrary form again. It must be huge inside, for holographic principle to manifest so overtly."  -- holographic principle is an anachronism for XIX or most of XX century, but "the cosmological scale effects" is too weak@@ -94,31 +131,37 @@ fastEye = ItemKind   { isymbol  = 'j'   , iname    = "injective jaw"-  , ifreq    = [("monster", 100), ("horror", 100), ("mobile monster", 100)]+  , ifreq    = [ ("monster", 100), ("mobile", 1)+               , ("mobile monster", 100), ("scout monster", 60) ]   , iflavour = zipFancy [BrBlue]   , icount   = 1   , irarity  = [(5, 5), (10, 5)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 5, AddMaxCalm 60, AddSpeed 30 ]+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 5, AddMaxCalm 70, AddSpeed 30, AddNocto 2+               , AddAggression 1+               , AddAbility AbAlter 2 ]   , ieffects = []   , ifeature = [Durable, Identified]   , idesc    = "Hungers but never eats. Bites but never swallows. Burrows its own image through, but never carries anything back."  -- rather weak: not about injective objects, but puny, concrete, injective functions  --- where's the madness in that?   , ikit     = [ ("tooth", COrgan), ("speed gland 10", COrgan)-               , ("lip", COrgan), ("vision 4", COrgan)+               , ("lip", COrgan), ("vision 6", COrgan)                , ("sapient brain", COrgan) ]   } nose = ItemKind  -- depends solely on smell   { isymbol  = 'n'   , iname    = "point-free nose"-  , ifreq    = [("monster", 100), ("horror", 100), ("mobile monster", 100)]+  , ifreq    = [("monster", 100), ("mobile", 1), ("mobile monster", 100)]   , iflavour = zipFancy [BrGreen]   , icount   = 1   , irarity  = [(1, 5), (4, 2), (10, 5)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 30, AddMaxCalm 30, AddSpeed 18-               , AddSkills $ EM.fromList [(AbProject, -1)] ]+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 30, AddMaxCalm 30, AddSpeed 18, AddNocto 2+               , AddAggression 1+               , AddAbility AbProject (-1), AddAbility AbAlter 2 ]   , ieffects = []   , ifeature = [Durable, Identified]   , idesc    = "No mouth, yet it devours everything around, constantly sniffing itself inward; pure movement structure, no constant point to focus one's maddened gaze on."@@ -128,22 +171,24 @@ elbow = ItemKind   { isymbol  = 'e'   , iname    = "commutative elbow"-  , ifreq    = [("monster", 100), ("horror", 100), ("mobile monster", 100)]+  , ifreq    = [ ("monster", 100), ("mobile", 1)+               , ("mobile monster", 100), ("scout monster", 30) ]   , iflavour = zipFancy [BrMagenta]   , icount   = 1   , irarity  = [(7, 1), (10, 5)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 8, AddMaxCalm 90, AddSpeed 21-               , AddSkills-                 $ EM.fromList [(AbProject, 2), (AbApply, 1), (AbMelee, -1)] ]+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 8, AddMaxCalm 80, AddSpeed 21, AddNocto 2+               , AddAbility AbProject 2, AddAbility AbApply 1+               , AddAbility AbAlter 2, AddAbility AbMelee (-1) ]   , ieffects = []   , ifeature = [Durable, Identified]   , idesc    = "An arm strung like a bow. A few edges, but none keen enough. A few points, but none piercing. Deadly objects zip out of the void."   , ikit     = [ ("speed gland 4", COrgan), ("armored skin", COrgan)-               , ("vision 14", COrgan)+               , ("vision 16", COrgan)                , ("any arrow", CSha), ("any arrow", CInv)-               , ("any arrow", CInv), ("any arrow", CInv)+               , ("weak arrow", CInv), ("weak arrow", CInv)                , ("sapient brain", COrgan) ]   } torsor = ItemKind@@ -155,11 +200,12 @@   , irarity  = [(9, 0), (10, 1000)]  -- unique   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ Unique, AddMaxHP 300, AddMaxCalm 100, AddSpeed 10-               , AddSkills $ EM.fromList-                   [(AbProject, 2), (AbApply, 1), (AbTrigger, -1)] ]-                   -- can't switch levels, a miniboss-  , ieffects = []+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 300, AddMaxCalm 100, AddSpeed 10, AddNocto 2+               , AddAggression 3+               , AddAbility AbProject 2, AddAbility AbApply 1 ]+                 -- can't exit the gated level, the boss+  , ieffects = [Unique]   , ifeature = [Durable, Identified]   , idesc    = "A principal homogeneous manifold, that acts freely and with enormous force, but whose stabilizers are trivial, making it rather helpless without a support group."   , ikit     = [ ("right torsion", COrgan), ("left torsion", COrgan)@@ -176,163 +222,181 @@ -- They need rather strong melee, because they don't use items. -- Unless/until they level up. +-- They have dull colors, except for yellow, because there is no dull variant.+ goldenJackal = ItemKind  -- basically a much smaller and slower hyena   { isymbol  = 'j'   , iname    = "golden jackal"-  , ifreq    = [("animal", 100), ("horror", 100), ("mobile animal", 100), ("scavenger", 50)]+  , ifreq    = [ ("animal", 100), ("mobile", 1), ("mobile animal", 100)+               , ("scavenger", 50) ]   , iflavour = zipPlain [BrYellow]   , icount   = 1-  , irarity  = [(1, 5)]+  , irarity  = [(1, 3)]   , iverbHit = "thud"   , iweight  = 13000-  , iaspects = [ AddMaxHP 12, AddMaxCalm 60, AddSpeed 22 ]+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 12, AddMaxCalm 70, AddSpeed 24, AddNocto 2 ]   , ieffects = []   , ifeature = [Durable, Identified]   , idesc    = ""-  , ikit     = [ ("small jaw", COrgan), ("eye 5", COrgan), ("nostril", COrgan)+  , ikit     = [ ("small jaw", COrgan), ("eye 6", COrgan), ("nostril", COrgan)                , ("animal brain", COrgan) ]   } griffonVulture = ItemKind   { isymbol  = 'v'   , iname    = "griffon vulture"-  , ifreq    = [("animal", 100), ("horror", 100), ("mobile animal", 100), ("scavenger", 30)]+  , ifreq    = [ ("animal", 100), ("mobile", 1), ("mobile animal", 100)+               , ("scavenger", 30) ]   , iflavour = zipPlain [BrYellow]   , icount   = 1   , irarity  = [(1, 5)]   , iverbHit = "thud"   , iweight  = 13000-  , iaspects = [ AddMaxHP 12, AddMaxCalm 60, AddSpeed 20-               , AddSkills $ EM.singleton AbAlter (-1) ]+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 12, AddMaxCalm 80, AddSpeed 22, AddNocto 2+               , AddAbility AbAlter (-2) ]  -- can't use stairs nor doors+      -- Animals don't have leader, usually, so even if only one of level,+      -- it pays the communication overhead, so the speed is higher to get+      -- them on par with human leaders moving solo. Random double moves,+      -- on either side, are just too frustrating.   , ieffects = []   , ifeature = [Durable, Identified]   , idesc    = ""   , ikit     = [ ("screeching beak", COrgan)  -- in reality it grunts and hisses-               , ("small claw", COrgan), ("eye 6", COrgan)+               , ("small claw", COrgan), ("eye 7", COrgan)                , ("animal brain", COrgan) ]   } skunk = ItemKind   { isymbol  = 's'   , iname    = "hog-nosed skunk"-  , ifreq    = [("animal", 100), ("horror", 100), ("mobile animal", 100)]+  , ifreq    = [("animal", 100), ("mobile", 1), ("mobile animal", 100)]   , iflavour = zipPlain [White]   , icount   = 1   , irarity  = [(1, 5), (10, 3)]   , iverbHit = "thud"   , iweight  = 4000-  , iaspects = [ AddMaxHP 10, AddMaxCalm 30, AddSpeed 20-               , AddSkills $ EM.singleton AbAlter (-1) ]+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 10, AddMaxCalm 30, AddSpeed 22, AddNocto 2+               , AddAbility AbAlter (-2) ]  -- can't use stairs nor doors   , ieffects = []   , ifeature = [Durable, Identified]   , idesc    = ""   , ikit     = [ ("scent gland", COrgan)                , ("small claw", COrgan), ("snout", COrgan)-               , ("nostril", COrgan), ("eye 2", COrgan)+               , ("nostril", COrgan), ("eye 3", COrgan)                , ("animal brain", COrgan) ]   } armadillo = ItemKind   { isymbol  = 'a'   , iname    = "giant armadillo"-  , ifreq    = [("animal", 100), ("horror", 100), ("mobile animal", 100)]+  , ifreq    = [("animal", 100), ("mobile", 1), ("mobile animal", 100)]   , iflavour = zipPlain [Brown]   , icount   = 1   , irarity  = [(1, 5)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 20, AddMaxCalm 30, AddSpeed 17-               , AddSkills $ EM.singleton AbAlter (-1) ]+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 20, AddMaxCalm 30, AddSpeed 20, AddNocto 2+               , AddAbility AbAlter (-2) ]  -- can't use stairs nor doors   , ieffects = []   , ifeature = [Durable, Identified]   , idesc    = ""-  , ikit     = [ ("claw", COrgan), ("snout", COrgan), ("armored skin", COrgan)-               , ("nostril", COrgan), ("eye 2", COrgan)-               , ("animal brain", COrgan) ]+  , ikit     = [ ("hooked claw", COrgan), ("snout", COrgan)+               , ("armored skin", COrgan), ("nostril", COrgan)+               , ("eye 3", COrgan), ("animal brain", COrgan) ]   } gilaMonster = ItemKind   { isymbol  = 'g'   , iname    = "Gila monster"-  , ifreq    = [("animal", 100), ("horror", 100), ("mobile animal", 100)]+  , ifreq    = [("animal", 100), ("mobile", 1), ("mobile animal", 100)]   , iflavour = zipPlain [Magenta]   , icount   = 1   , irarity  = [(2, 5), (10, 3)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 12, AddMaxCalm 60, AddSpeed 15-               , AddSkills $ EM.singleton AbAlter (-1) ]+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 12, AddMaxCalm 50, AddSpeed 18, AddNocto 2+               , AddAbility AbAlter (-2) ]  -- can't use stairs nor doors   , ieffects = []   , ifeature = [Durable, Identified]   , idesc    = ""   , ikit     = [ ("venom tooth", COrgan), ("small claw", COrgan)-               , ("eye 2", COrgan), ("nostril", COrgan)+               , ("eye 3", COrgan), ("nostril", COrgan)                , ("animal brain", COrgan) ]   } rattlesnake = ItemKind   { isymbol  = 's'   , iname    = "rattlesnake"-  , ifreq    = [("animal", 100), ("horror", 100), ("mobile animal", 100)]+  , ifreq    = [("animal", 100), ("mobile", 1), ("mobile animal", 100)]   , iflavour = zipPlain [Brown]   , icount   = 1   , irarity  = [(4, 1), (10, 7)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 25, AddMaxCalm 60, AddSpeed 15-               , AddSkills $ EM.singleton AbAlter (-1) ]+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 25, AddMaxCalm 60, AddSpeed 16, AddNocto 2+               , AddAbility AbAlter (-2) ]  -- can't use stairs nor doors   , ieffects = []   , ifeature = [Durable, Identified]   , idesc    = ""   , ikit     = [ ("venom fang", COrgan)-               , ("eye 3", COrgan), ("nostril", COrgan)+               , ("eye 4", COrgan), ("nostril", COrgan)                , ("animal brain", COrgan) ]   } komodoDragon = ItemKind  -- bad hearing; regeneration makes it very powerful   { isymbol  = 'k'   , iname    = "Komodo dragon"-  , ifreq    = [("animal", 100), ("horror", 100), ("mobile animal", 100)]+  , ifreq    = [("animal", 100), ("mobile", 1), ("mobile animal", 100)]   , iflavour = zipPlain [Blue]   , icount   = 1-  , irarity  = [(7, 0), (10, 10)]+  , irarity  = [(9, 0), (10, 10)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 41, AddMaxCalm 60, AddSpeed 16 ]+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 41, AddMaxCalm 60, AddSpeed 18, AddNocto 2 ]   , ieffects = []   , ifeature = [Durable, Identified]   , idesc    = ""-  , ikit     = [ ("large tail", COrgan), ("jaw", COrgan), ("claw", COrgan)-               , ("speed gland 4", COrgan), ("armored skin", COrgan)-               , ("eye 2", COrgan), ("nostril", COrgan)-               , ("animal brain", COrgan) ]+  , ikit     = [ ("large tail", COrgan), ("jaw", COrgan)+               , ("hooked claw", COrgan), ("speed gland 4", COrgan)+               , ("armored skin", COrgan), ("eye 3", COrgan)+               , ("nostril", COrgan), ("animal brain", COrgan) ]   } hyena = ItemKind   { isymbol  = 'h'   , iname    = "spotted hyena"-  , ifreq    = [("animal", 100), ("horror", 100), ("mobile animal", 100), ("scavenger", 20)]+  , ifreq    = [ ("animal", 100), ("mobile", 1), ("mobile animal", 100)+               , ("scavenger", 20) ]   , iflavour = zipPlain [BrYellow]   , icount   = 1   , irarity  = [(4, 1), (10, 8)]   , iverbHit = "thud"   , iweight  = 60000-  , iaspects = [ AddMaxHP 20, AddMaxCalm 60, AddSpeed 30 ]+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 20, AddMaxCalm 70, AddSpeed 32, AddNocto 2 ]   , ieffects = []   , ifeature = [Durable, Identified]   , idesc    = ""-  , ikit     = [ ("jaw", COrgan), ("eye 5", COrgan), ("nostril", COrgan)+  , ikit     = [ ("jaw", COrgan), ("eye 6", COrgan), ("nostril", COrgan)                , ("animal brain", COrgan) ]   } alligator = ItemKind   { isymbol  = 'a'   , iname    = "alligator"-  , ifreq    = [("animal", 100), ("horror", 100), ("mobile animal", 100)]+  , ifreq    = [("animal", 100), ("mobile", 1), ("mobile animal", 100)]   , iflavour = zipPlain [Blue]   , icount   = 1-  , irarity  = [(6, 1), (10, 9)]+  , irarity  = [(8, 1), (10, 9)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 41, AddMaxCalm 60, AddSpeed 15 ]+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 41, AddMaxCalm 70, AddSpeed 18, AddNocto 2 ]   , ieffects = []   , ifeature = [Durable, Identified]   , idesc    = ""   , ikit     = [ ("large jaw", COrgan), ("large tail", COrgan)                , ("small claw", COrgan)-               , ("armored skin", COrgan), ("eye 5", COrgan)+               , ("armored skin", COrgan), ("eye 6", COrgan)                , ("animal brain", COrgan) ]   } rhinoceros = ItemKind@@ -344,10 +408,11 @@   , irarity  = [(2, 0), (3, 1000000), (4, 0)]  -- unique   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ Unique, AddMaxHP 90, AddMaxCalm 60, AddSpeed 25-               , AddSkills $ EM.singleton AbTrigger (-1) ]-                   -- can't switch levels, a miniboss-  , ieffects = []+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 90, AddMaxCalm 60, AddSpeed 27, AddNocto 2+               , AddAggression 2+               , AddAbility AbAlter (-1) ]  -- can't switch levels, a miniboss+  , ieffects = [Unique]   , ifeature = [Durable, Identified]   , idesc    = "The last of its kind. Blind with rage. Charges at deadly speed."   , ikit     = [ ("armored skin", COrgan), ("eye 2", COrgan)@@ -360,49 +425,53 @@ beeSwarm = ItemKind   { isymbol  = 'b'   , iname    = "bee swarm"-  , ifreq    = [("animal", 100), ("horror", 100)]+  , ifreq    = [("animal", 100), ("mobile", 1)]   , iflavour = zipPlain [Brown]   , icount   = 1   , irarity  = [(1, 2), (10, 4)]   , iverbHit = "thud"   , iweight  = 1000-  , iaspects = [ AddMaxHP 8, AddMaxCalm 60, AddSpeed 30-               , AddSkills $ EM.singleton AbAlter (-1) ]  -- armor in sting+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 8, AddMaxCalm 60+               , AddSpeed 30, AddNocto 2  -- armor in sting+               , AddAbility AbAlter (-2) ]  -- can't use stairs nor doors   , ieffects = []   , ifeature = [Durable, Identified]   , idesc    = ""-  , ikit     = [ ("bee sting", COrgan), ("vision 4", COrgan)+  , ikit     = [ ("bee sting", COrgan), ("vision 6", COrgan)                , ("insect mortality", COrgan), ("animal brain", COrgan) ]   } hornetSwarm = ItemKind   { isymbol  = 'h'   , iname    = "hornet swarm"-  , ifreq    = [("animal", 100), ("horror", 100), ("mobile animal", 100)]+  , ifreq    = [("animal", 100), ("mobile", 1), ("mobile animal", 100)]   , iflavour = zipPlain [Magenta]   , icount   = 1   , irarity  = [(5, 1), (10, 8)]   , iverbHit = "thud"   , iweight  = 1000-  , iaspects = [ AddMaxHP 8, AddMaxCalm 60, AddSpeed 30-               , AddSkills $ EM.singleton AbAlter (-1)-               , AddArmorMelee 80, AddArmorRanged 80 ]+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 8, AddMaxCalm 70, AddSpeed 30, AddNocto 2+               , AddAbility AbAlter (-2)  -- can't use stairs nor doors+               , AddArmorMelee 80, AddArmorRanged 40 ]   , ieffects = []   , ifeature = [Durable, Identified]   , idesc    = ""-  , ikit     = [ ("sting", COrgan), ("vision 4", COrgan)+  , ikit     = [ ("sting", COrgan), ("vision 8", COrgan)                , ("insect mortality", COrgan), ("animal brain", COrgan) ]   } thornbush = ItemKind   { isymbol  = 't'   , iname    = "thornbush"-  , ifreq    = [("animal", 50), ("immobile vents", 100)]+  , ifreq    = [("animal", 50), ("immobile animal", 100)]   , iflavour = zipPlain [Brown]   , icount   = 1-  , irarity  = [(1, 3)]+  , irarity  = [(1, 2)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 20, AddMaxCalm 999, AddSpeed 20-               , AddSkills $ EM.fromList (zip [AbWait, AbMelee] [1, 1..]) ]+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 20, AddMaxCalm 999, AddSpeed 22, AddNocto 2+               , AddAbility AbWait 1, AddAbility AbMelee 1 ]   , ieffects = []   , ifeature = [Durable, Identified]   , idesc    = ""@@ -411,15 +480,16 @@ geyserBoiling = ItemKind   { isymbol  = 'g'   , iname    = "geyser"-  , ifreq    = [("animal", 50), ("immobile vents", 50)]+  , ifreq    = [("animal", 50), ("immobile animal", 60)]   , iflavour = zipPlain [Blue]   , icount   = 1   , irarity  = [(5, 2)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 10, AddMaxCalm 999, AddSpeed 10-               , AddSkills $ EM.fromList (zip [AbWait, AbMelee] [1, 1..])-               , AddArmorMelee 80, AddArmorRanged 80 ]+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 20, AddMaxCalm 999, AddSpeed 10, AddNocto 2+               , AddAbility AbWait 1, AddAbility AbMelee 1+               , AddArmorMelee 40, AddArmorRanged 20 ]  -- hard material   , ieffects = []   , ifeature = [Durable, Identified]   , idesc    = ""@@ -428,14 +498,16 @@ geyserArsenic = ItemKind   { isymbol  = 'g'   , iname    = "arsenic geyser"-  , ifreq    = [("animal", 50), ("immobile vents", 100)]+  , ifreq    = [("animal", 50), ("immobile animal", 120)]   , iflavour = zipPlain [Cyan]   , icount   = 1   , irarity  = [(5, 2)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 30, AddMaxCalm 999, AddSpeed 20, AddLight 3-               , AddSkills $ EM.fromList (zip [AbWait, AbMelee] [1, 1..]) ]+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 30, AddMaxCalm 999, AddSpeed 22+               , AddNocto 2, AddShine 3+               , AddAbility AbWait 1, AddAbility AbMelee 1 ]   , ieffects = []   , ifeature = [Durable, Identified]   , idesc    = ""@@ -444,16 +516,18 @@ geyserSulfur = ItemKind   { isymbol  = 'g'   , iname    = "sulfur geyser"-  , ifreq    = [("animal", 50), ("immobile vents", 300)]+  , ifreq    = [("animal", 50), ("immobile animal", 300)]   , iflavour = zipPlain [BrYellow]  -- exception, animal with bright color   , icount   = 1   , irarity  = [(5, 2)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 30, AddMaxCalm 999, AddSpeed 20, AddLight 3-               , AddSkills $ EM.fromList (zip [AbWait, AbMelee] [1, 1..]) ]+  , idamage  = toDmg 0+  , iaspects = [ AddMaxHP 30, AddMaxCalm 999, AddSpeed 22+               , AddNocto 2, AddShine 3+               , AddAbility AbWait 1, AddAbility AbMelee 1 ]   , ieffects = []-  , ifeature = [Durable, Identified]  -- TODO: only heal humans+  , ifeature = [Durable, Identified]   , idesc    = ""   , ikit     = [("sulfur vent", COrgan), ("sulfur fissure", COrgan)]   }

GameDefinition/Content/ItemKindBlast.hs view

@@ -1,19 +1,28 @@ -- | Blast definitions.-module Content.ItemKindBlast ( blasts ) where+module Content.ItemKindBlast+  ( blasts+  ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Dice import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg import Game.LambdaHack.Content.ItemKind  blasts :: [ItemKind] blasts =-  [burningOil2, burningOil3, burningOil4, explosionBlast2, explosionBlast10, explosionBlast20, firecracker2, firecracker3, firecracker4, firecracker5, firecracker6, firecracker7, fragrance, pheromone, mistCalming, odorDistressing, mistHealing, mistHealing2, mistWounding, distortion, waste, glassPiece, smoke, boilingWater, glue, spark, mistAntiSlow, mistAntidote, mistStrength, mistWeakness, protectingBalm, vulnerabilityBalm, hasteSpray, slownessSpray, eyeDrop, smellyDroplet, whiskeySpray]+  [burningOil2, burningOil3, burningOil4, explosionBlast2, explosionBlast10, explosionBlast20, firecracker2, firecracker3, firecracker4, firecracker5, firecracker6, firecracker7, fragrance, pheromone, mistCalming, odorDistressing, mistHealing, mistHealing2, mistWounding, distortion, glassPiece, smoke, boilingWater, glue, singleSpark, spark, denseShower, sparseShower, protectingBalmMelee, protectingBalmRanged, vulnerabilityBalm, resolutionDust, hasteSpray, slownessMist, eyeDrop, ironFiling, smellyDroplet, eyeShine, whiskeySpray, waste, youthSprinkle, poisonCloud, mistAntiSlow, mistAntidote] -burningOil2,    burningOil3, burningOil4, explosionBlast2, explosionBlast10, explosionBlast20, firecracker2, firecracker3, firecracker4, firecracker5, firecracker6, firecracker7, fragrance, pheromone, mistCalming, odorDistressing, mistHealing, mistHealing2, mistWounding, distortion, waste, glassPiece, smoke, boilingWater, glue, spark, mistAntiSlow, mistAntidote, mistStrength, mistWeakness, protectingBalm, vulnerabilityBalm, hasteSpray, slownessSpray, eyeDrop, smellyDroplet, whiskeySpray :: ItemKind+burningOil2,    burningOil3, burningOil4, explosionBlast2, explosionBlast10, explosionBlast20, firecracker2, firecracker3, firecracker4, firecracker5, firecracker6, firecracker7, fragrance, pheromone, mistCalming, odorDistressing, mistHealing, mistHealing2, mistWounding, distortion, glassPiece, smoke, boilingWater, glue, singleSpark, spark, denseShower, sparseShower, protectingBalmMelee, protectingBalmRanged, vulnerabilityBalm, resolutionDust, hasteSpray, slownessMist, eyeDrop, ironFiling, smellyDroplet, eyeShine, whiskeySpray, waste, youthSprinkle, poisonCloud, mistAntiSlow, mistAntidote :: ItemKind +-- We take care (e.g., in burningOil below) that blasts are not faster+-- than 100% fastest natural speed, or some frames would be skipped,+-- which is a waste of prefectly good frames.+ -- * Parameterized immediate effect blasts  burningOil :: Int -> ItemKind@@ -22,35 +31,38 @@   , iname    = "burning oil"   , ifreq    = [(toGroupName $ "burning oil" <+> tshow n, 1)]   , iflavour = zipFancy [BrYellow]-  , icount   = intToDice (n * 5)+  , icount   = intToDice (n * 8)   , irarity  = [(1, 1)]-  , iverbHit = "burn"+  , iverbHit = "sear"   , iweight  = 1-  , iaspects = [AddLight 2]-  , ieffects = [Burn 1, Paralyze 1]  -- tripping on oil-  , ifeature = [ toVelocity (min 100 $ n * 7)+  , idamage  = toDmg 0+  , iaspects = [AddShine 2]+  , ieffects = [Burn 1, Paralyze 2]  -- tripping on oil+  , ifeature = [ toVelocity (min 100 $ n `div` 2 * 10)                , Fragile, Identified ]   , idesc    = "Sticky oil, burning brightly."   , ikit     = []   }-burningOil2 = burningOil 2-burningOil3 = burningOil 3-burningOil4 = burningOil 4+burningOil2 = burningOil 2  -- 2 steps, 2 turns+burningOil3 = burningOil 3  -- 3 steps, 2 turns+burningOil4 = burningOil 4  -- 4 steps, 2 turns explosionBlast :: Int -> ItemKind explosionBlast n = ItemKind   { isymbol  = '*'   , iname    = "blast"   , ifreq    = [(toGroupName $ "blast" <+> tshow n, 1)]   , iflavour = zipPlain [BrRed]-  , icount   = 15  -- strong, but few, so not always hits target+  , icount   = 16  -- strong and wide, but few, so not always hits target   , irarity  = [(1, 1)]   , iverbHit = "tear apart"   , iweight  = 1-  , iaspects = [AddLight $ intToDice n]+  , idamage  = toDmg 0+  , iaspects = [AddShine $ intToDice $ min 10 n]   , ieffects = [RefillHP (- n `div` 2)]-               ++ [PushActor (ThrowMod (100 * (n `div` 5)) 50)]-               ++ [DropItem COrgan "temporary conditions" True | n >= 10]-  , ifeature = [Fragile, toLinger 20, Identified]+               ++ [PushActor (ThrowMod (100 * (n `div` 5)) 50)| n >= 10]+               ++ [DropItem 1 maxBound COrgan "temporary condition" | n >= 10]+               ++ [DropItem 1 maxBound COrgan "impressed" | n >= 10]  -- shock+  , ifeature = [toLinger 20, Fragile, Identified]  -- 4 steps, 1 turn   , idesc    = ""   , ikit     = []   }@@ -67,13 +79,14 @@   , irarity  = [(1, 1)]   , iverbHit = "crack"   , iweight  = 1-  , iaspects = [AddLight $ intToDice $ n `div` 2]+  , idamage  = toDmg 0+  , iaspects = [AddShine $ intToDice $ n `div` 2]   , ieffects = [ RefillCalm (-1) | n >= 5 ]                ++ [ DropBestWeapon | n >= 5]                ++ [ OnSmash (Explode $ toGroupName                              $ "firecracker" <+> tshow (n - 1))                   | n > 2 ]-  , ifeature = [ ToThrow $ ThrowMod (10 + 3 * n) (10 + 100 `div` n)+  , ifeature = [ ToThrow $ ThrowMod (5 + 3 * n) (10 + 100 `div` n)                , Fragile, Identified ]   , idesc    = ""   , ikit     = []@@ -88,89 +101,89 @@ -- * Assorted immediate effect blasts  fragrance = ItemKind-  { isymbol  = '\''-  , iname    = "fragrance"+  { isymbol  = '`'+  , iname    = "fragrance"  -- instant, fast fragrance   , ifreq    = [("fragrance", 1)]   , iflavour = zipFancy [Magenta]-  , icount   = 20+  , icount   = 16   , irarity  = [(1, 1)]   , iverbHit = "engulf"   , iweight  = 1+  , idamage  = toDmg 0   , iaspects = []   , ieffects = [Impress]   -- Linger 10, because sometimes it takes 2 turns due to starting just   -- before actor turn's end (e.g., via a necklace).-  , ifeature = [ ToThrow $ ThrowMod 28 10  -- 2 steps, one turn-               , Fragile, Identified ]+  , ifeature = [toLinger 10, Fragile, Identified]  -- 2 steps, 1 turn   , idesc    = ""   , ikit     = []   } pheromone = ItemKind-  { isymbol  = '\''-  , iname    = "musky whiff"+  { isymbol  = '`'+  , iname    = "musky whiff"  -- a kind of mist rather than fragrance   , ifreq    = [("pheromone", 1)]   , iflavour = zipFancy [BrMagenta]-  , icount   = 18+  , icount   = 16   , irarity  = [(1, 1)]   , iverbHit = "tempt"   , iweight  = 1+  , idamage  = toDmg 0   , iaspects = []-  , ieffects = [Impress, OverfillCalm (-20)]-  , ifeature = [ toVelocity 13  -- the slowest that travels at least 2 steps-               , Fragile, Identified ]+  , ieffects = [Impress, RefillCalm (-10)]+  , ifeature = [toVelocity 10, Fragile, Identified]  -- 2 steps, 2 turns   , idesc    = ""   , ikit     = []   }-mistCalming = ItemKind-  { isymbol  = '\''+mistCalming = ItemKind  -- unused+  { isymbol  = '`'   , iname    = "mist"   , ifreq    = [("calming mist", 1)]   , iflavour = zipFancy [White]-  , icount   = 19+  , icount   = 8   , irarity  = [(1, 1)]   , iverbHit = "sooth"   , iweight  = 1+  , idamage  = toDmg 0   , iaspects = []   , ieffects = [RefillCalm 2]-  , ifeature = [ toVelocity 13  -- the slowest that travels at least 2 steps-               , Fragile, Identified ]+  , ifeature = [toVelocity 5, Fragile, Identified]  -- 1 step, 1 turn   , idesc    = ""   , ikit     = []   } odorDistressing = ItemKind-  { isymbol  = '\''+  { isymbol  = '`'   , iname    = "distressing whiff"   , ifreq    = [("distressing odor", 1)]   , iflavour = zipFancy [BrRed]-  , icount   = 10+  , icount   = 16   , irarity  = [(1, 1)]   , iverbHit = "distress"   , iweight  = 1+  , idamage  = toDmg 0   , iaspects = []-  , ieffects = [OverfillCalm (-20)]-  , ifeature = [ toVelocity 13  -- the slowest that travels at least 2 steps-               , Fragile, Identified ]+  , ieffects = [RefillCalm (-20)]+  , ifeature = [toLinger 10, Fragile, Identified]  -- 2 steps, 1 turn   , idesc    = ""   , ikit     = []   } mistHealing = ItemKind-  { isymbol  = '\''-  , iname    = "mist"+  { isymbol  = '`'+  , iname    = "mist"  -- powerful, so slow and narrow   , ifreq    = [("healing mist", 1)]   , iflavour = zipFancy [White]-  , icount   = 9+  , icount   = 8   , irarity  = [(1, 1)]   , iverbHit = "revitalize"   , iweight  = 1-  , iaspects = [AddLight 1]+  , idamage  = toDmg 0+  , iaspects = [AddShine 1]   , ieffects = [RefillHP 2]-  , ifeature = [ toVelocity 7  -- the slowest that gets anywhere (1 step only)-               , Fragile, Identified ]+  , ifeature = [toVelocity 5, Fragile, Identified]  -- 1 step, 1 turn   , idesc    = ""   , ikit     = []   } mistHealing2 = ItemKind-  { isymbol  = '\''+  { isymbol  = '`'   , iname    = "mist"   , ifreq    = [("healing mist 2", 1)]   , iflavour = zipFancy [White]@@ -178,26 +191,26 @@   , irarity  = [(1, 1)]   , iverbHit = "revitalize"   , iweight  = 1-  , iaspects = [AddLight 2]+  , idamage  = toDmg 0+  , iaspects = [AddShine 2]   , ieffects = [RefillHP 4]-  , ifeature = [ toVelocity 7  -- the slowest that gets anywhere (1 step only)-               , Fragile, Identified ]+  , ifeature = [toVelocity 5, Fragile, Identified]  -- 1 step, 1 turn   , idesc    = ""   , ikit     = []   } mistWounding = ItemKind-  { isymbol  = '\''+  { isymbol  = '`'   , iname    = "mist"   , ifreq    = [("wounding mist", 1)]   , iflavour = zipFancy [White]-  , icount   = 7+  , icount   = 8   , irarity  = [(1, 1)]   , iverbHit = "devitalize"   , iweight  = 1+  , idamage  = toDmg 0   , iaspects = []   , ieffects = [RefillHP (-2)]-  , ifeature = [ toVelocity 7  -- the slowest that gets anywhere (1 step only)-               , Fragile, Identified ]+  , ifeature = [toVelocity 5, Fragile, Identified]  -- 1 step, 1 turn   , idesc    = ""   , ikit     = []   }@@ -206,30 +219,14 @@   , iname    = "vortex"   , ifreq    = [("distortion", 1)]   , iflavour = zipFancy [White]-  , icount   = 6+  , icount   = 16   , irarity  = [(1, 1)]   , iverbHit = "engulf"   , iweight  = 1+  , idamage  = toDmg 0   , iaspects = []   , ieffects = [Teleport $ 15 + d 10]-  , ifeature = [ toVelocity 7  -- the slowest that gets anywhere (1 step only)-               , Fragile, Identified ]-  , idesc    = ""-  , ikit     = []-  }-waste = ItemKind-  { isymbol  = '*'-  , iname    = "waste"-  , ifreq    = [("waste", 1)]-  , iflavour = zipPlain [Brown]-  , icount   = 18-  , irarity  = [(1, 1)]-  , iverbHit = "splosh"-  , iweight  = 50-  , iaspects = []-  , ieffects = [RefillHP (-1)]-  , ifeature = [ ToThrow $ ThrowMod 28 10  -- 2 steps, one turn-               , Fragile, Identified ]+  , ifeature = [toLinger 10, Fragile, Identified]  -- 2 steps, 1 turn   , idesc    = ""   , ikit     = []   }@@ -238,28 +235,30 @@   , iname    = "glass piece"   , ifreq    = [("glass piece", 1)]   , iflavour = zipPlain [BrBlue]-  , icount   = 18+  , icount   = 16   , irarity  = [(1, 1)]   , iverbHit = "cut"-  , iweight  = 10+  , iweight  = 1+  , idamage  = toDmg 0   , iaspects = []-  , ieffects = [Hurt (1 * d 1)]-  , ifeature = [toLinger 20, Fragile, Identified]+  , ieffects = [RefillHP (-1)]  -- high velocity, so can't do idamage+  , ifeature = [toLinger 20, Fragile, Identified]  -- 4 steps, 1 turn   , idesc    = ""   , ikit     = []   }-smoke = ItemKind  -- when stuff burns out-  { isymbol  = '\''+smoke = ItemKind  -- when stuff burns out  -- unused+  { isymbol  = '`'   , iname    = "smoke"   , ifreq    = [("smoke", 1)]   , iflavour = zipPlain [BrBlack]-  , icount   = 19+  , icount   = 16   , irarity  = [(1, 1)]-  , iverbHit = "choke"+  , iverbHit = "choke"  -- or obscure   , iweight  = 1+  , idamage  = toDmg 0   , iaspects = []   , ieffects = []-  , ifeature = [ toVelocity 21, Fragile, Identified ]+  , ifeature = [toVelocity 20, Fragile, Identified]  -- 4 steps, 2 turns   , idesc    = ""   , ikit     = []   }@@ -268,13 +267,14 @@   , iname    = "boiling water"   , ifreq    = [("boiling water", 1)]   , iflavour = zipPlain [BrWhite]-  , icount   = 21+  , icount   = 16   , irarity  = [(1, 1)]   , iverbHit = "boil"-  , iweight  = 5+  , iweight  = 1+  , idamage  = toDmg 0   , iaspects = []   , ieffects = [Burn 1]-  , ifeature = [toVelocity 50, Fragile, Identified]+  , ifeature = [toVelocity 30, Fragile, Identified]  -- 6 steps, 2 turns   , idesc    = ""   , ikit     = []   }@@ -283,207 +283,344 @@   , iname    = "hoof glue"   , ifreq    = [("glue", 1)]   , iflavour = zipPlain [BrYellow]-  , icount   = 20+  , icount   = 16   , irarity  = [(1, 1)]   , iverbHit = "glue"-  , iweight  = 20+  , iweight  = 1+  , idamage  = toDmg 0   , iaspects = []-  , ieffects = [Paralyze (3 + d 3)]-  , ifeature = [toVelocity 40, Fragile, Identified]+  , ieffects = [Paralyze 10]+  , ifeature = [toVelocity 20, Fragile, Identified]  -- 4 steps, 2 turns   , idesc    = ""   , ikit     = []   }-spark = ItemKind-  { isymbol  = '\''-  , iname    = "spark"-  , ifreq    = [("spark", 1)]+singleSpark = ItemKind+  { isymbol  = '`'+  , iname    = "single spark"+  , ifreq    = [("single spark", 1)]   , iflavour = zipPlain [BrYellow]-  , icount   = 17-  , irarity  = [(1, 1)]-  , iverbHit = "burn"-  , iweight  = 1-  , iaspects = [AddLight 4]-  , ieffects = [Burn 1]-  , ifeature = [Fragile, toLinger 10, Identified]-  , idesc    = ""-  , ikit     = []-  }-mistAntiSlow = ItemKind-  { isymbol  = '\''-  , iname    = "mist"-  , ifreq    = [("anti-slow mist", 1)]-  , iflavour = zipPlain [BrRed]-  , icount   = 7+  , icount   = 1   , irarity  = [(1, 1)]-  , iverbHit = "propel"+  , iverbHit = "spark"   , iweight  = 1-  , iaspects = []-  , ieffects = [DropItem COrgan "slow 10" True]-  , ifeature = [ toVelocity 7  -- the slowest that gets anywhere (1 step only)-               , Fragile, Identified ]+  , idamage  = toDmg 0+  , iaspects = [AddShine 4]+  , ieffects = []+  , ifeature = [toLinger 5, Fragile, Identified]  -- 1 step, 1 turn   , idesc    = ""   , ikit     = []   }-mistAntidote = ItemKind-  { isymbol  = '\''-  , iname    = "mist"-  , ifreq    = [("antidote mist", 1)]-  , iflavour = zipPlain [BrBlue]-  , icount   = 8+spark = ItemKind+  { isymbol  = '`'+  , iname    = "spark"+  , ifreq    = [("spark", 1)]+  , iflavour = zipPlain [BrYellow]+  , icount   = 16   , irarity  = [(1, 1)]-  , iverbHit = "cure"+  , iverbHit = "scorch"   , iweight  = 1-  , iaspects = []-  , ieffects = [DropItem COrgan "poisoned" True]-  , ifeature = [ toVelocity 7  -- the slowest that gets anywhere (1 step only)-               , Fragile, Identified ]+  , idamage  = toDmg 0+  , iaspects = [AddShine 4]+  , ieffects = [Burn 1]+  , ifeature = [toLinger 10, Fragile, Identified]  -- 2 steps, 1 turn   , idesc    = ""   , ikit     = []   } --- * Assorted temporary condition blasts+-- * Temporary condition blasts strictly matching the aspects -mistStrength = ItemKind-  { isymbol  = '\''-  , iname    = "mist"-  , ifreq    = [("strength mist", 1)]+-- Almost all have @toLinger 10@, that travels 2 steps in 1 turn.+-- These are very fast projectiles, not getting into the way of big+-- actors and not burdening the engine for long.++denseShower = ItemKind+  { isymbol  = '`'+  , iname    = "dense shower"+  , ifreq    = [("dense shower", 1)]   , iflavour = zipFancy [Red]-  , icount   = 6+  , icount   = 16   , irarity  = [(1, 1)]   , iverbHit = "strengthen"   , iweight  = 1+  , idamage  = toDmg 0   , iaspects = []   , ieffects = [toOrganActorTurn "strengthened" (3 + d 3)]-  , ifeature = [ toVelocity 7  -- the slowest that gets anywhere (1 step only)-               , Fragile, Identified ]+  , ifeature = [toLinger 10, Fragile, Identified]   , idesc    = ""   , ikit     = []   }-mistWeakness = ItemKind-  { isymbol  = '\''-  , iname    = "mist"-  , ifreq    = [("weakness mist", 1)]+sparseShower = ItemKind+  { isymbol  = '`'+  , iname    = "sparse shower"+  , ifreq    = [("sparse shower", 1)]   , iflavour = zipFancy [Blue]-  , icount   = 5+  , icount   = 16   , irarity  = [(1, 1)]   , iverbHit = "weaken"   , iweight  = 1+  , idamage  = toDmg 0   , iaspects = []   , ieffects = [toOrganGameTurn "weakened" (3 + d 3)]-  , ifeature = [ toVelocity 7  -- the slowest that gets anywhere (1 step only)-               , Fragile, Identified ]+  , ifeature = [toLinger 10, Fragile, Identified]   , idesc    = ""   , ikit     = []   }-protectingBalm = ItemKind-  { isymbol  = '\''+protectingBalmMelee = ItemKind+  { isymbol  = '`'   , iname    = "balm droplet"-  , ifreq    = [("protecting balm", 1)]+  , ifreq    = [("melee protective balm", 1)]   , iflavour = zipPlain [Brown]-  , icount   = 13+  , icount   = 16   , irarity  = [(1, 1)]   , iverbHit = "balm"   , iweight  = 1+  , idamage  = toDmg 0   , iaspects = []-  , ieffects = [toOrganActorTurn "protected" (3 + d 3)]-  , ifeature = [ toVelocity 13  -- the slowest that travels at least 2 steps-               , Fragile, Identified ]+  , ieffects = [toOrganActorTurn "protected from melee" (3 + d 3)]+  , ifeature = [toLinger 10, Fragile, Identified]   , idesc    = ""   , ikit     = []   }+protectingBalmRanged = ItemKind+  { isymbol  = '`'+  , iname    = "balm droplet"+  , ifreq    = [("ranged protective balm", 1)]+  , iflavour = zipPlain [BrYellow]+  , icount   = 16+  , irarity  = [(1, 1)]+  , iverbHit = "balm"+  , iweight  = 1+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = [toOrganActorTurn "protected from ranged" (3 + d 3)]+  , ifeature = [toLinger 10, Fragile, Identified]+  , idesc    = ""+  , ikit     = []+  } vulnerabilityBalm = ItemKind-  { isymbol  = '\''+  { isymbol  = '?'   , iname    = "PhD defense question"   , ifreq    = [("PhD defense question", 1)]   , iflavour = zipPlain [BrRed]-  , icount   = 14+  , icount   = 16   , irarity  = [(1, 1)]   , iverbHit = "nag"   , iweight  = 1+  , idamage  = toDmg 0   , iaspects = []   , ieffects = [toOrganGameTurn "defenseless" (3 + d 3)]-  , ifeature = [ toVelocity 13  -- the slowest that travels at least 2 steps-               , Fragile, Identified ]+  , ifeature = [toLinger 10, Fragile, Identified]   , idesc    = ""   , ikit     = []   }+resolutionDust = ItemKind+  { isymbol  = '`'+  , iname    = "resolution dust"+  , ifreq    = [("resolution dust", 1)]+  , iflavour = zipPlain [Brown]+  , icount   = 16+  , irarity  = [(1, 1)]+  , iverbHit = "calm"+  , iweight  = 1+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = [toOrganActorTurn "resolute" (3 + d 3)]+  , ifeature = [toLinger 10, Fragile, Identified]+  , idesc    = ""+  , ikit     = []+  } hasteSpray = ItemKind-  { isymbol  = '\''+  { isymbol  = '`'   , iname    = "haste spray"   , ifreq    = [("haste spray", 1)]   , iflavour = zipPlain [BrRed]-  , icount   = 15+  , icount   = 16   , irarity  = [(1, 1)]   , iverbHit = "haste"   , iweight  = 1+  , idamage  = toDmg 0   , iaspects = []-  , ieffects = [toOrganActorTurn "fast 20" (3 + d 3)]-  , ifeature = [ toVelocity 13  -- the slowest that travels at least 2 steps-               , Fragile, Identified ]+  , ieffects = [toOrganActorTurn "hasted" (3 + d 3)]+  , ifeature = [toLinger 10, Fragile, Identified]   , idesc    = ""   , ikit     = []   }-slownessSpray = ItemKind-  { isymbol  = '\''-  , iname    = "slowness spray"-  , ifreq    = [("slowness spray", 1)]+slownessMist = ItemKind+  { isymbol  = '`'+  , iname    = "slowness mist"+  , ifreq    = [("slowness mist", 1)]   , iflavour = zipPlain [BrBlue]-  , icount   = 16+  , icount   = 8   , irarity  = [(1, 1)]   , iverbHit = "slow"   , iweight  = 1+  , idamage  = toDmg 0   , iaspects = []-  , ieffects = [toOrganGameTurn "slow 10" (3 + d 3)]-  , ifeature = [ toVelocity 13  -- the slowest that travels at least 2 steps-               , Fragile, Identified ]+  , ieffects = [toOrganGameTurn "slowed" (3 + d 3)]+  , ifeature = [toVelocity 5, Fragile, Identified]  -- 1 step, 1 turn, mist   , idesc    = ""   , ikit     = []   } eyeDrop = ItemKind-  { isymbol  = '\''+  { isymbol  = '`'   , iname    = "eye drop"   , ifreq    = [("eye drop", 1)]   , iflavour = zipPlain [BrGreen]-  , icount   = 17+  , icount   = 16   , irarity  = [(1, 1)]   , iverbHit = "cleanse"   , iweight  = 1+  , idamage  = toDmg 0   , iaspects = []   , ieffects = [toOrganActorTurn "far-sighted" (3 + d 3)]-  , ifeature = [ toVelocity 13  -- the slowest that travels at least 2 steps-               , Fragile, Identified ]+  , ifeature = [toLinger 10, Fragile, Identified]   , idesc    = ""   , ikit     = []   }+ironFiling = ItemKind+  { isymbol  = '`'+  , iname    = "iron filing"+  , ifreq    = [("iron filing", 1)]+  , iflavour = zipPlain [Brown]+  , icount   = 16+  , irarity  = [(1, 1)]+  , iverbHit = "blind"+  , iweight  = 1+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = [toOrganActorTurn "blind" (10 + d 10)]+  , ifeature = [toLinger 10, Fragile, Identified]+  , idesc    = ""+  , ikit     = []+  } smellyDroplet = ItemKind-  { isymbol  = '\''+  { isymbol  = '`'   , iname    = "smelly droplet"   , ifreq    = [("smelly droplet", 1)]   , iflavour = zipPlain [Blue]-  , icount   = 18+  , icount   = 16   , irarity  = [(1, 1)]   , iverbHit = "sensitize"   , iweight  = 1+  , idamage  = toDmg 0   , iaspects = []   , ieffects = [toOrganActorTurn "keen-smelling" (3 + d 3)]-  , ifeature = [ toVelocity 13  -- the slowest that travels at least 2 steps-               , Fragile, Identified ]+  , ifeature = [toLinger 10, Fragile, Identified]   , idesc    = ""   , ikit     = []   }+eyeShine = ItemKind+  { isymbol  = '`'+  , iname    = "eye shine"+  , ifreq    = [("eye shine", 1)]+  , iflavour = zipPlain [BrRed]+  , icount   = 16+  , irarity  = [(1, 1)]+  , iverbHit = "smear"+  , iweight  = 1+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = [toOrganActorTurn "shiny-eyed" (3 + d 3)]+  , ifeature = [toLinger 10, Fragile, Identified]+  , idesc    = ""+  , ikit     = []+  }++-- * Assorted temporary condition blasts or related (also, matching flasks)+ whiskeySpray = ItemKind-  { isymbol  = '\''+  { isymbol  = '`'   , iname    = "whiskey spray"   , ifreq    = [("whiskey spray", 1)]   , iflavour = zipPlain [Brown]-  , icount   = 19+  , icount   = 16   , irarity  = [(1, 1)]   , iverbHit = "inebriate"   , iweight  = 1+  , idamage  = toDmg 0   , iaspects = []   , ieffects = [toOrganActorTurn "drunk" (3 + d 3)]-  , ifeature = [ toVelocity 13  -- the slowest that travels at least 2 steps-               , Fragile, Identified ]+  , ifeature = [toLinger 10, Fragile, Identified]+  , idesc    = ""+  , ikit     = []+  }+waste = ItemKind+  { isymbol  = '*'+  , iname    = "waste"+  , ifreq    = [("waste", 1)]+  , iflavour = zipPlain [Brown]+  , icount   = 16+  , irarity  = [(1, 1)]+  , iverbHit = "splosh"+  , iweight  = 1+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = [Burn (-1)]+  , ifeature = [toLinger 10, Fragile, Identified]+  , idesc    = ""+  , ikit     = []+  }+youthSprinkle = ItemKind+  { isymbol  = '`'+  , iname    = "youth sprinkle"+  , ifreq    = [("youth sprinkle", 1)]+  , iflavour = zipPlain [BrGreen]+  , icount   = 16+  , irarity  = [(1, 1)]+  , iverbHit = "sprinkle"+  , iweight  = 1+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = [toOrganNone "regenerating"]+  , ifeature = [toLinger 10, Fragile, Identified]+  , idesc    = ""+  , ikit     = []+  }+poisonCloud = ItemKind+  { isymbol  = '`'+  , iname    = "poison cloud"+  , ifreq    = [("poison cloud", 1)]+  , iflavour = zipPlain [Green]+  , icount   = 16+  , irarity  = [(1, 1)]+  , iverbHit = "poison"+  , iweight  = 1+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = [toOrganNone "poisoned"]+  , ifeature = [toVelocity 10, Fragile, Identified]  -- 2 steps, 2 turns+  , idesc    = ""+  , ikit     = []+  }+mistAntiSlow = ItemKind+  { isymbol  = '`'+  , iname    = "mist"+  , ifreq    = [("anti-slow mist", 1)]+  , iflavour = zipPlain [BrRed]+  , icount   = 8+  , irarity  = [(1, 1)]+  , iverbHit = "propel"+  , iweight  = 1+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = [DropItem 1 1 COrgan "slowed"]+  , ifeature = [toVelocity 5, Fragile, Identified]  -- 1 step, 1 turn+  , idesc    = ""+  , ikit     = []+  }+mistAntidote = ItemKind+  { isymbol  = '`'+  , iname    = "mist"+  , ifreq    = [("antidote mist", 1)]+  , iflavour = zipPlain [BrBlue]+  , icount   = 8+  , irarity  = [(1, 1)]+  , iverbHit = "cure"+  , iweight  = 1+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = [DropItem 1 maxBound COrgan "poisoned"]+  , ifeature = [toVelocity 5, Fragile, Identified]  -- 1 step, 1 turn   , idesc    = ""   , ikit     = []   }

+ GameDefinition/Content/ItemKindEmbed.hs view

@@ -0,0 +1,275 @@+-- | Definitions of items embedded in map tiles.+module Content.ItemKindEmbed+  ( embeds+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Game.LambdaHack.Common.Color+import Game.LambdaHack.Common.Dice+import Game.LambdaHack.Common.Flavour+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Content.ItemKind++embeds :: [ItemKind]+embeds =+  [stairsUp, stairsDown, escape, terrainCache, terrainCacheTrap, signboardExit, signboardMap, fireSmall, fireBig, frost, rubble, staircaseTrapUp, staircaseTrapDown, doorwayTrap, obscenePictograms, subtleFresco, scratchOnWall, pulpit]++stairsUp,    stairsDown, escape, terrainCache, terrainCacheTrap, signboardExit, signboardMap, fireSmall, fireBig, frost, rubble, staircaseTrapUp, staircaseTrapDown, doorwayTrap, obscenePictograms, subtleFresco, scratchOnWall, pulpit :: ItemKind++stairsUp = ItemKind+  { isymbol  = '<'+  , iname    = "staircase up"+  , ifreq    = [("staircase up", 1)]+  , iflavour = zipPlain [BrWhite]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "crash"+  , iweight  = 100000+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = [Ascend True]+  , ifeature = [Identified, Durable]+  , idesc    = ""+  , ikit     = []+  }+stairsDown = stairsUp+  { isymbol  = '>'+  , iname    = "staircase down"+  , ifreq    = [("staircase down", 1)]+  , ieffects = [Ascend False]+  }+escape = stairsUp+  { iname    = "escape"+  , ifreq    = [("escape", 1)]+  , iflavour = zipPlain [BrYellow]+  , ieffects = [Escape]+  }+terrainCache = stairsUp+  { isymbol  = 'O'+  , iname    = "treasure cache"+  , ifreq    = [("terrain cache", 1)]+  , iflavour = zipPlain [BrYellow]+  , ieffects = [CreateItem CGround "useful" TimerNone]+  }+terrainCacheTrap = ItemKind+  { isymbol  = '^'+  , iname    = "treasure cache trap"+  , ifreq    = [("terrain cache trap", 1)]+  , iflavour = zipPlain [BrRed]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "trap"+  , iweight  = 1000+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = [OneOf [ toOrganNone "poisoned", Explode "glue"+                      , ELabel "", ELabel "", ELabel ""+                      , ELabel "", ELabel "", ELabel ""+                      , ELabel "", ELabel "" ]]+  , ifeature = [Identified]  -- not Durable, springs at most once+  , idesc    = ""+  , ikit     = []+  }+signboardExit = ItemKind+  { isymbol  = 'O'+  , iname    = "signboard with exits"+  , ifreq    = [("signboard", 80)]+  , iflavour = zipPlain [BrMagenta]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "whack"+  , iweight  = 10000+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = [DetectExit 100]+  , ifeature = [Identified, Durable]+  , idesc    = ""+  , ikit     = []+  }+signboardMap = signboardExit+  { iname    = "signboard with map"+  , ifreq    = [("signboard", 20)]+  , ieffects = [Detect 10]+  }+fireSmall = ItemKind+  { isymbol  = '&'+  , iname    = "small fire"+  , ifreq    = [("small fire", 1)]+  , iflavour = zipPlain [BrRed]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "burn"+  , iweight  = 10000+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = [Burn 1, Explode "single spark"]+  , ifeature = [Identified, Durable]+  , idesc    = ""+  , ikit     = []+  }+fireBig = fireSmall+  { isymbol  = 'O'+  , iname    = "big fire"+  , ifreq    = [("big fire", 1)]+  , ieffects = [ Burn 2, Explode "spark"+               , CreateItem CGround "wooden torch" TimerNone ]+  , ifeature = [Identified, Durable]+  , idesc    = ""+  , ikit     = []+  }+frost = ItemKind+  { isymbol  = '%'+  , iname    = "frost"+  , ifreq    = [("frost", 1)]+  , iflavour = zipPlain [BrBlue]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "burn"+  , iweight  = 10000+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = [ Burn 1  -- sensory ambiguity between hot and cold+               , RefillCalm 20  -- cold reason+               , PushActor (ThrowMod 200 50) ]  -- slippery ice+  , ifeature = [Identified, Durable]+  , idesc    = ""+  , ikit     = []+  }+rubble = ItemKind+  { isymbol  = ':'+  , iname    = "rubble"+  , ifreq    = [("rubble", 1)]+  , iflavour = zipPlain [BrWhite]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "bury"+  , iweight  = 100000+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = [OneOf [ Explode "glass piece", Explode "waste"+                      , Summon "animal" 1, toOrganNone "poisoned"+                      , CreateItem CGround "useful" TimerNone+                      , ELabel "", ELabel "", ELabel ""+                      , ELabel "", ELabel "", ELabel "" ]]+  , ifeature = [Identified, Durable]+  , idesc    = ""+  , ikit     = []+  }+staircaseTrapUp = ItemKind+  { isymbol  = '^'+  , iname    = "staircase trap"+  , ifreq    = [("staircase trap up", 1)]+  , iflavour = zipPlain [BrRed]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "taint"+  , iweight  = 10000+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = [Temporary "be caught in an updraft", Teleport 20]+  , ifeature = [Identified]  -- not Durable, springs at most once+  , idesc    = ""+  , ikit     = []+  }+-- Needs to be separate from staircaseTrapUp, to make sure the item is+-- registered after up staircase (not only after down staircase)+-- so that effects are invoked in the proper order and, e.g., teleport works.+staircaseTrapDown = staircaseTrapUp+  { ifreq    = [("staircase trap down", 1)]+  , ieffects = [ Temporary "tumble down the stairwell"+               , toOrganActorTurn "drunk" (20 + d 5) ]+  }+doorwayTrap = ItemKind+  { isymbol  = '^'+  , iname    = "doorway trap"+  , ifreq    = [("doorway trap", 1)]+  , iflavour = zipPlain [BrRed]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "trap"+  , iweight  = 10000+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = [OneOf [ RefillCalm (-20)+                      , toOrganActorTurn "slowed" (20 + d 5)+                      , toOrganActorTurn "weakened" (20 + d 5) ]]+  , ifeature = [Identified]  -- not Durable, springs at most once+  , idesc    = ""+  , ikit     = []+  }+obscenePictograms = ItemKind+  { isymbol  = '*'+  , iname    = "obscene pictograms"+  , ifreq    = [("obscene pictograms", 1)]+  , iflavour = zipPlain [BrRed]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "infuriate"+  , iweight  = 1000+  , idamage  = toDmg 0+  , iaspects = [Timeout 7]+  , ieffects = [ Temporary "enter destructive rage at the sight of obscene pictograms"+               , RefillCalm (-20)+               , Recharging $ OneOf+                   [ toOrganActorTurn "strengthened" (3 + d 3)+                   , CreateItem CInv "sandstone rock" TimerNone ] ]+  , ifeature = [Identified, Durable]+  , idesc    = ""+  , ikit     = []+  }+subtleFresco = ItemKind+  { isymbol  = '*'+  , iname    = "subtle fresco"+  , ifreq    = [("subtle fresco", 1)]+  , iflavour = zipPlain [BrGreen]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = ""+  , iweight  = 1000+  , idamage  = toDmg 0+  , iaspects = [Timeout 7]+  , ieffects = [ Temporary "feel refreshed by the subtle fresco"+               , RefillCalm 2+               , Recharging $ toOrganActorTurn "far-sighted" (3 + d 3)+               , Recharging $ toOrganActorTurn "keen-smelling" (3 + d 3) ]+  , ifeature = [Identified, Durable]+  , idesc    = ""+  , ikit     = []+  }+scratchOnWall = ItemKind+  { isymbol  = '*'+  , iname    = "scratch on wall"+  , ifreq    = [("scratch on wall", 1)]+  , iflavour = zipPlain [BrBlue]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "scratch"+  , iweight  = 1000+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = [Temporary "start making sense of the scratches", DetectHidden 3]+  , ifeature = [Identified, Durable]+  , idesc    = ""+  , ikit     = []+  }+pulpit = ItemKind+  { isymbol  = 'O'+  , iname    = "pulpit"+  , ifreq    = [("pulpit", 1)]+  , iflavour = zipFancy [BrBlue]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "ask"+  , iweight  = 10000+  , idamage  = toDmg 0+  , iaspects = []+  , ieffects = [ CreateItem CGround "any scroll" TimerNone+               , toOrganGameTurn "defenseless" (20 + d 5)+               , Explode "PhD defense question" ]+  , ifeature = [Identified]  -- not Durable, springs at most once+  , idesc    = ""+  , ikit     = []+  }

GameDefinition/Content/ItemKindOrgan.hs view

@@ -1,21 +1,28 @@ -- | Organ definitions.-module Content.ItemKindOrgan ( organs ) where+module Content.ItemKindOrgan+  ( organs+  ) where -import qualified Data.EnumMap.Strict as EM+import Prelude () +import Game.LambdaHack.Common.Prelude+ import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Dice import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg import Game.LambdaHack.Content.ItemKind  organs :: [ItemKind] organs =-  [fist, foot, claw, smallClaw, snout, smallJaw, jaw, largeJaw, tooth, horn, tentacle, lash, noseTip, lip, torsionRight, torsionLeft, thorn, boilingFissure, arsenicFissure, sulfurFissure, beeSting, sting, venomTooth, venomFang, screechingBeak, largeTail, pupil, armoredSkin, eye2, eye3, eye4, eye5, eye6, eye7, eye8, vision4, vision6, vision8, vision10, vision12, vision14, vision16, nostril, insectMortality, sapientBrain, animalBrain, speedGland2, speedGland4, speedGland6, speedGland8, speedGland10, scentGland, boilingVent, arsenicVent, sulfurVent, bonusHP]+  [fist, foot, hookedClaw, smallClaw, snout, smallJaw, jaw, largeJaw, horn, tentacle, thorn, boilingFissure, arsenicFissure, sulfurFissure, beeSting, sting, venomTooth, venomFang, screechingBeak, largeTail, armoredSkin, eye2, eye3, eye4, eye5, eye6, eye7, eye8, vision4, vision5, vision6, vision7, vision8, vision10, vision12, vision14, vision16, nostril, insectMortality, sapientBrain, animalBrain, speedGland2, speedGland4, speedGland6, speedGland8, speedGland10, scentGland, boilingVent, arsenicVent, sulfurVent, bonusHP]+  -- LH-specific+  ++ [tooth, lash, noseTip, lip, torsionRight, torsionLeft, pupil] -fist,    foot, claw, smallClaw, snout, smallJaw, jaw, largeJaw, tooth, horn, tentacle, lash, noseTip, lip, torsionRight, torsionLeft, thorn, boilingFissure, arsenicFissure, sulfurFissure, beeSting, sting, venomTooth, venomFang, screechingBeak, largeTail, pupil, armoredSkin, eye2, eye3, eye4, eye5, eye6, eye7, eye8, vision4, vision6, vision8, vision10, vision12, vision14, vision16, nostril, insectMortality, sapientBrain, animalBrain, speedGland2, speedGland4, speedGland6, speedGland8, speedGland10, scentGland, boilingVent, arsenicVent, sulfurVent, bonusHP :: ItemKind+fist,    foot, hookedClaw, smallClaw, snout, smallJaw, jaw, largeJaw, horn, tentacle, thorn, boilingFissure, arsenicFissure, sulfurFissure, beeSting, sting, venomTooth, venomFang, screechingBeak, largeTail, armoredSkin, eye2, eye3, eye4, eye5, eye6, eye7, eye8, vision4, vision5, vision6, vision7, vision8, vision10, vision12, vision14, vision16, nostril, insectMortality, sapientBrain, animalBrain, speedGland2, speedGland4, speedGland6, speedGland8, speedGland10, scentGland, boilingVent, arsenicVent, sulfurVent, bonusHP :: ItemKind+-- LH-specific+tooth, lash, noseTip, lip, torsionRight, torsionLeft, pupil :: ItemKind  -- Weapons @@ -30,45 +37,46 @@   , irarity  = [(1, 1)]   , iverbHit = "punch"   , iweight  = 2000+  , idamage  = toDmg $ 4 * d 1   , iaspects = []-  , ieffects = [Hurt (4 * d 1)]-  , ifeature = [Durable, Identified]+  , ieffects = []+  , ifeature = [Durable, Identified, Meleeable]   , idesc    = ""   , ikit     = []   } foot = fist   { iname    = "foot"   , ifreq    = [("foot", 50)]-  , icount   = 2   , iverbHit = "kick"-  , ieffects = [Hurt (4 * d 1)]+  , idamage  = toDmg $ 4 * d 1   , idesc    = ""   }  -- * Universal weapon organs -claw = fist-  { iname    = "claw"-  , ifreq    = [("claw", 50)]+hookedClaw = fist+  { iname    = "hooked claw"+  , ifreq    = [("hooked claw", 50)]   , icount   = 2  -- even if more, only the fore claws used for fighting   , iverbHit = "hook"+  , idamage  = toDmg $ 2 * d 1   , iaspects = [Timeout $ 4 + d 4]-  , ieffects = [Hurt (2 * d 1), Recharging (toOrganGameTurn "slow 10" 2)]+  , ieffects = [Recharging (toOrganGameTurn "slowed" 2)]   , idesc    = ""   } smallClaw = fist   { iname    = "small claw"   , ifreq    = [("small claw", 50)]-  , icount   = 2   , iverbHit = "slash"-  , ieffects = [Hurt (2 * d 1)]+  , idamage  = toDmg $ 2 * d 1   , idesc    = ""   } snout = fist   { iname    = "snout"   , ifreq    = [("snout", 10)]+  , icount   = 1   , iverbHit = "bite"-  , ieffects = [Hurt (2 * d 1)]+  , idamage  = toDmg $ 2 * d 1   , idesc    = ""   } smallJaw = fist@@ -76,7 +84,7 @@   , ifreq    = [("small jaw", 20)]   , icount   = 1   , iverbHit = "rip"-  , ieffects = [Hurt (3 * d 1)]+  , idamage  = toDmg $ 3 * d 1   , idesc    = ""   } jaw = fist@@ -84,7 +92,7 @@   , ifreq    = [("jaw", 20)]   , icount   = 1   , iverbHit = "rip"-  , ieffects = [Hurt (5 * d 1)]+  , idamage  = toDmg $ 5 * d 1   , idesc    = ""   } largeJaw = fist@@ -92,15 +100,7 @@   , ifreq    = [("large jaw", 100)]   , icount   = 1   , iverbHit = "crush"-  , ieffects = [Hurt (12 * d 1)]-  , idesc    = ""-  }-tooth = fist-  { iname    = "tooth"-  , ifreq    = [("tooth", 20)]-  , icount   = 3-  , iverbHit = "nail"-  , ieffects = [Hurt (2 * d 1)]+  , idamage  = toDmg $ 10 * d 1   , idesc    = ""   } horn = fist@@ -108,77 +108,29 @@   , ifreq    = [("horn", 20)]   , icount   = 2   , iverbHit = "impale"-  , ieffects = [Hurt (8 * d 1)]+  , idamage  = toDmg $ 6 * d 1+  , iaspects = [AddHurtMelee 20]   , idesc    = ""   } --- * Monster weapon organs+-- * Special weapon organs  tentacle = fist   { iname    = "tentacle"   , ifreq    = [("tentacle", 50)]   , icount   = 4   , iverbHit = "slap"-  , ieffects = [Hurt (4 * d 1)]-  , idesc    = ""-  }-lash = fist-  { iname    = "lash"-  , ifreq    = [("lash", 100)]-  , icount   = 1-  , iverbHit = "lash"-  , iaspects = []-  , ieffects = [Hurt (3 * d 1)]-  , idesc    = ""-  }-noseTip = fist-  { iname    = "tip"-  , ifreq    = [("nose tip", 50)]-  , icount   = 1-  , iverbHit = "poke"-  , ieffects = [Hurt (2 * d 1)]-  , idesc    = ""-  }-lip = fist-  { iname    = "lip"-  , ifreq    = [("lip", 10)]-  , icount   = 1-  , iverbHit = "lap"-  , iaspects = [Timeout $ 3 + d 3]-  , ieffects = [ Hurt (1 * d 1)-               , Recharging (toOrganGameTurn "weakened" (2 + d 2)) ]-  , idesc    = ""-  }-torsionRight = fist-  { iname    = "right torsion"-  , ifreq    = [("right torsion", 100)]-  , icount   = 1-  , iverbHit = "twist"-  , iaspects = [Timeout $ 5 + d 5]-  , ieffects = [ Hurt (17 * d 1)-               , Recharging (toOrganGameTurn "slow 10" (3 + d 3)) ]-  , idesc    = ""-  }-torsionLeft = fist-  { iname    = "left torsion"-  , ifreq    = [("left torsion", 100)]-  , icount   = 1-  , iverbHit = "twist"-  , iaspects = [Timeout $ 5 + d 5]-  , ieffects = [ Hurt (17 * d 1)-               , Recharging (toOrganGameTurn "weakened" (3 + d 3)) ]+  , idamage  = toDmg $ 4 * d 1   , idesc    = ""   }---- * Special weapon organs- thorn = fist   { iname    = "thorn"   , ifreq    = [("thorn", 100)]   , icount   = 2 + d 3   , iverbHit = "impale"-  , ieffects = [Hurt (2 * d 1)]-  , ifeature = [Identified]  -- not Durable+  , idamage  = toDmg $ 1 * d 1+  , ieffects = [RefillHP (-2)]+  , ifeature = [Identified, Meleeable]  -- not Durable   , idesc    = ""   } boilingFissure = fist@@ -186,30 +138,34 @@   , ifreq    = [("boiling fissure", 100)]   , icount   = 5 + d 5   , iverbHit = "hiss at"-  , ieffects = [Burn $ 1 * d 1]-  , ifeature = [Identified]  -- not Durable+  , idamage  = toDmg $ 1 * d 1+  , iaspects = [AddHurtMelee 20]+  , ieffects = [InsertMove $ 1 * d 3]+  , ifeature = [Identified, Meleeable]  -- not Durable   , idesc    = ""   } arsenicFissure = boilingFissure   { iname    = "fissure"   , ifreq    = [("arsenic fissure", 100)]-  , icount   = 2 + d 2-  , ieffects = [Burn $ 1 * d 1, toOrganGameTurn "weakened" (2 + d 2)]+  , icount   = 3 + d 3+  , idamage  = toDmg $ 2 * d 1+  , ieffects = [toOrganGameTurn "weakened" (2 + d 2)]   } sulfurFissure = boilingFissure   { iname    = "fissure"   , ifreq    = [("sulfur fissure", 100)]   , icount   = 2 + d 2-  , ieffects = [Burn $ 1 * d 1, RefillHP 6]+  , ieffects = [RefillHP 6]   } beeSting = fist   { iname    = "bee sting"   , ifreq    = [("bee sting", 100)]   , icount   = 1   , iverbHit = "sting"-  , iaspects = [AddArmorMelee 90, AddArmorRanged 90]-  , ieffects = [Burn $ 2 * d 1, Paralyze 3, RefillHP 5]-  , ifeature = [Identified]  -- not Durable+  , idamage  = toDmg $ 1 * d 1+  , iaspects = [AddArmorMelee 90, AddArmorRanged 45]+  , ieffects = [Paralyze 6, RefillHP 5]+  , ifeature = [Identified, Meleeable]  -- not Durable   , idesc    = "Painful, but beneficial."   } sting = fist@@ -217,8 +173,9 @@   , ifreq    = [("sting", 100)]   , icount   = 1   , iverbHit = "sting"-  , iaspects = [Timeout $ 1 + d 5]-  , ieffects = [Burn $ 2 * d 1, Recharging (Paralyze 2)]+  , idamage  = toDmg $ 1 * d 1+  , iaspects = [Timeout $ 1 + d 5, AddHurtMelee 40]+  , ieffects = [Recharging (Paralyze 4)]   , idesc    = "Painful, debilitating and harmful."   } venomTooth = fist@@ -226,31 +183,29 @@   , ifreq    = [("venom tooth", 100)]   , icount   = 2   , iverbHit = "bite"+  , idamage  = toDmg $ 2 * d 1   , iaspects = [Timeout $ 5 + d 3]-  , ieffects = [ Hurt (2 * d 1)-               , Recharging (toOrganGameTurn "slow 10" (3 + d 3)) ]+  , ieffects = [Recharging (toOrganGameTurn "slowed" (3 + d 3))]   , idesc    = ""   }--- TODO: should also confer poison resistance, but current implementation--- is too costly (poison removal each turn) venomFang = fist   { iname    = "venom fang"   , ifreq    = [("venom fang", 100)]   , icount   = 2   , iverbHit = "bite"+  , idamage  = toDmg $ 2 * d 1   , iaspects = [Timeout $ 7 + d 5]-  , ieffects = [ Hurt (2 * d 1)-               , Recharging (toOrganNone "poisoned") ]+  , ieffects = [Recharging (toOrganNone "poisoned")]   , idesc    = ""   }-screechingBeak = armoredSkin+screechingBeak = fist   { iname    = "screeching beak"   , ifreq    = [("screeching beak", 100)]   , icount   = 1   , iverbHit = "peck"+  , idamage  = toDmg $ 2 * d 1   , iaspects = [Timeout $ 5 + d 5]-  , ieffects = [ Recharging (Summon [("scavenger", 1)] $ 1 + dl 2)-               , Hurt (2 * d 1) ]+  , ieffects = [Recharging $ Summon "scavenger" $ 1 + dl 2]   , idesc    = ""   } largeTail = fist@@ -258,20 +213,9 @@   , ifreq    = [("large tail", 50)]   , icount   = 1   , iverbHit = "knock"-  , iaspects = [Timeout $ 1 + d 3]-  , ieffects = [Hurt (8 * d 1), Recharging (PushActor (ThrowMod 400 25))]-  , idesc    = ""-  }-pupil = fist-  { iname    = "pupil"-  , ifreq    = [("pupil", 100)]-  , icount   = 1-  , iverbHit = "gaze at"-  , iaspects = [AddSight 10, Timeout $ 5 + d 5]-  , ieffects = [ Hurt (1 * d 1)-               , Recharging (DropItem COrgan "temporary conditions" True)-               , Recharging $ RefillHP (-2)-               ]+  , idamage  = toDmg $ 6 * d 1+  , iaspects = [Timeout $ 1 + d 3, AddHurtMelee 20]+  , ieffects = [Recharging (PushActor (ThrowMod 400 25))]   , idesc    = ""   } @@ -288,7 +232,8 @@   , irarity  = [(1, 1)]   , iverbHit = "bash"   , iweight  = 2000-  , iaspects = [AddArmorMelee 30, AddArmorRanged 30]+  , idamage  = toDmg 0+  , iaspects = [AddArmorMelee 30, AddArmorRanged 15]   , ieffects = []   , ifeature = [Durable, Identified]   , idesc    = ""@@ -317,13 +262,14 @@ vision n = armoredSkin   { iname    = "vision"   , ifreq    = [(toGroupName $ "vision" <+> tshow n, 100)]-  , icount   = 1   , iverbHit = "visualize"   , iaspects = [AddSight (intToDice n)]   , idesc    = ""   } vision4 = vision 4+vision5 = vision 5 vision6 = vision 6+vision7 = vision 7 vision8 = vision 8 vision10 = vision 10 vision12 = vision 12@@ -340,43 +286,40 @@  -- * Assorted -insectMortality = fist+insectMortality = armoredSkin   { iname    = "insect mortality"   , ifreq    = [("insect mortality", 100)]-  , icount   = 1   , iverbHit = "age"-  , iaspects = [Periodic, Timeout $ 40 + d 10]-  , ieffects = [Recharging (RefillHP (-1))]+  , iaspects = [Timeout $ 40 + d 10]+  , ieffects = [Periodic, Recharging (RefillHP (-1))]   , idesc    = ""   } sapientBrain = armoredSkin   { iname    = "sapient brain"   , ifreq    = [("sapient brain", 100)]-  , icount   = 1   , iverbHit = "outbrain"-  , iaspects = [AddSkills unitSkills]+  , iaspects = [AddAbility ab 1 | ab <- [minBound..maxBound]]+               ++ [AddAbility AbAlter 2]  -- can use stairs   , idesc    = ""   } animalBrain = armoredSkin   { iname    = "animal brain"   , ifreq    = [("animal brain", 100)]-  , icount   = 1   , iverbHit = "blank"-  , iaspects = [let absNo = [AbDisplace, AbMoveItem, AbProject, AbApply]-                    sk = EM.fromList $ zip absNo [-1, -1..]-                in AddSkills $ addSkills unitSkills sk]+  , iaspects = [AddAbility ab 1 | ab <- [minBound..maxBound]]+               ++ [AddAbility AbAlter 2]  -- can use stairs+               ++ [ AddAbility ab (-1)+                  | ab <- [AbDisplace, AbMoveItem, AbProject, AbApply] ]   , idesc    = ""   } speedGland :: Int -> ItemKind speedGland n = armoredSkin   { iname    = "speed gland"   , ifreq    = [(toGroupName $ "speed gland" <+> tshow n, 100)]-  , icount   = 1   , iverbHit = "spit at"   , iaspects = [ AddSpeed $ intToDice n-               , Periodic                , Timeout $ intToDice $ 100 `div` n ]-  , ieffects = [Recharging (RefillHP 1)]+  , ieffects = [Periodic, Recharging (RefillHP 1)]   , idesc    = ""   } speedGland2 = speedGland 2@@ -384,13 +327,12 @@ speedGland6 = speedGland 6 speedGland8 = speedGland 8 speedGland10 = speedGland 10-scentGland = armoredSkin  -- TODO: cone attack, 3m away, project? apply?+scentGland = armoredSkin   { iname    = "scent gland"   , ifreq    = [("scent gland", 100)]-  , icount   = 1   , iverbHit = "spray at"-  , iaspects = [Periodic, Timeout $ 10 + d 2 |*| 5 ]-  , ieffects = [ Recharging (Explode "distressing odor")+  , iaspects = [Timeout $ 10 + d 2 |*| 5 ]+  , ieffects = [ Periodic, Recharging (Explode "distressing odor")                , Recharging ApplyPerfume ]   , idesc    = ""   }@@ -398,32 +340,111 @@   { iname    = "vent"   , ifreq    = [("boiling vent", 100)]   , iflavour = zipPlain [Blue]-  , icount   = 1   , iverbHit = "menace"-  , iaspects = [Periodic, Timeout $ 2 + d 2 |*| 5]-  , ieffects = [Recharging (Explode "boiling water")]+  , iaspects = [Timeout $ 2 + d 2 |*| 5]+  , ieffects = [Periodic+               , Recharging (Explode "boiling water")+               , Recharging (RefillHP 2) ]   , idesc    = ""   }-arsenicVent = boilingVent+arsenicVent = armoredSkin   { iname    = "vent"   , ifreq    = [("arsenic vent", 100)]   , iflavour = zipPlain [Cyan]-  , iaspects = [Periodic, Timeout $ 2 + d 2 |*| 5]-  , ieffects = [Recharging (Explode "weakness mist")]+  , iverbHit = "menace"+  , iaspects = [Timeout $ 2 + d 2 |*| 5]+  , ieffects = [ Periodic+               , Recharging (Explode "sparse shower")+               , Recharging (RefillHP 2) ]+  , idesc    = ""   }-sulfurVent = boilingVent+sulfurVent = armoredSkin   { iname    = "vent"   , ifreq    = [("sulfur vent", 100)]   , iflavour = zipPlain [BrYellow]-  , iaspects = [Periodic, Timeout $ 2 + d 2 |*| 5]-  , ieffects = [Recharging (Explode "strength mist")]+  , iverbHit = "menace"+  , iaspects = [Timeout $ 2 + d 2 |*| 5]+  , ieffects = [ Periodic+               , Recharging (Explode "dense shower")+               , Recharging (RefillHP 2) ]+  , idesc    = ""   } bonusHP = armoredSkin-  { iname    = "bonus HP"-  , ifreq    = [("bonus HP", 100)]-  , icount   = 1+  { isymbol  = '+'+  , iname    = "bonus HP"+  , iflavour = zipPlain [BrBlue]+  , ifreq    = [("bonus HP", 1)]   , iverbHit = "intimidate"-  , iweight  = 0+  , iweight  = 1  -- weight 0 reserved for tmp organs   , iaspects = [AddMaxHP 1]+  , idesc    = ""+  }++-- * LH-specific++tooth = fist+  { iname    = "tooth"+  , ifreq    = [("tooth", 20)]+  , icount   = 3+  , iverbHit = "nail"+  , idamage  = toDmg $ 2 * d 1+  , idesc    = ""+  }+lash = fist+  { iname    = "lash"+  , ifreq    = [("lash", 100)]+  , icount   = 1+  , iverbHit = "lash"+  , idamage  = toDmg $ 3 * d 1+  , idesc    = ""+  }+noseTip = fist+  { iname    = "tip"+  , ifreq    = [("nose tip", 50)]+  , icount   = 1+  , iverbHit = "poke"+  , idamage  = toDmg $ 2 * d 1+  , idesc    = ""+  }+lip = fist+  { iname    = "lip"+  , ifreq    = [("lip", 10)]+  , icount   = 1+  , iverbHit = "lap"+  , idamage  = toDmg $ 1 * d 1+  , iaspects = [Timeout $ 3 + d 3]+  , ieffects = [Recharging (toOrganGameTurn "weakened" (2 + d 2))]+  , idesc    = ""+  }+torsionRight = fist+  { iname    = "right torsion"+  , ifreq    = [("right torsion", 100)]+  , icount   = 1+  , iverbHit = "twist"+  , idamage  = toDmg $ 13 * d 1+  , iaspects = [Timeout $ 5 + d 5, AddHurtMelee 20]+  , ieffects = [Recharging (toOrganGameTurn "slowed" (3 + d 3))]+  , idesc    = ""+  }+torsionLeft = fist+  { iname    = "left torsion"+  , ifreq    = [("left torsion", 100)]+  , icount   = 1+  , iverbHit = "twist"+  , idamage  = toDmg $ 13 * d 1+  , iaspects = [Timeout $ 5 + d 5, AddHurtMelee 20]+  , ieffects = [Recharging (toOrganGameTurn "weakened" (3 + d 3))]+  , idesc    = ""+  }+pupil = fist+  { iname    = "pupil"+  , ifreq    = [("pupil", 100)]+  , icount   = 1+  , iverbHit = "gaze at"+  , idamage  = toDmg $ 1 * d 1+  , iaspects = [AddSight 12, Timeout $ 5 + d 5]+  , ieffects = [ Recharging (DropItem 1 maxBound COrgan "temporary condition")+               , Recharging $ RefillCalm (-10)+               ]   , idesc    = ""   }

GameDefinition/Content/ItemKindTemporary.hs view

@@ -1,75 +1,93 @@ -- | Temporary aspect pseudo-item definitions.-module Content.ItemKindTemporary ( temporaries ) where+module Content.ItemKindTemporary+  ( temporaries+  ) where -import Data.Text (Text)+import Prelude () +import Game.LambdaHack.Common.Prelude+ import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Dice import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg import Game.LambdaHack.Content.ItemKind  temporaries :: [ItemKind] temporaries =-  [tmpStrengthened, tmpWeakened, tmpProtected, tmpVulnerable, tmpFast20, tmpSlow10, tmpFarSighted, tmpKeenSmelling, tmpDrunk, tmpRegenerating, tmpPoisoned, tmpSlow10Resistant, tmpPoisonResistant]+  [tmpStrengthened, tmpWeakened, tmpProtectedMelee, tmpProtectedRanged, tmpVulnerable, tmpResolute, tmpFast20, tmpSlow10, tmpFarSighted, tmpBlind, tmpKeenSmelling, tmpNoctovision, tmpDrunk, tmpRegenerating, tmpPoisoned, tmpSlow10Resistant, tmpPoisonResistant, tmpImpressed] -tmpStrengthened,    tmpWeakened, tmpProtected, tmpVulnerable, tmpFast20, tmpSlow10, tmpFarSighted, tmpKeenSmelling, tmpDrunk, tmpRegenerating, tmpPoisoned, tmpSlow10Resistant, tmpPoisonResistant :: ItemKind+tmpStrengthened,    tmpWeakened, tmpProtectedMelee, tmpProtectedRanged, tmpVulnerable, tmpResolute, tmpFast20, tmpSlow10, tmpFarSighted, tmpBlind, tmpKeenSmelling, tmpNoctovision, tmpDrunk, tmpRegenerating, tmpPoisoned, tmpSlow10Resistant, tmpPoisonResistant, tmpImpressed :: ItemKind +tmpNoLonger :: Text -> Effect+tmpNoLonger name = Temporary $ "be no longer" <+> name+ -- The @name@ is be used in item description, so it should be an adjective -- describing the temporary set of aspects.-tmpAs :: Text -> [Aspect Dice] -> ItemKind+tmpAs :: Text -> [Aspect] -> ItemKind tmpAs name aspects = ItemKind   { isymbol  = '+'   , iname    = name-  , ifreq    = [(toGroupName name, 1), ("temporary conditions", 1)]+  , ifreq    = [(toGroupName name, 1), ("temporary condition", 1)]   , iflavour = zipPlain [BrWhite]   , icount   = 1   , irarity  = [(1, 1)]   , iverbHit = "affect"   , iweight  = 0-  , iaspects = [Periodic, Timeout 0]  -- activates and vanishes soon,-                                      -- depending on initial timer setting-               ++ aspects-  , ieffects = let tmp = Temporary $ "be no longer" <+> name-               in [Recharging tmp, OnSmash tmp]-  , ifeature = [Identified]+  , idamage  = toDmg 0+  , iaspects = -- timeout is 0; activates and vanishes soon,+               -- depending on initial timer setting+               aspects+  , ieffects = [ Periodic+               , Recharging $ tmpNoLonger name+               , OnSmash $ tmpNoLonger name ]+  , ifeature = [Identified, Fragile, Durable]  -- hack: destroy on drop   , idesc    = ""   , ikit     = []   }  tmpStrengthened = tmpAs "strengthened" [AddHurtMelee 20] tmpWeakened = tmpAs "weakened" [AddHurtMelee (-20)]-tmpProtected = tmpAs "protected" [ AddArmorMelee 30-                                 , AddArmorRanged 30 ]-tmpVulnerable = tmpAs "defenseless" [ AddArmorMelee (-30)-                                    , AddArmorRanged (-30) ]-tmpFast20 = tmpAs "fast 20" [AddSpeed 20]-tmpSlow10 = tmpAs "slow 10" [AddSpeed (-10)]+tmpProtectedMelee = tmpAs "protected from melee" [AddArmorMelee 50]+tmpProtectedRanged = tmpAs "protected from ranged" [AddArmorRanged 25]+tmpVulnerable = tmpAs "defenseless" [ AddArmorMelee (-50)+                                    , AddArmorRanged (-25) ]+tmpResolute = tmpAs "resolute" [AddMaxCalm 60]+tmpFast20 = tmpAs "hasted" [AddSpeed 20]+tmpSlow10 = tmpAs "slowed" [AddSpeed (-10)] tmpFarSighted = tmpAs "far-sighted" [AddSight 5]+tmpBlind = tmpAs "blind" [AddSight (-99)] tmpKeenSmelling = tmpAs "keen-smelling" [AddSmell 2]+tmpNoctovision = tmpAs "shiny-eyed" [AddNocto 2] tmpDrunk = tmpAs "drunk" [ AddHurtMelee 30  -- fury                          , AddArmorMelee (-20)                          , AddArmorRanged (-20)-                         , AddSight (-7)+                         , AddSight (-8)                          ] tmpRegenerating =   let tmp = tmpAs "regenerating" []-  in tmp { icount = 7 + d 5+  in tmp { icount = 4 + d 2          , ieffects = Recharging (RefillHP 1) : ieffects tmp          } tmpPoisoned =   let tmp = tmpAs "poisoned" []-  in tmp { icount = 7 + d 5+  in tmp { icount = 4 + d 2          , ieffects = Recharging (RefillHP (-1)) : ieffects tmp          } tmpSlow10Resistant =   let tmp = tmpAs "slow resistant" []-  in tmp { icount = 7 + d 5-         , ieffects = Recharging (DropItem COrgan "slow 10" True) : ieffects tmp+  in tmp { icount = 8 + d 4+         , ieffects = Recharging (DropItem 1 1 COrgan "slowed") : ieffects tmp          } tmpPoisonResistant =   let tmp = tmpAs "poison resistant" []-  in tmp { icount = 7 + d 5-         , ieffects = Recharging (DropItem COrgan "poisoned" True) : ieffects tmp+  in tmp { icount = 8 + d 4+         , ieffects = Recharging (DropItem 1 maxBound COrgan "poisoned")+                      : ieffects tmp+         }+tmpImpressed =+  let tmp = tmpAs "impressed" []+  in tmp { isymbol = '!'+         , ifreq = [("impressed", 1)]  -- no "temporary condition"+         , ieffects = [OnSmash $ tmpNoLonger "impressed"]  -- not @Periodic@          }

GameDefinition/Content/ModeKind.hs view

@@ -1,12 +1,17 @@ -- | Game mode definitions.-module Content.ModeKind ( cdefs ) where+module Content.ModeKind+  ( cdefs+  ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import qualified Data.IntMap.Strict as IM  import Content.ModeKindPlayer import Game.LambdaHack.Common.ContentDef import Game.LambdaHack.Common.Dice-import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.ModeKind  cdefs :: ContentDef ModeKind@@ -16,74 +21,124 @@   , getFreq = mfreq   , validateSingle = validateSingleModeKind   , validateAll = validateAllModeKind-  , content =-      [campaign, raid, skirmish, ambush, battle, battleSurvival, safari, safariSurvival, pvp, coop, defense, screensaver, boardgame]+  , content = contentFromList+      [raid, brawl, shootout, escape, zoo, ambush, exploration, explorationSurvival, safari, safariSurvival, battle, battleSurvival, defense, screensaverRaid, screensaverBrawl, screensaverShootout, screensaverEscape, screensaverZoo, screensaverAmbush, screensaverExploration, screensaverSafari]   }-campaign,        raid, skirmish, ambush, battle, battleSurvival, safari, safariSurvival, pvp, coop, defense, screensaver, boardgame :: ModeKind+raid,        brawl, shootout, escape, zoo, ambush, exploration, explorationSurvival, safari, safariSurvival, battle, battleSurvival, defense, screensaverRaid, screensaverBrawl, screensaverShootout, screensaverEscape, screensaverZoo, screensaverAmbush, screensaverExploration, screensaverSafari :: ModeKind -campaign = ModeKind-  { msymbol = 'c'-  , mname   = "campaign"-  , mfreq   = [("campaign", 1)]-  , mroster = rosterCampaign-  , mcaves  = cavesCampaign-  , mdesc   = "Don't let wanton curiosity, greed and the creeping abstraction madness keep you down there in the darkness for too long!"-  }+-- What other symmetric (two only-one-moves factions) and asymmetric vs crowd+-- scenarios make sense (e.g., are good for a tutorial or for standalone+-- extreme fun or are impossible as part of a crawl)?+-- sparse melee at night: no, shade ambush in brawl is enough+-- dense melee: no, keeping big party together is a chore and big enemy+--   party is less fun than huge enemy party+-- crowd melee in daylight: no, possible in crawl and at night is more fun+-- sparse ranged at night: no, less fun than dense and if no reaction fire,+--   just a camp fest or firing blindly+-- dense ranged in daylight: no, less fun than at night with flares+-- crowd ranged: no, fish in a barel, less predictable and more fun inside+--   crawl, even without reaction fire -raid = ModeKind+raid = ModeKind  -- mini-crawl   { msymbol = 'r'   , mname   = "raid"-  , mfreq   = [("raid", 1)]+  , mfreq   = [("raid", 1), ("campaign scenario", 1)]   , mroster = rosterRaid   , mcaves  = cavesRaid-  , mdesc   = "An incredibly advanced typing machine worth 100 gold is buried at the other end of this maze. Be the first to claim it and fund a research team that will make typing accurate and dependable forever."+  , mdesc   = "An incredibly advanced typing machine worth 100 gold is buried at the exit of this maze. Be the first to find it and fund a research team that makes typing accurate and dependable forever."   } -skirmish = ModeKind+brawl = ModeKind  -- sparse melee in daylight, with shade for melee ambush   { msymbol = 'k'-  , mname   = "skirmish"-  , mfreq   = [("skirmish", 1)]-  , mroster = rosterSkirmish-  , mcaves  = cavesSkirmish-  , mdesc   = "Your type theory research teams disagreed about the premises of a relative completeness theorem and there's only one way to settle that."+  , mname   = "brawl"+  , mfreq   = [("brawl", 1), ("campaign scenario", 1)]+  , mroster = rosterBrawl+  , mcaves  = cavesBrawl+  , mdesc   = "Your engineering team disagrees over a drink with some gentlemen scientists about premises of a relative completeness theorem and there's only one way to settle that. Remember to keep your party together, or the opposing team might be tempted to gang upon a solitary disputant."   } -ambush = ModeKind+-- The trajectory tip is important because of tactics of scout looking from+-- behind a bush and others hiding in mist. If no suitable bushes,+-- fire once and flee into mist or behind cover. Then whomever is out of LOS+-- range or inside mist can shoot at the last seen enemy locations,+-- adjusting and according to ounds and incoming missile trajectories.+-- If the scount can't find bushes or glass building to set a lookout,+-- the other team member are more spotters and guardians than snipers+-- and that's their only role, so a small party makes sense.+shootout = ModeKind  -- sparse ranged in daylight+  { msymbol = 's'+  , mname   = "shootout"+  , mfreq   = [("shootout", 1), ("campaign scenario", 1)]+  , mroster = rosterShootout+  , mcaves  = cavesShootout+  , mdesc   = "Whose arguments are most striking and whose ideas fly fastest? Let's scatter up, attack the problems from different angles and find out. (To display the trajectory of any soaring entity, point it with the crosshair in aiming mode.)"+  }++escape = ModeKind  -- asymmetric ranged and stealth race at night+  { msymbol = 'e'+  , mname   = "escape"+  , mfreq   = [("escape", 1), ("campaign scenario", 1)]+  , mroster = rosterEscape+  , mcaves  = cavesEscape+  , mdesc   = "Dwelling into dark matters is dangerous, so avoid the crowd of firebrand disputants, catch any gems of thought, find a way out and bring back a larger team to shed new light on the field."+  }++zoo = ModeKind  -- asymmetric crowd melee at night+  { msymbol = 'b'+  , mname   = "zoo"+  , mfreq   = [("zoo", 1), ("campaign scenario", 1)]+  , mroster = rosterZoo+  , mcaves  = cavesZoo+  , mdesc   = "The heat of the dispute reaches the nearby Wonders of Science and Nature exhibition, igniting greenery, nets and cages. Crazed animals must be prevented from ruining precious scientific equipment and setting back the otherwise fruitful exchange of ideas."+  }++-- The tactic is to sneak in the dark, highlight enemy with thrown torches+-- (and douse thrown enemy torches with blankets) and only if this fails,+-- actually scout using extended noctovision.+-- With reaction fire, larger team is more fun.+--+-- For now, while we have no shooters with timeout, massive ranged battles+-- without reaction fire don't make sense, because then usually only one hero+-- shoots (and often also scouts) and others just gather ammo.+ambush = ModeKind  -- dense ranged with reaction fire at night   { msymbol = 'm'   , mname   = "ambush"-  , mfreq   = [("ambush", 1)]+  , mfreq   = [("ambush", 1), ("campaign scenario", 1)]   , mroster = rosterAmbush   , mcaves  = cavesAmbush-  , mdesc   = "Surprising, striking ideas and fast execution are what makes or breaks a creative team!"-  }--battle = ModeKind-  { msymbol = 'b'-  , mname   = "battle"-  , mfreq   = [("battle", 1)]-  , mroster = rosterBattle-  , mcaves  = cavesBattle-  , mdesc   = "Odds are stacked against those that unleash the horrors of abstraction."+  , mdesc   = "Prevent hijacking of your ideas at all cost! Be stealthy, be aggressive. Fast execution is what makes or breaks a creative team."   } -battleSurvival = ModeKind-  { msymbol = 'i'-  , mname   = "battle survival"-  , mfreq   = [("battle survival", 1)]-  , mroster = rosterBattleSurvival-  , mcaves  = cavesBattle-  , mdesc   = "Odds are stacked for those that breathe mathematics."+exploration = ModeKind+  { msymbol = 'c'+  , mname   = "crawl (long)"+  , mfreq   = [ ("crawl (long)", 1), ("exploration", 1)+              , ("campaign scenario", 1) ]+  , mroster = rosterExploration+  , mcaves  = cavesExploration+  , mdesc   = "Enjoy the peaceful seclusion of these cold austere tunnels, but don't let wanton curiosity, greed and the ever-creeping abstraction madness keep you down there for too long."   } -safari = ModeKind+safari = ModeKind  -- easter egg available only via screensaver   { msymbol = 'f'   , mname   = "safari"   , mfreq   = [("safari", 1)]   , mroster = rosterSafari   , mcaves  = cavesSafari-  , mdesc   = "In this simulation you'll discover the joys of hunting the most exquisite of Earth's flora and fauna, both animal and semi-intelligent (exit at the bottommost level)."+  , mdesc   = "\"In this simulation you'll discover the joys of hunting the most exquisite of Earth's flora and fauna, both animal and semi-intelligent. Exit at the bottommost level.\" This is a VR recording recovered from a monster nest debris."   } +-- * Testing modes++explorationSurvival = ModeKind+  { msymbol = 'd'+  , mname   = "crawl survival"+  , mfreq   = [("crawl survival", 1)]+  , mroster = rosterExplorationSurvival+  , mcaves  = cavesExploration+  , mdesc   = "Lure the human intruders deeper and deeper."+  }+ safariSurvival = ModeKind   { msymbol = 'u'   , mname   = "safari survival"@@ -93,262 +148,299 @@   , mdesc   = "In this simulation you'll discover the joys of being hunted among the most exquisite of Earth's flora and fauna, both animal and semi-intelligent."   } -pvp = ModeKind-  { msymbol = 'v'-  , mname   = "PvP"-  , mfreq   = [("PvP", 1)]-  , mroster = rosterPvP-  , mcaves  = cavesSkirmish-  , mdesc   = "(Not usable right now.) This is a fight to the death between two human-controlled teams."+battle = ModeKind+  { msymbol = 'b'+  , mname   = "battle"+  , mfreq   = [("battle", 1)]+  , mroster = rosterBattle+  , mcaves  = cavesBattle+  , mdesc   = "Odds are stacked against those that unleash the horrors of abstraction."   } -coop = ModeKind-  { msymbol = 'o'-  , mname   = "Coop"-  , mfreq   = [("Coop", 1)]-  , mroster = rosterCoop-  , mcaves  = cavesCampaign-  , mdesc   = "(This mode is intended solely for automated testing.)"+battleSurvival = ModeKind+  { msymbol = 'i'+  , mname   = "battle survival"+  , mfreq   = [("battle survival", 1)]+  , mroster = rosterBattleSurvival+  , mcaves  = cavesBattle+  , mdesc   = "Odds are stacked for those that breathe mathematics."   } -defense = ModeKind+defense = ModeKind  -- perhaps a real scenario in the future   { msymbol = 'e'   , mname   = "defense"   , mfreq   = [("defense", 1)]   , mroster = rosterDefense-  , mcaves  = cavesCampaign-  , mdesc   = "Don't let the humans defile your abstract secrets and flee, like the vulgar, literal, base scoundrels that they are!"+  , mcaves  = cavesExploration+  , mdesc   = "Don't let human interlopers defile your abstract secrets and flee unpunished!"   } -screensaver = safari-  { mname   = "safari screensaver"-  , mfreq   = [("starting", 1)]-  , mroster = rosterSafari-      { rosterList = (head (rosterList rosterSafari))-                       -- changing leader by client needed, because of TFollow-                       -- changing level by client enabled for UI-                       {fleaderMode = LeaderAI $ AutoLeader False False}-                     : tail (rosterList rosterSafari)-      }+-- * Screensaver modes++screensave :: AutoLeader -> Roster -> Roster+screensave auto r =+  let f [] = []+      f ((player, initial) : rest) =+        (player {fleaderMode = LeaderAI auto}, initial) : rest+  in r {rosterList = f $ rosterList r}++screensaverRaid = raid+  { mname   = "auto-raid"+  , mfreq   = [("starting", 1), ("starting JS", 1), ("no confirms", 1)]+  , mroster = screensave (AutoLeader False False) rosterRaid   } -boardgame = ModeKind-  { msymbol = 'g'-  , mname   = "boardgame"-  , mfreq   = [("boardgame", 1)]-  , mroster = rosterBoardgame-  , mcaves  = cavesBoardgame-  , mdesc   = "Small room, no exits. Who will prevail?"+screensaverBrawl = brawl+  { mname   = "auto-brawl"+  , mfreq   = [("no confirms", 1)]+  , mroster = screensave (AutoLeader False False) rosterBrawl   } +screensaverShootout = shootout+  { mname   = "auto-shootout"+  , mfreq   = [("starting", 1), ("starting JS", 1), ("no confirms", 1)]+  , mroster = screensave (AutoLeader False False) rosterShootout+  } -rosterCampaign, rosterRaid, rosterSkirmish, rosterAmbush, rosterBattle, rosterBattleSurvival, rosterSafari, rosterSafariSurvival, rosterPvP, rosterCoop, rosterDefense, rosterBoardgame:: Roster+screensaverEscape = escape+  { mname   = "auto-escape"+  , mfreq   = [("starting", 1), ("starting JS", 1), ("no confirms", 1)]+  , mroster = screensave (AutoLeader False False) rosterEscape+  } -rosterCampaign = Roster-  { rosterList = [ playerHero-                 , playerMonster-                 , playerAnimal ]-  , rosterEnemy = [ ("Adventurer Party", "Monster Hive")-                  , ("Adventurer Party", "Animal Kingdom") ]-  , rosterAlly = [("Monster Hive", "Animal Kingdom")] }+screensaverZoo = zoo+  { mname   = "auto-zoo"+  , mfreq   = [("no confirms", 1)]+  , mroster = screensave (AutoLeader False False) rosterZoo+  } +screensaverAmbush = ambush+  { mname   = "auto-ambush"+  , mfreq   = [("no confirms", 1)]+  , mroster = screensave (AutoLeader False False) rosterAmbush+  }++screensaverExploration = exploration+  { mname   = "auto-crawl"+  , mfreq   = [("no confirms", 1)]+  , mroster = screensave (AutoLeader False False) rosterExploration+  }++screensaverSafari = safari+  { mname   = "auto-safari"+  , mfreq   = [("starting", 1), ("starting JS", 1), ("no confirms", 1)]+  , mroster = -- changing leader by client needed, because of TFollow+              screensave (AutoLeader False True) rosterSafari+  }++rosterRaid, rosterBrawl, rosterShootout, rosterEscape, rosterZoo, rosterAmbush, rosterExploration, rosterExplorationSurvival, rosterSafari, rosterSafariSurvival, rosterBattle, rosterBattleSurvival, rosterDefense :: Roster+ rosterRaid = Roster-  { rosterList = [ playerHero { fname = "White Recursive"-                              , fhiCondPoly = hiRaid-                              , fentryLevel = -4-                              , finitialActors = 1 }-                 , playerAntiHero { fname = "Red Iterative"-                                  , fhiCondPoly = hiRaid-                                  , fentryLevel = -4-                                  , finitialActors = 1 }-                 , playerAnimal { fentryLevel = -4-                                , finitialActors = 2 } ]-  , rosterEnemy = [ ("White Recursive", "Animal Kingdom")-                  , ("Red Iterative", "Animal Kingdom") ]+  { rosterList = [ ( playerHero {fhiCondPoly = hiRaid}+                   , [(-2, 1, "hero")] )+                 , ( playerAntiHero { fname = "Indigo Founder"+                                    , fhiCondPoly = hiRaid }+                   , [(-2, 1, "hero")] )+                 , ( playerAnimal  -- starting over escape+                   , [(-2, 2, "animal")] )+                 , (playerHorror, []) ]  -- for summoned monsters+  , rosterEnemy = [ ("Explorer", "Animal Kingdom")+                  , ("Explorer", "Horror Den")+                  , ("Indigo Founder", "Animal Kingdom")+                  , ("Indigo Founder", "Horror Den") ]   , rosterAlly = [] } -rosterSkirmish = Roster-  { rosterList = [ playerHero { fname = "White Haskell"-                              , fhiCondPoly = hiDweller-                              , fentryLevel = -3 }-                 , playerAntiHero { fname = "Purple Agda"-                                  , fhiCondPoly = hiDweller-                                  , fentryLevel = -3 }-                 , playerHorror ]-  , rosterEnemy = [ ("White Haskell", "Purple Agda")-                  , ("White Haskell", "Horror Den")-                  , ("Purple Agda", "Horror Den") ]+rosterBrawl = Roster+  { rosterList = [ ( playerHero { fcanEscape = False+                                , fhiCondPoly = hiDweller }+                   , [(-3, 3, "hero")] )+                 , ( playerAntiHero { fname = "Indigo Researcher"+                                    , fcanEscape = False+                                    , fhiCondPoly = hiDweller }+                   , [(-3, 3, "hero")] )+                 , (playerHorror, []) ]+  , rosterEnemy = [ ("Explorer", "Indigo Researcher")+                  , ("Explorer", "Horror Den")+                  , ("Indigo Researcher", "Horror Den") ]   , rosterAlly = [] } -rosterAmbush = Roster-  { rosterList = [ playerSniper { fname = "Yellow Idris"-                                , fhiCondPoly = hiDweller-                                , fentryLevel = -5-                                , finitialActors = 4 }-                 , playerAntiSniper { fname = "Blue Epigram"-                                    , fhiCondPoly = hiDweller-                                    , fentryLevel = -5-                                    , finitialActors = 4 }-                 , playerHorror {fentryLevel = -5} ]-  , rosterEnemy = [ ("Yellow Idris", "Blue Epigram")-                  , ("Yellow Idris", "Horror Den")-                  , ("Blue Epigram", "Horror Den") ]+-- Exactly one scout gets a sight boost, to help the aggressor, because he uses+-- the scout for initial attack, while camper (on big enough maps)+-- can't guess where the attack would come and so can't position his single+-- scout to counter the stealthy advance.+rosterShootout = Roster+  { rosterList = [ ( playerHero { fcanEscape = False+                                , fhiCondPoly = hiDweller }+                   , [(-5, 1, "scout hero"), (-5, 2, "ranger hero")] )+                 , ( playerAntiHero { fname = "Indigo Researcher"+                                    , fcanEscape = False+                                    , fhiCondPoly = hiDweller }+                   , [(-5, 1, "scout hero"), (-5, 2, "ranger hero")] )+                 , (playerHorror, []) ]+  , rosterEnemy = [ ("Explorer", "Indigo Researcher")+                  , ("Explorer", "Horror Den")+                  , ("Indigo Researcher", "Horror Den") ]   , rosterAlly = [] } -rosterBattle = Roster-  { rosterList = [ playerSoldier { fhiCondPoly = hiDweller-                                 , fentryLevel = -5-                                 , finitialActors = 5 }-                 , playerMobileMonster { fentryLevel = -5-                                       , finitialActors = 35-                                       , fneverEmpty = True }-                 , playerMobileAnimal { fentryLevel = -5-                                      , finitialActors = 30-                                      , fneverEmpty = True } ]-  , rosterEnemy = [ ("Armed Adventurer Party", "Monster Hive")-                  , ("Armed Adventurer Party", "Animal Kingdom") ]-  , rosterAlly = [("Monster Hive", "Animal Kingdom")] }--rosterBattleSurvival = rosterBattle-  { rosterList = [ playerSoldier { fhiCondPoly = hiDweller-                                 , fentryLevel = -5-                                 , finitialActors = 5-                                 , fleaderMode =-                                     LeaderAI $ AutoLeader True False-                                 , fhasUI = False }-                 , playerMobileMonster { fentryLevel = -5-                                       , finitialActors = 35-                                       , fneverEmpty = True }-                 , playerMobileAnimal { fentryLevel = -5-                                      , finitialActors = 30-                                      , fneverEmpty = True-                                      , fhasUI = True } ] }--playerMonsterTourist, playerHunamConvict, playerAnimalMagnificent, playerAnimalExquisite :: Player Dice+rosterEscape = Roster+  { rosterList = [ ( playerHero {fhiCondPoly = hiEscapist}+                   , [(-7, 1, "scout hero"), (-7, 2, "escapist hero")] )+                 , ( playerAntiHero { fname = "Indigo Researcher"+                                    , fcanEscape = False  -- start on escape+                                    , fhiCondPoly = hiDweller }+                   , [(-7, 1, "scout hero"), (-7, 7, "ambusher hero")] )+                 , (playerHorror, []) ]+  , rosterEnemy = [ ("Explorer", "Indigo Researcher")+                  , ("Explorer", "Horror Den")+                  , ("Indigo Researcher", "Horror Den") ]+  , rosterAlly = [] } -playerMonsterTourist =-  playerAntiMonster { fname = "Monster Tourist Office"-                    , fcanEscape = True-                    , fneverEmpty = True  -- no spawning-                      -- Follow-the-guide, as tourists do.-                    , ftactic = TFollow-                    , fentryLevel = -4-                    , finitialActors = 15-                    , fleaderMode =-                      LeaderUI $ AutoLeader False False }+rosterZoo = Roster+  { rosterList = [ ( playerHero { fcanEscape = False+                                , fhiCondPoly = hiDweller }+                   , [(-8, 5, "soldier hero")] )+                 , ( playerAnimal {fneverEmpty = True}+                   , [(-8, 100, "mobile animal")] )+                 , (playerHorror, []) ]  -- for summoned monsters+  , rosterEnemy = [ ("Explorer", "Animal Kingdom")+                  , ("Explorer", "Horror Den") ]+  , rosterAlly = [] } -playerHunamConvict =-  playerCivilian { fname = "Hunam Convict Pack"-                 , fentryLevel = -4 }+rosterAmbush = Roster+  { rosterList = [ ( playerHero { fcanEscape = False+                                , fhiCondPoly = hiDweller }+                   , [(-9, 1, "scout hero"), (-9, 5, "ambusher hero")] )+                 , ( playerAntiHero { fname = "Indigo Researcher"+                                    , fcanEscape = False+                                    , fhiCondPoly = hiDweller }+                   , [(-9, 1, "scout hero"), (-9, 5, "ambusher hero")] )+                 , (playerHorror, []) ]+  , rosterEnemy = [ ("Explorer", "Indigo Researcher")+                  , ("Explorer", "Horror Den")+                  , ("Indigo Researcher", "Horror Den") ]+  , rosterAlly = [] } -playerAnimalMagnificent =-  playerMobileAnimal { fname = "Animal Magnificent Specimen Variety"-                     , fneverEmpty = True-                     , fentryLevel = -7-                     , finitialActors = 10-                     , fleaderMode =  -- move away from stairs-                         LeaderAI $ AutoLeader True False }+rosterExploration = Roster+  { rosterList = [ ( playerHero+                   , [(-1, 3, "hero")] )+                 , ( playerMonster+                   , [(-4, 1, "scout monster"), (-4, 3, "monster")] )+                 , ( playerAnimal+                   , -- Fun from the start to avoid empty initial level:+                     [ (-1, 1 + d 2, "animal")+                     -- Huge battle at the end:+                     , (-10, 100, "mobile animal") ] ) ]+  , rosterEnemy = [ ("Explorer", "Monster Hive")+                  , ("Explorer", "Animal Kingdom") ]+  , rosterAlly = [("Monster Hive", "Animal Kingdom")] } -playerAnimalExquisite =-  playerMobileAnimal { fname = "Animal Exquisite Herds and Packs"-                     , fneverEmpty = True-                     , fentryLevel = -10-                     , finitialActors = 30 }+rosterExplorationSurvival = rosterExploration+  { rosterList = [ ( playerHero { fleaderMode =+                                    LeaderAI $ AutoLeader True False+                                , fhasUI = False }+                   , [(-1, 3, "hero")] )+                 , ( playerMonster+                   , [(-4, 1, "scout monster"), (-4, 3, "monster")] )+                 , ( playerAnimal {fhasUI = True}+                   , -- Fun from the start to avoid empty initial level:+                     [ (-1, 1 + d 2, "animal")+                     -- Huge battle at the end:+                     , (-10, 100, "mobile animal") ] ) ] } +-- No horrors faction needed, because spawned heroes land in civilian faction. rosterSafari = Roster-  { rosterList = [ playerMonsterTourist-                 , playerHunamConvict-                 , playerAnimalMagnificent-                 , playerAnimalExquisite-                 ]-  , rosterEnemy = [ ("Monster Tourist Office", "Hunam Convict Pack")+  { rosterList = [ ( playerMonsterTourist+                   , [(-4, 15, "monster")] )+                 , ( playerHunamConvict+                   , [(-4, 3, "civilian")] )+                 , ( playerAnimalMagnificent+                   , [(-7, 20, "mobile animal")] )+                 , ( playerAnimalExquisite  -- start on escape+                   , [(-10, 30, "mobile animal")] ) ]+  , rosterEnemy = [ ("Monster Tourist Office", "Hunam Convict")                   , ( "Monster Tourist Office"-                    , "Animal Magnificent Specimen Variety")+                    , "Animal Magnificent Specimen Variety" )                   , ( "Monster Tourist Office"-                    , "Animal Exquisite Herds and Packs") ]+                    , "Animal Exquisite Herds and Packs Galore" )+                  , ( "Animal Magnificent Specimen Variety"+                    , "Hunam Convict" )+                  , ( "Hunam Convict"+                    , "Animal Exquisite Herds and Packs Galore" ) ]   , rosterAlly = [ ( "Animal Magnificent Specimen Variety"-                   , "Animal Exquisite Herds and Packs" )-                 , ( "Animal Magnificent Specimen Variety"-                   , "Hunam Convict Pack" )-                 , ( "Hunam Convict Pack"-                   , "Animal Exquisite Herds and Packs" ) ] }+                   , "Animal Exquisite Herds and Packs Galore" ) ] }  rosterSafariSurvival = rosterSafari-  { rosterList = [ playerMonsterTourist-                     { fleaderMode = LeaderAI $ AutoLeader True False-                     , fhasUI = False }-                 , playerHunamConvict-                 , playerAnimalMagnificent-                     { fleaderMode = LeaderUI $ AutoLeader False False-                     , fhasUI = True }-                 , playerAnimalExquisite-                 ] }+  { rosterList = [ ( playerMonsterTourist+                       { fleaderMode = LeaderAI $ AutoLeader True True+                       , fhasUI = False }+                   , [(-4, 15, "monster")] )+                 , ( playerHunamConvict+                   , [(-4, 3, "civilian")] )+                 , ( playerAnimalMagnificent+                       { fleaderMode = LeaderUI $ AutoLeader True False+                       , fhasUI = True }+                   , [(-7, 20, "mobile animal")] )+                 , ( playerAnimalExquisite+                   , [(-10, 30, "mobile animal")] ) ] } -rosterPvP = Roster-  { rosterList = [ playerHero { fname = "Red"-                              , fhiCondPoly = hiDweller-                              , fentryLevel = -3 }-                 , playerHero { fname = "Blue"-                              , fhiCondPoly = hiDweller-                              , fentryLevel = -3 }-                 , playerHorror ]-  , rosterEnemy = [ ("Red", "Blue")-                  , ("Red", "Horror Den")-                  , ("Blue", "Horror Den") ]-  , rosterAlly = [] }+rosterBattle = Roster+  { rosterList = [ ( playerHero { fcanEscape = False+                                , fhiCondPoly = hiDweller }+                   , [(-5, 5, "soldier hero")] )+                 , ( playerMonster {fneverEmpty = True}+                   , [(-5, 35, "mobile monster")] )+                 , ( playerAnimal {fneverEmpty = True}+                   , [(-5, 30, "mobile animal")] ) ]+  , rosterEnemy = [ ("Explorer", "Monster Hive")+                  , ("Explorer", "Animal Kingdom") ]+  , rosterAlly = [("Monster Hive", "Animal Kingdom")] } -rosterCoop = Roster-  { rosterList = [ playerAntiHero { fname = "Coral" }-                 , playerAntiHero { fname = "Amber"-                                  , fleaderMode = LeaderNull }-                 , playerAnimal { fhasUI = True }-                 , playerAnimal-                 , playerMonster-                 , playerMonster { fname = "Leaderless Monster Hive"-                                 , fleaderMode = LeaderNull } ]-  , rosterEnemy = [ ("Coral", "Monster Hive")-                  , ("Amber", "Monster Hive") ]-  , rosterAlly = [ ("Coral", "Amber") ] }+rosterBattleSurvival = rosterBattle+  { rosterList = [ ( playerHero { fcanEscape = False+                                , fhiCondPoly = hiDweller+                                , fleaderMode =+                                    LeaderAI $ AutoLeader False False+                                , fhasUI = False }+                   , [(-5, 5, "soldier hero")] )+                 , ( playerMonster {fneverEmpty = True}+                   , [(-5, 35, "mobile monster")] )+                 , ( playerAnimal { fneverEmpty = True+                                  , fhasUI = True }+                   , [(-5, 30, "mobile animal")] ) ] } -rosterDefense = rosterCampaign-  { rosterList = [ playerAntiHero-                 , playerAntiMonster-                 , playerAnimal ] }+rosterDefense = rosterExploration+  { rosterList = [ ( playerAntiHero+                   , [(-1, 3, "hero")] )+                 , ( playerAntiMonster+                   , [(-4, 1, "scout monster"), (-4, 3, "monster")] )+                 , ( playerAnimal+                   , [ (-1, 1 + d 2, "animal")+                     , (-10, 100, "mobile animal") ] ) ] } -rosterBoardgame = Roster-  { rosterList = [ playerHero { fname = "Blue"-                              , fhiCondPoly = hiDweller-                              , fentryLevel = -3-                              , finitialActors = 6 }-                 , playerAntiHero { fname = "Red"-                                  , fhiCondPoly = hiDweller-                                  , fentryLevel = -3-                                  , finitialActors = 6 }-                 , playerHorror ]-  , rosterEnemy = [ ("Blue", "Red")-                  , ("Blue", "Horror Den")-                  , ("Red", "Horror Den") ]-  , rosterAlly = [] }+cavesRaid, cavesBrawl, cavesShootout, cavesEscape, cavesZoo, cavesAmbush, cavesExploration, cavesSafari, cavesBattle :: Caves -cavesCampaign, cavesRaid, cavesSkirmish, cavesAmbush, cavesBattle, cavesSafari, cavesBoardgame :: Caves+cavesRaid = IM.fromList [(-2, "caveRaid")] -cavesCampaign = IM.fromList-                $ [ (-1, ("shallow random 1", Just True))-                  , (-2, ("caveRogue", Nothing))-                  , (-3, ("caveEmpty", Nothing)) ]-                  ++ zip [-4, -5..(-9)] (repeat ("campaign random", Nothing))-                  ++ [(-10, ("caveNoise", Nothing))]+cavesBrawl = IM.fromList [(-3, "caveBrawl")] -cavesRaid = IM.fromList [(-4, ("caveRogueLit", Just True))]+cavesShootout = IM.fromList [(-5, "caveShootout")] -cavesSkirmish = IM.fromList [(-3, ("caveSkirmish", Nothing))]+cavesEscape = IM.fromList [(-7, "caveEscape")] -cavesAmbush = IM.fromList [(-5, ("caveAmbush", Nothing))]+cavesZoo = IM.fromList [(-8, "caveZoo")] -cavesBattle = IM.fromList [(-5, ("caveBattle", Nothing))]+cavesAmbush = IM.fromList [(-9, "caveAmbush")] -cavesSafari = IM.fromList [ (-4, ("caveSafari1", Nothing))-                          , (-7, ("caveSafari2", Nothing))-                          , (-10, ("caveSafari3", Just False)) ]+cavesExploration = IM.fromList $+  [ (-1, "outermost")+  , (-2, "shallow random 2")+  , (-3, "caveEmpty") ]+  ++ zip [-4, -5] (repeat "default random")+  ++ zip [-6, -7, -8, -9] (repeat "deep random")+  ++ [(-10, "caveNoise2")] -cavesBoardgame = IM.fromList [(-3, ("caveBoardgame", Nothing))]+cavesSafari = IM.fromList [ (-4, "caveSafari1")+                          , (-7, "caveSafari2")+                          , (-10, "caveSafari3") ]++cavesBattle = IM.fromList [(-5, "caveBattle")]

GameDefinition/Content/ModeKindPlayer.hs view

@@ -1,86 +1,63 @@ -- | Basic players definitions. module Content.ModeKindPlayer-  ( playerHero, playerSoldier, playerSniper-  , playerAntiHero, playerAntiSniper, playerCivilian-  , playerMonster, playerMobileMonster, playerAntiMonster-  , playerAnimal, playerMobileAnimal-  , playerHorror-  , hiHero, hiDweller, hiRaid+  ( playerHero, playerAntiHero, playerCivilian+  , playerMonster, playerAntiMonster, playerAnimal+  , playerHorror, playerMonsterTourist, playerHunamConvict+  , playerAnimalMagnificent, playerAnimalExquisite+  , hiHero, hiDweller, hiRaid, hiEscapist   ) where -import Data.List+import Prelude () +import Game.LambdaHack.Common.Prelude+ import Game.LambdaHack.Common.Ability-import Game.LambdaHack.Common.Dice+import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.ModeKind -playerHero, playerSoldier, playerSniper, playerAntiHero, playerAntiSniper, playerCivilian, playerMonster, playerMobileMonster, playerAntiMonster, playerAnimal, playerMobileAnimal, playerHorror :: Player Dice+playerHero, playerAntiHero, playerCivilian, playerMonster, playerAntiMonster, playerAnimal, playerHorror, playerMonsterTourist, playerHunamConvict, playerAnimalMagnificent, playerAnimalExquisite :: Player  playerHero = Player-  { fname = "Adventurer Party"-  , fgroup = "hero"+  { fname = "Explorer"+  , fgroups = ["hero"]   , fskillsOther = meleeAdjacent   , fcanEscape = True   , fneverEmpty = True   , fhiCondPoly = hiHero-  , fhasNumbers = True   , fhasGender = True   , ftactic = TExplore-  , fentryLevel = -1-  , finitialActors = 3   , fleaderMode = LeaderUI $ AutoLeader False False   , fhasUI = True   } -playerSoldier = playerHero-  { fname = "Armed Adventurer Party"-  , fgroup = "soldier"-  }--playerSniper = playerHero-  { fname = "Sniper Adventurer Party"-  , fgroup = "sniper"-  }- playerAntiHero = playerHero   { fleaderMode = LeaderAI $ AutoLeader True False   , fhasUI = False   } -playerAntiSniper = playerSniper-  { fleaderMode = LeaderAI $ AutoLeader True False-  , fhasUI = False-  }- playerCivilian = Player-  { fname = "Civilian Crowd"-  , fgroup = "civilian"+  { fname = "Civilian"+  , fgroups = ["hero", "civilian"]   , fskillsOther = zeroSkills  -- not coordinated by any leadership   , fcanEscape = False   , fneverEmpty = True   , fhiCondPoly = hiDweller-  , fhasNumbers = False   , fhasGender = True   , ftactic = TPatrol-  , fentryLevel = -1-  , finitialActors = d 2 + 1   , fleaderMode = LeaderNull  -- unorganized   , fhasUI = False   }  playerMonster = Player   { fname = "Monster Hive"-  , fgroup = "monster"+  , fgroups = ["monster", "mobile monster", "immobile monster"]   , fskillsOther = zeroSkills   , fcanEscape = False   , fneverEmpty = False   , fhiCondPoly = hiDweller-  , fhasNumbers = False   , fhasGender = False   , ftactic = TExplore-  , fentryLevel = -4-  , finitialActors = 4  -- one of these most probably not nose, so will explore   , fleaderMode =       -- No point changing leader on level, since all move and they       -- don't follow the leader.@@ -88,8 +65,6 @@   , fhasUI = False   } -playerMobileMonster = playerMonster- playerAntiMonster = playerMonster   { fhasUI = True   , fleaderMode = LeaderUI $ AutoLeader True True@@ -97,71 +72,87 @@  playerAnimal = Player   { fname = "Animal Kingdom"-  , fgroup = "animal"+  , fgroups = ["animal", "mobile animal", "immobile animal", "scavenger"]   , fskillsOther = zeroSkills   , fcanEscape = False   , fneverEmpty = False   , fhiCondPoly = hiDweller-  , fhasNumbers = False   , fhasGender = False   , ftactic = TRoam  -- can't pick up, so no point exploring-  , fentryLevel = -1  -- fun from the start to avoid empty initial level-  , finitialActors = 1 + d 2   , fleaderMode = LeaderNull   , fhasUI = False   } -playerMobileAnimal = playerAnimal-  { fgroup = "mobile animal" }- -- | A special player, for summoned actors that don't belong to any -- of the main players of a given game. E.g., animals summoned during--- a skirmish game between two hero factions land in the horror faction.+-- a brawl game between two hero factions land in the horror faction. -- In every game, either all factions for which summoning items exist -- should be present or a horror player should be added to host them.--- Actors that can be summoned should have "horror" in their @ifreq@ set. playerHorror = Player   { fname = "Horror Den"-  , fgroup = "horror"+  , fgroups = [nameOfHorrorFact]   , fskillsOther = zeroSkills   , fcanEscape = False   , fneverEmpty = False   , fhiCondPoly = []-  , fhasNumbers = False   , fhasGender = False   , ftactic = TPatrol  -- disoriented-  , fentryLevel = -3-  , finitialActors = 0   , fleaderMode = LeaderNull   , fhasUI = False   } +playerMonsterTourist =+  playerAntiMonster { fname = "Monster Tourist Office"+                    , fcanEscape = True+                    , fneverEmpty = True  -- no spawning+                    , fhiCondPoly = hiEscapist+                    , ftactic = TFollow  -- follow-the-guide, as tourists do+                    , fleaderMode = LeaderUI $ AutoLeader False False }++playerHunamConvict =+  playerCivilian { fname = "Hunam Convict"+                 , fleaderMode = LeaderAI $ AutoLeader True False }++playerAnimalMagnificent =+  playerAnimal { fname = "Animal Magnificent Specimen Variety"+               , fneverEmpty = True+               , fleaderMode = -- False to move away from stairs+                               LeaderAI $ AutoLeader True False }++playerAnimalExquisite =+  playerAnimal { fname = "Animal Exquisite Herds and Packs Galore"+               , fneverEmpty = True }+ victoryOutcomes :: [Outcome] victoryOutcomes = [Conquer, Escape] -hiHero, hiDweller, hiRaid :: HiCondPoly+hiHero, hiRaid, hiDweller, hiEscapist :: HiCondPoly  -- Heroes rejoice in loot. hiHero = [ ( [(HiLoot, 1)]            , [minBound..maxBound] )-         , ( [(HiConst, 1000), (HiLoss, -100)]+         , ( [(HiConst, 1000), (HiLoss, -1)]            , victoryOutcomes )          ] +hiRaid = [ ( [(HiLoot, 1)]+           , [minBound..maxBound] )+         , ( [(HiConst, 100)]+           , victoryOutcomes )+         ]+ -- Spawners or skirmishers get no points from loot, but try to kill -- all opponents fast or at least hold up for long.-hiDweller = [ ( [(HiConst, 1000)]  -- no loot+hiDweller = [ ( [(HiConst, 1000)]  -- no loot, so big win reward               , victoryOutcomes )             , ( [(HiConst, 1000), (HiLoss, -10)]               , victoryOutcomes )-            , ( [(HiBlitz, -100)]+            , ( [(HiBlitz, -100)]  -- speed matters               , victoryOutcomes )             , ( [(HiSurvival, 100)]               , [minBound..maxBound] \\ victoryOutcomes )             ] -hiRaid = [ ( [(HiLoot, 1)]-           , [minBound..maxBound] )-         , ( [(HiConst, 100)]-           , victoryOutcomes )-         ]+hiEscapist = ( [(HiLoot, 1)]  -- loot matters a little bit+             , [minBound..maxBound] )+             : hiDweller

GameDefinition/Content/PlaceKind.hs view

@@ -1,7 +1,14 @@ -- | Room, hall and passage definitions.-module Content.PlaceKind ( cdefs ) where+module Content.PlaceKind+  ( cdefs+  ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Game.LambdaHack.Common.ContentDef+import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.PlaceKind  cdefs :: ContentDef PlaceKind@@ -11,27 +18,75 @@   , getFreq = pfreq   , validateSingle = validateSinglePlaceKind   , validateAll = validateAllPlaceKind-  , content =-      [rect, ruin, collapsed, collapsed2, collapsed3, collapsed4, pillar, pillar2, pillar3, pillar4, colonnade, colonnade2, colonnade3, colonnade4, colonnade5, colonnade6, lampPost, lampPost2, lampPost3, lampPost4, treeShade, treeShade2, treeShade3, boardgame]+  , content = contentFromList $+      [rect, rectWindows, glasshouse, pulpit, ruin, collapsed, collapsed2, collapsed3, collapsed4, collapsed5, collapsed6, collapsed7, pillar, pillar2, pillar3, pillar4, colonnade, colonnade2, colonnade3, colonnade4, colonnade5, colonnade6, lampPost, lampPost2, lampPost3, lampPost4, treeShade, fogClump, fogClump2, smokeClump, smokeClump2FGround, bushClump, staircase, staircase2, staircase3, staircase4, staircase5, staircase6, staircase7, staircase8, staircase9, staircase10, staircase11, staircase12, staircase13, staircase14, staircase15, staircase16, staircase17, staircaseOutdoor, staircaseGated, escapeUp, escapeUp2, escapeUp3, escapeUp4, escapeUp5, escapeDown, escapeDown2, escapeDown3, escapeDown4, escapeDown5, escapeOutdoorDown]+      ++ map makeStaircaseUp lstaircase+      ++ map makeStaircaseDown lstaircase   }-rect,        ruin, collapsed, collapsed2, collapsed3, collapsed4, pillar, pillar2, pillar3, pillar4, colonnade, colonnade2, colonnade3, colonnade4, colonnade5, colonnade6, lampPost, lampPost2, lampPost3, lampPost4, treeShade, treeShade2, treeShade3, boardgame :: PlaceKind+rect,        rectWindows, glasshouse, pulpit, ruin, collapsed, collapsed2, collapsed3, collapsed4, collapsed5, collapsed6, collapsed7, pillar, pillar2, pillar3, pillar4, colonnade, colonnade2, colonnade3, colonnade4, colonnade5, colonnade6, lampPost, lampPost2, lampPost3, lampPost4, treeShade, fogClump, fogClump2, smokeClump, smokeClump2FGround, bushClump, staircase, staircase2, staircase3, staircase4, staircase5, staircase6, staircase7, staircase8, staircase9, staircase10, staircase11, staircase12, staircase13, staircase14, staircase15, staircase16, staircase17, staircaseOutdoor, staircaseGated, escapeUp, escapeUp2, escapeUp3, escapeUp4, escapeUp5, escapeDown, escapeDown2, escapeDown3, escapeDown4, escapeDown5, escapeOutdoorDown :: PlaceKind +lstaircase :: [PlaceKind]+lstaircase = [staircase, staircase2, staircase3, staircase4, staircase5, staircase6, staircase7, staircase8, staircase9, staircase10, staircase11, staircase12, staircase13, staircase14, staircase15, staircase16, staircase17, staircaseOutdoor, staircaseGated]++-- The dots below are @Char.chr 183@, as defined in @TileKind.floorSymbol@. rect = PlaceKind  -- Valid for any nonempty area, hence low frequency.   { psymbol  = 'r'   , pname    = "room"-  , pfreq    = [("rogue", 100), ("ambush", 8), ("noise", 80)]+  , pfreq    = [ ("rogue", 100), ("arena", 40), ("laboratory", 40)+               , ("shootout", 8), ("zoo", 7) ]   , prarity  = [(1, 10), (10, 8)]   , pcover   = CStretch   , pfence   = FNone   , ptopLeft = [ "--"-               , "|."+               , "|·"                ]   , poverride = []   }+rectWindows = PlaceKind+  { psymbol  = 'w'+  , pname    = "room"+  , pfreq    = [("empty", 10), ("park", 7)]+  , prarity  = [(1, 10), (10, 8)]+  , pcover   = CStretch+  , pfence   = FNone+  , ptopLeft = [ "-="+               , "!·"+               ]+  , poverride = [('=', "rectWindowsOver_=_Lit"), ('!', "rectWindowsOver_!_Lit")]+      -- for now I need to specify 'Lit' or I'd be randomly getting lit and dark+      -- tiles, until ooverride is extended to take night/dark into account+  }+glasshouse = PlaceKind+  { psymbol  = 'g'+  , pname    = "glasshouse"+  , pfreq    = [("arena", 40), ("zoo", 12)]+  , prarity  = [(1, 10), (10, 8)]+  , pcover   = CStretch+  , pfence   = FNone+  , ptopLeft = [ "=="+               , "!·"+               ]+  , poverride = [('=', "glasshouseOver_=_Lit"), ('!', "glasshouseOver_!_Lit")]+  }+pulpit = PlaceKind+  { psymbol  = 'p'+  , pname    = "pulpit"+  , pfreq    = [("arena", 10), ("zoo", 30)]+  , prarity  = [(1, 10), (10, 8)]+  , pcover   = CMirror+  , pfence   = FGround+  , ptopLeft = [ "==·"+               , "!··"+               , "··O"+               ]+  , poverride = [ ('=', "glasshouseOver_=_Lit"), ('!', "glasshouseOver_!_Lit")+                , ('O', "pulpit") ]+      -- except for floor, this will all be lit, regardless of night/dark; OK+  } ruin = PlaceKind   { psymbol  = 'R'   , pname    = "ruin"-  , pfreq    = [("ambush", 17), ("battle", 100), ("noise", 40)]+  , pfreq    = [("battle", 33), ("noise", 50)]   , prarity  = [(1, 10), (10, 20)]   , pcover   = CStretch   , pfence   = FNone@@ -40,7 +95,7 @@                ]   , poverride = []   }-collapsed = PlaceKind+collapsed = PlaceKind  -- in a dark cave, they have little lights --- that's OK   { psymbol  = 'c'   , pname    = "collapsed cavern"   , pfreq    = [("noise", 1)]@@ -52,186 +107,528 @@   , poverride = []   } collapsed2 = collapsed-  { pfreq    = [("noise", 100), ("battle", 50)]+  { pfreq    = [("noise", 100), ("battle", 20)]+  , ptopLeft = [ "XO"+               , "OO"+               ]+  }+collapsed3 = collapsed+  { pfreq    = [("noise", 200), ("battle", 20)]   , ptopLeft = [ "XXO"+               , "OOO"+               ]+  }+collapsed4 = collapsed+  { pfreq    = [("noise", 200), ("battle", 20)]+  , ptopLeft = [ "XXXO"+               , "OOOO"+               ]+  }+collapsed5 = collapsed+  { pfreq    = [("noise", 300), ("battle", 50)]+  , ptopLeft = [ "XXO"                , "XOO"+               , "OOO"                ]   }-collapsed3 = collapsed-  { pfreq    = [("noise", 200), ("battle", 50)]+collapsed6 = collapsed+  { pfreq    = [("noise", 400), ("battle", 100)]   , ptopLeft = [ "XXXO"                , "XOOO"+               , "OOOO"                ]   }-collapsed4 = collapsed-  { pfreq    = [("noise", 400), ("battle", 200)]+collapsed7 = collapsed+  { pfreq    = [("noise", 400), ("battle", 100)]   , ptopLeft = [ "XXXO"-               , "XXXO"-               , "XOOO"+               , "XXOO"+               , "OOOO"                ]   } pillar = PlaceKind   { psymbol  = 'p'   , pname    = "pillar room"-  , pfreq    = [("rogue", 1000), ("noise", 50)]+  , pfreq    = [ ("rogue", 500), ("arena", 1000), ("laboratory", 1000)+               , ("empty", 300), ("noise", 1000) ]   , prarity  = [(1, 10), (10, 10)]   , pcover   = CStretch   , pfence   = FNone   -- Larger rooms require support pillars.   , ptopLeft = [ "-----"-               , "|...."-               , "|.O.."-               , "|...."-               , "|...."+               , "|····"+               , "|·O··"+               , "|····"+               , "|····"                ]-  , poverride = []+  , poverride = [('&', "cachable")]   } pillar2 = pillar   { ptopLeft = [ "-----"-               , "|O..."-               , "|...."-               , "|...."-               , "|...."+               , "|O···"+               , "|····"+               , "|····"+               , "|····"                ]   } pillar3 = pillar-  { prarity  = [(1, 2), (10, 2)]+  { prarity  = [(10, 5)]   , ptopLeft = [ "-----"-               , "|O..."-               , "|..O."-               , "|.O.."-               , "|...."+               , "|&·O·"+               , "|····"+               , "|O·O·"+               , "|····"                ]   } pillar4 = pillar-  { prarity  = [(10, 10)]+  { prarity  = [(10, 5)]   , ptopLeft = [ "-----"-               , "|&.O."-               , "|...."-               , "|O..."-               , "|...."+               , "|&·O·"+               , "|····"+               , "|O···"+               , "|····"                ]   } colonnade = PlaceKind   { psymbol  = 'c'   , pname    = "colonnade"-  , pfreq    = [("rogue", 70), ("noise", 2000)]-  , prarity  = [(1, 10), (10, 10)]+  , pfreq    = [ ("rogue", 30), ("arena", 70), ("laboratory", 40)+               , ("empty", 100), ("mine", 10000), ("park", 3000) ]+  , prarity  = [(1, 3), (10, 3)]   , pcover   = CAlternate   , pfence   = FFloor-  , ptopLeft = [ "O."-               , ".O"+  , ptopLeft = [ "O·"+               , "·O"                ]   , poverride = []   } colonnade2 = colonnade-  { prarity  = [(1, 4), (10, 4)]-  , ptopLeft = [ "O."-               , ".."+  { prarity  = [(1, 2), (10, 2)]+  , ptopLeft = [ "O·"+               , "··"                ]   } colonnade3 = colonnade-  { prarity  = [(1, 2), (10, 2)]-  , pfence   = FGround-  , ptopLeft = [ ".."-               , ".O"+  { prarity  = [(1, 12), (10, 12)]+  , ptopLeft = [ "··O"+               , "·O·"+               , "O··"                ]   } colonnade4 = colonnade-  { ptopLeft = [ "O.."-               , ".O."-               , "..O"+  { prarity  = [(1, 12), (10, 12)]+  , ptopLeft = [ "O··"+               , "·O·"+               , "··O"                ]   } colonnade5 = colonnade-  { prarity  = [(1, 4), (10, 4)]-  , ptopLeft = [ "O.."-               , "..O"+  { prarity  = [(1, 7), (10, 7)]+  , ptopLeft = [ "O··"+               , "··O"                ]   } colonnade6 = colonnade-  { ptopLeft = [ "O."-               , ".."-               , ".O"+  { ptopLeft = [ "O·"+               , "··"+               , "·O"                ]   } lampPost = PlaceKind   { psymbol  = 'l'   , pname    = "lamp post"-  , pfreq    = [("ambush", 30), ("battle", 10)]+  , pfreq    = [("park", 20), ("zoo", 10), ("battle", 10)]   , prarity  = [(1, 10), (10, 10)]   , pcover   = CVerbatim   , pfence   = FNone-  , ptopLeft = [ "X.X"-               , ".O."-               , "X.X"+  , ptopLeft = [ "X·X"+               , "·O·"+               , "X·X"                ]-  , poverride = [('O', "lampPostOver_O")]+  , poverride = [('O', "lampPostOver_O"), ('·', "floorActorLit")]   } lampPost2 = lampPost-  { ptopLeft = [ "..."-               , ".O."-               , "..."+  { ptopLeft = [ "···"+               , "·O·"+               , "···"                ]   } lampPost3 = lampPost-  { ptopLeft = [ "XX.XX"-               , "X...X"-               , "..O.."-               , "X...X"-               , "XX.XX"+  { pfreq    = [("park", 3000), ("zoo", 50), ("battle", 110)]+  , ptopLeft = [ "XX·XX"+               , "X···X"+               , "··O··"+               , "X···X"+               , "XX·XX"                ]   } lampPost4 = lampPost-  { ptopLeft = [ "X...X"-               , "....."-               , "..O.."-               , "....."-               , "X...X"+  { pfreq    = [("park", 3000), ("zoo", 50), ("battle", 60)]+  , ptopLeft = [ "X···X"+               , "·····"+               , "··O··"+               , "·····"+               , "X···X"                ]   } treeShade = PlaceKind   { psymbol  = 't'   , pname    = "tree shade"-  , pfreq    = [("skirmish", 100)]+  , pfreq    = [("brawl", 300)]   , prarity  = [(1, 10), (10, 10)]-  , pcover   = CVerbatim+  , pcover   = CMirror   , pfence   = FNone-  , ptopLeft = [ "sss"-               , "XOs"-               , "XXs"+  , ptopLeft = [ "··s"+               , "sO·"+               , "Xs·"                ]-  , poverride = [('O', "treeShadeOver_O"), ('s', "treeShadeOver_s")]+  , poverride = [ ('O', "treeShadeOver_O_Lit"), ('s', "treeShadeOver_s_Lit")+                , ('·', "shaded ground") ]   }-treeShade2 = treeShade-  { ptopLeft = [ "sss"-               , "XOs"-               , "Xss"+fogClump = PlaceKind+  { psymbol  = 'f'+  , pname    = "foggy patch"+  , pfreq    = [("shootout", 170)]+  , prarity  = [(1, 1)]+  , pcover   = CMirror+  , pfence   = FNone+  , ptopLeft = [ "f;"+               , ";f"+               , ";f"                ]+  , poverride = [('f', "fogClumpOver_f_Lit"), (';', "lit fog")]   }-treeShade3 = treeShade-  { ptopLeft = [ "sss"-               , "sOs"-               , "XXs"+fogClump2 = fogClump+  { pfreq    = [("shootout", 400), ("empty", 1500)]+  , prarity  = [(1, 1)]+  , pcover   = CMirror+  , pfence   = FNone+  , ptopLeft = [ "Xff"+               , "f;f"+               , ";;f"+               , "XfX"                ]   }-boardgame = PlaceKind+smokeClump = PlaceKind+  { psymbol  = 's'+  , pname    = "smoky patch"+  , pfreq    = [("zoo", 100)]+  , prarity  = [(1, 1)]+  , pcover   = CMirror+  , pfence   = FNone+  , ptopLeft = [ "f;"+               , ";f"+               , ";f"+               ]+  , poverride = [ ('f', "smokeClumpOver_f_Lit"), (';', "lit smoke")+                , ('·', "floorActorLit") ]+  }+smokeClump2FGround = smokeClump+  { pfreq    = [("laboratory", 100), ("zoo", 1000)]+  , prarity  = [(1, 1)]+  , pcover   = CMirror+  , pfence   = FGround+  , ptopLeft = [ ";f;"+               , "f·f"+               , ";·f"+               , ";f;"+               ]+  }+bushClump = PlaceKind   { psymbol  = 'b'-  , pname    = "boardgame"-  , pfreq    = [("boardgame", 1)]+  , pname    = "bushy patch"+  , pfreq    = [("shootout", 120)]   , prarity  = [(1, 1)]+  , pcover   = CMirror+  , pfence   = FNone+  , ptopLeft = [ "f;"+               , ";f"+               , ";f"+               ]+  , poverride = [('f', "bushClumpOver_f_Lit"), (';', "bush Lit")]+  }+staircase = PlaceKind+  { psymbol  = '|'+  , pname    = "staircase"+  , pfreq    = [("staircase", 1)]+  , prarity  = [(1, 1)]   , pcover   = CVerbatim+  , pfence   = FGround+  , ptopLeft = [ "<·>"+               ]+  , poverride = [ ('<', "staircase up"), ('>', "staircase down")+                , ('I', "signboard") ]+  }+staircase2 = staircase+  { pfreq    = [("staircase", 1000)]+  , pfence   = FFloor+  , ptopLeft = [ "O·O"+               , "···"+               , "<·>"+               , "···"+               , "O·O"+               ]+  }+staircase3 = staircase+  { pfreq    = [("staircase", 1000)]+  , pfence   = FFloor+  , ptopLeft = [ "O·I·O"+               , "·····"+               , "·<·>·"+               , "·····"+               , "O·I·O"+               ]+  }+staircase4 = staircase+  { pfreq    = [("staircase", 1000)]+  , pfence   = FFloor+  , ptopLeft = [ "O·O·O·O"+               , "·······"+               , "O·<·>·O"+               , "·······"+               , "O·O·O·O"+               ]+  }+staircase5 = staircase+  { pfreq    = [("staircase", 100)]+  , pfence   = FGround+  , ptopLeft = [ "O·<·>·O"+               ]+  }+staircase6 = staircase+  { pfreq    = [("staircase", 100)]+  , pfence   = FGround+  , ptopLeft = [ "O··<·>··O"+               ]+  }+staircase7 = staircase+  { pfreq    = [("staircase", 100)]+  , pfence   = FGround+  , ptopLeft = [ "O·I·<·>·I·O"+               ]+  }+staircase8 = staircase+  { pfreq    = [("staircase", 1000)]+  , pfence   = FFloor+  , ptopLeft = [ "O·····O"+               , "··<·>··"+               , "O·····O"+               ]+  }+staircase9 = staircase+  { pfreq    = [("staircase", 1000)]+  , pfence   = FFloor+  , ptopLeft = [ "O·······O"+               , "·O·<·>·O·"+               , "O·······O"+               ]+  }+staircase10 = staircase+  { pfreq    = [("staircase", 1000)]+  , pfence   = FFloor+  , ptopLeft = [ "O·O·····O·O"+               , "·O··<·>··O·"+               , "O·O·····O·O"+               ]+  }+staircase11 = staircase+  { pfreq    = [("staircase", 10000)]+  , pfence   = FGround+  , ptopLeft = [ "··O·O··"+               , "O·····O"+               , "··<·>··"+               , "O·····O"+               , "··O·O··"+               ]+  }+staircase12 = staircase+  { pfreq    = [("staircase", 1000)]   , pfence   = FNone-  , ptopLeft = [ "----------"-               , "|.b.b.b.b|"-               , "|b.b.b.b.|"-               , "|.b.b.b.b|"-               , "|b.b.b.b.|"-               , "|.b.b.b.b|"-               , "|b.b.b.b.|"-               , "|.b.b.b.b|"-               , "|b.b.b.b.|"-               , "----------"+  , ptopLeft = [ "-------"+               , "|·····|"+               , "|·<·>·|"+               , "|·····|"+               , "-------"                ]-  , poverride = [('b', "trailChessLit")]   }+staircase13 = staircase+  { pfreq    = [("staircase", 1000)]+  , pfence   = FNone+  , ptopLeft = [ "---------"+               , "|·······|"+               , "|O·<·>·O|"+               , "|·······|"+               , "---------"+               ]+  }+staircase14 = staircase+  { pfreq    = [("staircase", 1000)]+  , pfence   = FNone+  , ptopLeft = [ "-----------"+               , "|·········|"+               , "|·O·<·>·O·|"+               , "|·········|"+               , "-----------"+               ]+  }+staircase15 = staircase+  { pfreq    = [("staircase", 1000)]+  , pfence   = FNone+  , ptopLeft = [ "-------------"+               , "|···········|"+               , "|O·I·<·>·I·O|"+               , "|···········|"+               , "-------------"+               ]+  }+staircase16 = staircase+  { pfreq    = [("staircase", 1000)]+  , pfence   = FNone+  , ptopLeft = [ "---------"+               , "|O·····O|"+               , "|··<·>··|"+               , "|O·····O|"+               , "---------"+               ]+  }+staircase17 = staircase+  { pfreq    = [("staircase", 1000)]+  , pfence   = FNone+  , ptopLeft = [ "-----------"+               , "|O·······O|"+               , "|·O·<·>·O·|"+               , "|O·······O|"+               , "-----------"+               ]+  }+staircaseOutdoor = staircase+  { pname     = "staircase outdoor"+  , pfreq     = [("staircase outdoor", 1)]+  , poverride = [('<', "staircase outdoor up"), ('>', "staircase outdoor down")]+  }+staircaseGated = staircase+  { pname     = "gated staircase"+  , pfreq     = [("gated staircase", 1)]+  , poverride = [('<', "gated staircase up"), ('>', "gated staircase down")]+  }+escapeUp = PlaceKind+  { psymbol  = '<'+  , pname    = "escape up"+  , pfreq    = [("escape up", 1)]+  , prarity  = [(1, 1)]+  , pcover   = CVerbatim+  , pfence   = FGround+  , ptopLeft = [ "<"+               ]+  , poverride = []+  }+escapeUp2 = escapeUp+  { pfreq    = [("escape up", 1000)]+  , pfence   = FFloor+  , ptopLeft = [ "O·O"+               , "·<·"+               , "O·O"+               ]+  }+escapeUp3 = escapeUp+  { pfreq    = [("escape down", 2000)]+  , pcover   = CMirror+  , pfence   = FFloor+  , ptopLeft = [ "O··"+               , "·<·"+               , "O·O"+               ]+  }+escapeUp4 = escapeUp+  { pfreq    = [("escape up", 1000)]+  , pfence   = FNone+  , ptopLeft = [ "-----"+               , "|O·O|"+               , "|·<·|"+               , "|O·O|"+               , "-----"+               ]+  }+escapeUp5 = escapeUp+  { pfreq    = [("escape up", 2000)]+  , pcover   = CMirror+  , pfence   = FNone+  , ptopLeft = [ "-----"+               , "|O··|"+               , "|·<·|"+               , "|O·O|"+               , "-----"+               ]+  }+escapeDown = PlaceKind+  { psymbol  = '>'+  , pname    = "escape down"+  , pfreq    = [("escape down", 1)]+  , prarity  = [(1, 1)]+  , pcover   = CVerbatim+  , pfence   = FGround+  , ptopLeft = [ ">"+               ]+  , poverride = []+  }+escapeDown2 = escapeDown+  { pfreq    = [("escape down", 1000)]+  , pfence   = FFloor+  , ptopLeft = [ "O·O"+               , "·>·"+               , "O·O"+               ]+  }+escapeDown3 = escapeDown+  { pfreq    = [("escape down", 2000)]+  , pcover   = CMirror+  , pfence   = FFloor+  , ptopLeft = [ "O··"+               , "·>·"+               , "O·O"+               ]+  }+escapeDown4 = escapeDown+  { pfreq    = [("escape down", 1000)]+  , pfence   = FNone+  , ptopLeft = [ "-----"+               , "|O·O|"+               , "|·>·|"+               , "|O·O|"+               , "-----"+               ]+  }+escapeDown5 = escapeDown+  { pfreq    = [("escape down", 2000)]+  , pcover   = CMirror+  , pfence   = FNone+  , ptopLeft = [ "-----"+               , "|O··|"+               , "|·>·|"+               , "|O·O|"+               , "-----"+               ]+  }+escapeOutdoorDown = escapeDown+  { pfreq     = [("escape outdoor down", 1)]+  , poverride = [('>', "escape outdoor down")]+  }++makeStaircaseUp :: PlaceKind -> PlaceKind+makeStaircaseUp s = s+ { psymbol   = '<'+ , pname     = pname s <+> "up"+ , pfreq     = map (\(t, k) -> (toGroupName $ tshow t <+> "up", k)) $ pfreq s+ , poverride = [ ('>', "stair terminal")+               , ('<', toGroupName $ pname s <+> "up")+               , ('I', "signboard") ]+ }++makeStaircaseDown :: PlaceKind -> PlaceKind+makeStaircaseDown s = s+ { psymbol   = '>'+ , pname     = pname s <+> "down"+ , pfreq     = map (\(t, k) -> (toGroupName $ tshow t <+> "down", k)) $ pfreq s+ , poverride = [ ('<', "stair terminal")+               , ('>', toGroupName $ pname s <+> "down")+               , ('I', "signboard") ]+ }

GameDefinition/Content/RuleKind.hs view

@@ -1,15 +1,21 @@ {-# LANGUAGE TemplateHaskell #-} -- | Game rules and assorted game setup data.-module Content.RuleKind ( cdefs ) where+module Content.RuleKind+  ( cdefs+  ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude+ import Language.Haskell.TH.Syntax import System.FilePath+import System.IO (readFile)  -- Cabal-import qualified Paths_LambdaHack as Self (getDataFileName, version)+import qualified Paths_LambdaHack as Self (version)  import Game.LambdaHack.Common.ContentDef-import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.RuleKind  cdefs :: ContentDef RuleKind@@ -19,58 +25,41 @@   , getFreq = rfreq   , validateSingle = validateSingleRuleKind   , validateAll = validateAllRuleKind-  , content =+  , content = contentFromList       [standard]   }  standard :: RuleKind standard = RuleKind-  { rsymbol        = 's'-  , rname          = "standard LambdaHack ruleset"-  , rfreq          = [("standard", 100)]-  -- Check whether one position is accessible from another.-  -- Precondition: the two positions are next to each other-  -- and the target tile is walkable. For LambdaHack we forbid-  -- diagonal movement to and from doors.-  , raccessible    = Nothing-  , raccessibleDoor =-      Just $ \spos tpos -> not $ isDiagonal $ spos `vectorToFrom` tpos-  , rtitle         = "LambdaHack"-  , rpathsDataFile = Self.getDataFileName-  , rpathsVersion  = Self.version+  { rsymbol = 's'+  , rname = "standard LambdaHack ruleset"+  , rfreq = [("standard", 100)]+  , rtitle = "LambdaHack"+  , rexeVersion = Self.version   -- The strings containing the default configuration file   -- included from config.ui.default.-  , rcfgUIName = "config.ui"+  , rcfgUIName = "config.ui" <.> "ini"   , rcfgUIDefault = $(do       let path = "GameDefinition" </> "config.ui" <.> "default"       qAddDependentFile path       x <- qRunIO (readFile path)       lift x)   -- ASCII art for the Main Menu. Only pure 7-bit ASCII characters are-  -- allowed. The picture should be exactly 24 rows by 80 columns,-  -- plus an extra frame (of any characters) that is ignored.-  -- For a different screen size, the picture is centered and the outermost-  -- rows and columns cloned. When displayed in the Main Menu screen,-  -- it's overwritten with the game version string and keybinding strings.-  -- The game version string begins and ends with a space and is placed-  -- in the very bottom right corner. The keybindings overwrite places-  -- marked with 25 left curly brace signs '{' in a row. The sign is forbidden-  -- everywhere else. A specific number of such places with 25 left braces-  -- are required, at most one per row, and all are overwritten-  -- with text that is flushed left and padded with spaces.-  -- The Main Menu is displayed dull white on black.-  -- TODO: Show highlighted keybinding in inverse video or bright white on grey-  -- background. The spaces that pad keybindings are not highlighted.+  -- allowed. The picture should be exactly 24 rows by 80 columns.+  -- For a different screen size, the picture is centered and padded.+  -- with spaces. When displayed in the Main Menu screen, the picture+  -- is overwritten with game and engine version strings and keybindings.+  -- The keybindings overwrite places marked with left curly brace signs.+  -- The sign is forbidden anywhere else. The Main Menu is displayed dull+  -- white on black.   , rmainMenuArt = $(do       let path = "GameDefinition/MainMenu.ascii"       qAddDependentFile path       x <- qRunIO (readFile path)       lift x)   , rfirstDeathEnds = False-  , rfovMode = Digital-  , rwriteSaveClips = 500-  , rleadLevelClips = 100+  , rwriteSaveClips = 1000+  , rleadLevelClips = 50   , rscoresFile = "scores"-  , rsavePrefix = "save"   , rnearby = 20   }

GameDefinition/Content/TileKind.hs view

@@ -1,15 +1,17 @@ -- | Terrain tile definitions.-module Content.TileKind ( cdefs ) where+module Content.TileKind+  ( cdefs+  ) where -import Control.Arrow (first)-import Data.Maybe+import Prelude ()++import Game.LambdaHack.Common.Prelude+ import qualified Data.Text as T  import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.ContentDef import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg-import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.TileKind  cdefs :: ContentDef TileKind@@ -19,275 +21,602 @@   , getFreq = tfreq   , validateSingle = validateSingleTileKind   , validateAll = validateAllTileKind-  , content =-      [wall, hardRock, pillar, pillarCache, lampPost, burningBush, bush, tree, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpLit, stairsLit, stairsDownLit, escapeUpLit, escapeDownLit, unknown, floorCorridorLit, floorArenaLit, floorArenaShade, floorActorLit, floorItemLit, floorActorItemLit, floorRedLit, floorBlueLit, floorGreenLit, floorBrownLit]-      ++ map makeDark [wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsLit, escapeUpLit, escapeDownLit, floorCorridorLit]-      ++ map makeDarkColor [stairsUpLit, stairsDownLit, floorArenaLit, floorActorLit, floorItemLit, floorActorItemLit]+  , content = contentFromList $+      [unknown, hardRock, bedrock, wall, wallSuspect, wallObscured, wallH, wallSuspectH, wallObscuredDefacedH, wallObscuredFrescoedH, pillar, pillarCache, lampPost, signboardUnread, signboardRead, tree, treeBurnt, treeBurning, rubble, rubbleSpice, doorTrapped, doorClosed, doorTrappedH, doorClosedH, stairsUp, stairsTaintedUp, stairsOutdoorUp, stairsGatedUp, stairsDown, stairsTaintedDown, stairsOutdoorDown, stairsGatedDown, escapeUp, escapeDown, escapeOutdoorDown, wallGlass, wallGlassSpice, wallGlassH, wallGlassHSpice, pillarIce, pulpit, bush, bushBurnt, bushBurning, floorFog, floorFogDark, floorSmoke, floorSmokeDark, doorOpen, doorOpenH, floorCorridor, floorArena, floorNoise, floorDirt, floorDirtSpice, floorActor, floorActorItem, floorRed, floorBlue, floorGreen, floorBrown, floorArenaShade ]+      ++ map makeDark ldarkable+      ++ map makeDarkColor ldarkColorable   }-wall,        hardRock, pillar, pillarCache, lampPost, burningBush, bush, tree, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpLit, stairsLit, stairsDownLit, escapeUpLit, escapeDownLit, unknown, floorCorridorLit, floorArenaLit, floorArenaShade, floorActorLit, floorItemLit, floorActorItemLit, floorRedLit, floorBlueLit, floorGreenLit, floorBrownLit :: TileKind+unknown,        hardRock, bedrock, wall, wallSuspect, wallObscured, wallH, wallSuspectH, wallObscuredDefacedH, wallObscuredFrescoedH, pillar, pillarCache, lampPost, signboardUnread, signboardRead, tree, treeBurnt, treeBurning, rubble, rubbleSpice, doorTrapped, doorClosed, doorTrappedH, doorClosedH, stairsUp, stairsTaintedUp, stairsOutdoorUp, stairsGatedUp, stairsDown, stairsTaintedDown, stairsOutdoorDown, stairsGatedDown, escapeUp, escapeDown, escapeOutdoorDown, wallGlass, wallGlassSpice, wallGlassH, wallGlassHSpice, pillarIce, pulpit, bush, bushBurnt, bushBurning, floorFog, floorFogDark, floorSmoke, floorSmokeDark, doorOpen, doorOpenH, floorCorridor, floorArena, floorNoise, floorDirt, floorDirtSpice, floorActor, floorActorItem, floorRed, floorBlue, floorGreen, floorBrown, floorArenaShade :: TileKind -wall = TileKind+ldarkable :: [TileKind]+ldarkable = [wall, wallSuspect, wallObscured, wallH, wallSuspectH, wallObscuredDefacedH, wallObscuredFrescoedH, doorTrapped, doorClosed, doorTrappedH, doorClosedH, wallGlass, wallGlassH, doorOpen, doorOpenH, floorCorridor]++ldarkColorable :: [TileKind]+ldarkColorable = [tree, bush, floorArena, floorNoise, floorDirt, floorDirtSpice, floorActor, floorActorItem]++-- Symbols to be used (the Nethack visual tradition imposes inconsistency):+--         LOS    noLOS+-- Walk    .|-#   :;+-- noWalk  %^-|   -| O&<>++--+-- can be opened ^&++-- can be closed |-+-- some noWalk can be changed without opening, regardless of symbol+-- not used yet:+-- ~ (water, acid, ect.)+-- : (curtain, etc., not flowing, but solid and static)+-- `' (not visible enough, would need font modification)++-- Note that for AI hints and UI comfort, most multiple-use @Embed@ tiles+-- should have a variant, which after first use transforms into a different+-- colour tile without @ChangeTo@ and similar (which then AI no longer touches).+-- If a tile is supposed to be repeatedly activated by AI (e.g., cache),+-- it should keep @ChangeTo@ for the whole time.++-- * Main tiles, in other games modified and some removed++-- ** Not walkable++-- *** Not clear++unknown = TileKind  -- needs to have index 0 and alter 1   { tsymbol  = ' '+  , tname    = "unknown space"+  , tfreq    = [("unknown space", 1)]+  , tcolor   = defFG+  , tcolor2  = defFG+  , talter   = 1+  , tfeature = [Dark, Indistinct]+  }+hardRock = TileKind+  { tsymbol  = ' '+  , tname    = "impenetrable bedrock"+  , tfreq    = [("basic outer fence", 1), ("noise fence", 1)]+  , tcolor   = defFG+  , tcolor2  = defFG+  , talter   = maxBound  -- impenetrable+  , tfeature = [Dark, Indistinct]+  }+bedrock = TileKind+  { tsymbol  = ' '   , tname    = "bedrock"   , tfreq    = [("fillerWall", 1), ("legendLit", 100), ("legendDark", 100)]-  , tcolor   = defBG-  , tcolor2  = defBG-  , tfeature = [Dark]+  , tcolor   = defFG+  , tcolor2  = defFG+  , talter   = 100+  , tfeature = [Dark, Indistinct]       -- Bedrock being dark is bad for AI (forces it to backtrack to explore       -- bedrock at corridor turns) and induces human micromanagement       -- if there can be corridors joined diagonally (humans have to check-      -- with the cursor if the dark space is bedrock or unexplored).+      -- with the xhair if the dark space is bedrock or unexplored).       -- Lit bedrock would be even worse for humans, because it's harder       -- to guess which tiles are unknown and which can be explored bedrock.       -- The setup of Allure is ideal, with lit bedrock that is easily       -- distinguished from an unknown tile. However, LH follows the NetHack,       -- not the Angband, visual tradition, so we can't improve the situation,       -- unless we turn to subtle shades of black or non-ASCII glyphs,-      -- but that is yet different aesthetics and it's inconsistent-      -- with console frontends.+      -- but that is yet different aesthetics.   }-hardRock = TileKind-  { tsymbol  = ' '-  , tname    = "impenetrable bedrock"-  , tfreq    = [("basic outer fence", 1)]+wall = TileKind+  { tsymbol  = '|'+  , tname    = "granite wall"+  , tfreq    = [("legendLit", 100), ("rectWindowsOver_!_Lit", 80)]   , tcolor   = BrWhite-  , tcolor2  = BrWhite-  , tfeature = [Dark, Impenetrable]+  , tcolor2  = defFG+  , talter   = 100+  , tfeature = [BuildAs "suspect vertical wall Lit", Indistinct]   }+wallSuspect = TileKind  -- only on client+  { tsymbol  = '|'+  , tname    = "suspect uneven wall"+  , tfreq    = [("suspect vertical wall Lit", 1)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , talter   = 2+  , tfeature = [ RevealAs "trapped vertical door Lit"+               , ObscureAs "obscured vertical wall Lit"+               , Indistinct ]+  }+wallObscured = TileKind+  { tsymbol  = '|'+  , tname    = "scratched wall"+  , tfreq    = [("obscured vertical wall Lit", 1)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , talter   = 5+  , tfeature = [ Embed "scratch on wall"+               , HideAs "suspect vertical wall Lit"+               , Indistinct+               ]+  }+wallH = TileKind+  { tsymbol  = '-'+  , tname    = "sandstone wall"+  , tfreq    = [("legendLit", 100), ("rectWindowsOver_=_Lit", 80)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , talter   = 100+  , tfeature = [ BuildAs "suspect horizontal wall Lit"+               , Indistinct ]+  }+wallSuspectH = TileKind  -- only on client+  { tsymbol  = '-'+  , tname    = "suspect painted wall"+  , tfreq    = [("suspect horizontal wall Lit", 1)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , talter   = 2+  , tfeature = [ RevealAs "trapped horizontal door Lit"+               , ObscureAs "obscured horizontal wall Lit"+               , Indistinct ]+  }+wallObscuredDefacedH = TileKind+  { tsymbol  = '-'+  , tname    = "defaced wall"+  , tfreq    = [("obscured horizontal wall Lit", 90)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , talter   = 5+  , tfeature = [ Embed "obscene pictograms"+               , HideAs "suspect horizontal wall Lit"+               , Indistinct+               ]+  }+wallObscuredFrescoedH = TileKind+  { tsymbol  = '-'+  , tname    = "frescoed wall"+  , tfreq    = [("obscured horizontal wall Lit", 10)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , talter   = 5+  , tfeature = [ Embed "subtle fresco"+               , HideAs "suspect horizontal wall Lit"+               , Indistinct+               ]  -- a bit beneficial, but AI would loop if allowed to trigger+  } pillar = TileKind   { tsymbol  = 'O'   , tname    = "rock"-  , tfreq    = [ ("cachable", 70)+  , tfreq    = [ ("cachable", 70), ("stair terminal", 100)                , ("legendLit", 100), ("legendDark", 100)-               , ("noiseSet", 100), ("skirmishSet", 5)-               , ("battleSet", 250) ]-  , tcolor   = BrWhite-  , tcolor2  = defFG-  , tfeature = []+               , ("noiseSet", 70), ("battleSet", 250), ("brawlSetLit", 50)+               , ("shootoutSetLit", 10), ("zooSet", 10) ]+  , tcolor   = BrCyan  -- not BrWhite, to tell from heroes+  , tcolor2  = Cyan+  , talter   = 100+  , tfeature = [Indistinct]   } pillarCache = TileKind-  { tsymbol  = '&'+  { tsymbol  = 'O'   , tname    = "cache"-  , tfreq    = [ ("cachable", 30)-               , ("legendLit", 100), ("legendDark", 100) ]-  , tcolor   = BrWhite-  , tcolor2  = defFG-  , tfeature = [ Cause $ IK.CreateItem CGround "useful" IK.TimerNone-               , ChangeTo "cachable" ]+  , tfreq    = [("cachable", 30), ("stair terminal", 1)]+  , tcolor   = BrBlue+  , tcolor2  = Blue+  , talter   = 5+  , tfeature = [ Embed "terrain cache", Embed "terrain cache trap"+               , ChangeTo "cachable", ConsideredByAI, Indistinct ]+      -- Not explorable, but prominently placed, so hard to miss.+      -- Very beneficial, so AI eager to trigger.   } lampPost = TileKind   { tsymbol  = 'O'   , tname    = "lamp post"-  , tfreq    = [("lampPostOver_O", 90)]+  , tfreq    = [("lampPostOver_O", 1)]   , tcolor   = BrYellow   , tcolor2  = Brown+  , talter   = 100   , tfeature = []   }-burningBush = TileKind+signboardUnread = TileKind  -- client only, indicates never used by this faction   { tsymbol  = 'O'-  , tname    = "burning bush"-  , tfreq    = [("lampPostOver_O", 10), ("ambushSet", 3), ("battleSet", 2)]-  , tcolor   = BrRed-  , tcolor2  = Red-  , tfeature = []+  , tname    = "signboard"+  , tfreq    = [("signboard unread", 1)]+  , tcolor   = BrCyan+  , tcolor2  = Cyan+  , talter   = 5+  , tfeature = [ Embed "signboard", Indistinct+               , ConsideredByAI  -- changes after use, so safe for AI+               , RevealAs "signboard" ]  -- to display as hidden   }-bush = TileKind+signboardRead = TileKind  -- after first use revealed to be this one   { tsymbol  = 'O'-  , tname    = "bush"-  , tfreq    = [("ambushSet", 100) ]-  , tcolor   = Green-  , tcolor2  = BrBlack-  , tfeature = [Dark]+  , tname    = "signboard"+  , tfreq    = [("signboard", 1), ("zooSet", 2)]+  , tcolor   = BrCyan+  , tcolor2  = Cyan+  , talter   = 5+  , tfeature = [Embed "signboard", HideAs "signboard unread", Indistinct]   } tree = TileKind   { tsymbol  = 'O'   , tname    = "tree"-  , tfreq    = [("skirmishSet", 14), ("battleSet", 20), ("treeShadeOver_O", 1)]+  , tfreq    = [ ("brawlSetLit", 140), ("shootoutSetLit", 10)+               , ("escapeSetLit", 30), ("treeShadeOver_O_Lit", 1) ]   , tcolor   = BrGreen   , tcolor2  = Green+  , talter   = 50   , tfeature = []   }-wallV = TileKind-  { tsymbol  = '|'-  , tname    = "granite wall"-  , tfreq    = [("legendLit", 100)]-  , tcolor   = BrWhite-  , tcolor2  = defFG-  , tfeature = [HideAs "suspect vertical wall Lit"]+treeBurnt = tree+  { tname    = "burnt tree"+  , tfreq    = [("ambushSet", 3), ("zooSet", 3), ("tree with fire", 30)]+  , tcolor   = BrBlack+  , tcolor2  = BrBlack+  , tfeature = Dark : tfeature tree   }-wallSuspectV = TileKind-  { tsymbol  = '|'-  , tname    = "moldy wall"-  , tfreq    = [("suspect vertical wall Lit", 1)]-  , tcolor   = BrWhite-  , tcolor2  = defFG-  , tfeature = [Suspect, RevealAs "vertical closed door Lit"]+treeBurning = tree+  { tname    = "burning tree"+  , tfreq    = [("ambushSet", 30), ("zooSet", 30), ("tree with fire", 70)]+  , tcolor   = BrRed+  , tcolor2  = Red+  , talter   = 5+  , tfeature = Embed "big fire" : ChangeTo "tree with fire" : tfeature tree+      -- dousing off the tree will have more sense when it periodically+      -- explodes, hitting and lighting up the team and so betraying it   }-doorClosedV = TileKind+rubble = TileKind+  { tsymbol  = '&'+  , tname    = "rubble"+  , tfreq    = []  -- [("floorCorridorLit", 1)]+                   -- disabled while it's all or nothing per cave and per room;+                   -- we need a new mechanism, Spice is not enough, because+                   -- we don't want multicolor trailLit corridors+      -- ("rubbleOrNot", 70)+      -- until we can sync change of tile and activation, it always takes 1 turn+  , tcolor   = BrYellow+  , tcolor2  = Brown+  , talter   = 5+  , tfeature = [OpenTo "rubbleOrNot", Embed "rubble", Indistinct]+  }+rubbleSpice = TileKind+  { tsymbol  = '&'+  , tname    = "rubble"+  , tfreq    = [ ("smokeClumpOver_f_Lit", 1), ("emptySet", 1), ("noiseSet", 5)+               , ("zooSet", 100), ("ambushSet", 20) ]+  , tcolor   = BrYellow+  , tcolor2  = Brown+  , talter   = 5+  , tfeature = [Spice, OpenTo "rubbleSpiceOrNot", Embed "rubble", Indistinct]+      -- It's not explorable, due to not being walkable nor clear and due+      -- to being a door (@OpenTo@), which is kind of OK, because getting+      -- the item is risky and, e.g., AI doesn't attempt it.+      -- Also, AI doesn't go out of its way to clear the way for heroes.+  }+doorTrapped = TileKind   { tsymbol  = '+'-  , tname    = "closed door"-  , tfreq    = [("vertical closed door Lit", 1)]-  , tcolor   = Brown-  , tcolor2  = BrBlack-  , tfeature = [ OpenTo "vertical open door Lit"+  , tname    = "trapped door"+  , tfreq    = [("trapped vertical door Lit", 1)]+  , tcolor   = BrRed+  , tcolor2  = Red+  , talter   = 2+  , tfeature = [ Embed "doorway trap"+               , OpenTo "open vertical door Lit"                , HideAs "suspect vertical wall Lit"-               ]-  }-doorOpenV = TileKind-  { tsymbol  = '-'-  , tname    = "open door"-  , tfreq    = [("vertical open door Lit", 1)]-  , tcolor   = Brown-  , tcolor2  = BrBlack-  , tfeature = [ Walkable, Clear, NoItem, NoActor-               , CloseTo "vertical closed door Lit"+               , Indistinct                ]   }-wallH = TileKind-  { tsymbol  = '-'-  , tname    = "granite wall"-  , tfreq    = [("legendLit", 100)]-  , tcolor   = BrWhite-  , tcolor2  = defFG-  , tfeature = [HideAs "suspect horizontal wall Lit"]-  }-wallSuspectH = TileKind-  { tsymbol  = '-'-  , tname    = "scratched wall"-  , tfreq    = [("suspect horizontal wall Lit", 1)]-  , tcolor   = BrWhite-  , tcolor2  = defFG-  , tfeature = [Suspect, RevealAs "horizontal closed door Lit"]-  }-doorClosedH = TileKind+doorClosed = TileKind   { tsymbol  = '+'   , tname    = "closed door"-  , tfreq    = [("horizontal closed door Lit", 1)]+  , tfreq    = [("closed vertical door Lit", 1)]   , tcolor   = Brown   , tcolor2  = BrBlack-  , tfeature = [ OpenTo "horizontal open door Lit"+  , talter   = 2+  , tfeature = [OpenTo "open vertical door Lit", Indistinct]  -- never hidden+  }+doorTrappedH = TileKind+  { tsymbol  = '+'+  , tname    = "trapped door"+  , tfreq    = [("trapped horizontal door Lit", 1)]+  , tcolor   = BrRed+  , tcolor2  = Red+  , talter   = 2+  , tfeature = [ Embed "doorway trap"+               , OpenTo "open horizontal door Lit"                , HideAs "suspect horizontal wall Lit"+               , Indistinct                ]   }-doorOpenH = TileKind-  { tsymbol  = '|'-  , tname    = "open door"-  , tfreq    = [("horizontal open door Lit", 1)]+doorClosedH = TileKind+  { tsymbol  = '+'+  , tname    = "closed door"+  , tfreq    = [("closed horizontal door Lit", 1)]   , tcolor   = Brown   , tcolor2  = BrBlack-  , tfeature = [ Walkable, Clear, NoItem, NoActor-               , CloseTo "horizontal closed door Lit"-               ]+  , talter   = 2+  , tfeature = [OpenTo "open horizontal door Lit", Indistinct]  -- never hidden   }-stairsUpLit = TileKind+stairsUp = TileKind   { tsymbol  = '<'   , tname    = "staircase up"-  , tfreq    = [("legendLit", 100)]+  , tfreq    = [("staircase up", 9), ("ordinary staircase up", 1)]   , tcolor   = BrWhite   , tcolor2  = defFG-  , tfeature = [Walkable, Clear, NoItem, NoActor, Cause $ IK.Ascend 1]+  , talter   = talterForStairs+  , tfeature = [Embed "staircase up", ConsideredByAI]   }-stairsLit = TileKind-  { tsymbol  = '>'-  , tname    = "staircase"-  , tfreq    = [("legendLit", 100)]-  , tcolor   = BrCyan-  , tcolor2  = Cyan  -- TODO-  , tfeature = [ Walkable, Clear, NoItem, NoActor-               , Cause $ IK.Ascend 1-               , Cause $ IK.Ascend (-1) ]+stairsTaintedUp = TileKind+  { tsymbol  = '<'+  , tname    = "tainted staircase up"+  , tfreq    = [("staircase up", 1)]+  , tcolor   = BrRed+  , tcolor2  = Red+  , talter   = talterForStairs+  , tfeature = [ Embed "staircase up", Embed "staircase trap up"+               , ConsideredByAI, ChangeTo "ordinary staircase up" ]+                 -- AI uses despite the trap; exploration more important   }-stairsDownLit = TileKind+stairsOutdoorUp = stairsUp+  { tname    = "signpost pointing backward"+  , tfreq    = [("staircase outdoor up", 1)]+  }+stairsGatedUp = stairsUp+  { tname    = "gated staircase up"+  , tfreq    = [("gated staircase up", 1)]+  , talter   = talterForStairs + 1  -- animals and bosses can't use+  }+stairsDown = TileKind   { tsymbol  = '>'   , tname    = "staircase down"-  , tfreq    = [("legendLit", 100)]+  , tfreq    = [("staircase down", 9), ("ordinary staircase down", 1)]   , tcolor   = BrWhite   , tcolor2  = defFG-  , tfeature = [Walkable, Clear, NoItem, NoActor, Cause $ IK.Ascend (-1)]+  , talter   = talterForStairs+  , tfeature = [Embed "staircase down", ConsideredByAI]   }-escapeUpLit = TileKind+stairsTaintedDown = TileKind+  { tsymbol  = '>'+  , tname    = "tainted staircase down"+  , tfreq    = [("staircase down", 1)]+  , tcolor   = BrRed+  , tcolor2  = Red+  , talter   = talterForStairs+  , tfeature = [ Embed "staircase down", Embed "staircase trap down"+               , ConsideredByAI, ChangeTo "ordinary staircase down" ]+  }+stairsOutdoorDown = stairsDown+  { tname    = "signpost pointing forward"+  , tfreq    = [("staircase outdoor down", 1)]+  }+stairsGatedDown = stairsDown+  { tname    = "gated staircase down"+  , tfreq    = [("gated staircase down", 1)]+  , talter   = talterForStairs + 1  -- animals and bosses can't use+  }+escapeUp = TileKind   { tsymbol  = '<'   , tname    = "exit hatch up"-  , tfreq    = [("legendLit", 100)]+  , tfreq    = [("legendLit", 1), ("legendDark", 1)]   , tcolor   = BrYellow   , tcolor2  = BrYellow-  , tfeature = [Walkable, Clear, NoItem, NoActor, Cause $ IK.Escape 1]+  , talter   = 0  -- anybody can escape (or guard escape)+  , tfeature = [Embed "escape", ConsideredByAI]   }-escapeDownLit = TileKind+escapeDown = TileKind   { tsymbol  = '>'   , tname    = "exit trapdoor down"-  , tfreq    = [("legendLit", 100)]+  , tfreq    = [("legendLit", 1), ("legendDark", 1)]   , tcolor   = BrYellow   , tcolor2  = BrYellow-  , tfeature = [Walkable, Clear, NoItem, NoActor, Cause $ IK.Escape (-1)]+  , talter   = 0  -- anybody can escape (or guard escape)+  , tfeature = [Embed "escape", ConsideredByAI]   }-unknown = TileKind-  { tsymbol  = ' '-  , tname    = "unknown space"-  , tfreq    = [("unknown space", 1)]-  , tcolor   = defFG-  , tcolor2  = defFG-  , tfeature = [Dark]+escapeOutdoorDown = escapeDown+  { tname    = "exit back to town"+  , tfreq    = [("escape outdoor down", 1)]   }-floorCorridorLit = TileKind++-- *** Clear++wallGlass = TileKind+  { tsymbol  = '|'+  , tname    = "polished crystal wall"+  , tfreq    = [("glasshouseOver_!_Lit", 1)]+  , tcolor   = BrBlue+  , tcolor2  = Blue+  , talter   = 10+  , tfeature = [BuildAs "suspect vertical wall Lit", Clear]+  }+wallGlassSpice = wallGlass+  { tfreq    = [("rectWindowsOver_!_Lit", 20)]+  , tfeature = Spice : tfeature wallGlass+  }+wallGlassH = TileKind+  { tsymbol  = '-'+  , tname    = "polished crystal wall"+  , tfreq    = [("glasshouseOver_=_Lit", 1)]+  , tcolor   = BrBlue+  , tcolor2  = Blue+  , talter   = 10+  , tfeature = [BuildAs "suspect horizontal wall Lit", Clear]+  }+wallGlassHSpice = wallGlassH+  { tfreq    = [("rectWindowsOver_=_Lit", 20)]+  , tfeature = Spice : tfeature wallGlassH+  }+pillarIce = TileKind+  { tsymbol  = '^'+  , tname    = "ice"+  , tfreq    = [("noiseSet", 30)]+  , tcolor   = BrBlue+  , tcolor2  = Blue+  , talter   = 5+  , tfeature = [Clear, Embed "frost", OpenTo "damp stone floor"]+      -- Is door, due to @OpenTo@, so is not explorable, but it's OK, because+      -- it doesn't generate items nor clues. This saves on the need to+      -- get each ice pillar into sight range when exploring level.+  }+pulpit = TileKind+  { tsymbol  = '%'+  , tname    = "pulpit"+  , tfreq    = [("pulpit", 1), ("zooSet", 2)]+  , tcolor   = BrYellow+  , tcolor2  = Brown+  , talter   = 5+  , tfeature = [Clear, Embed "pulpit", Indistinct]+                 -- mixed blessing, so AI ignores, saved for player fun+  }+bush = TileKind+  { tsymbol  = '%'+  , tname    = "bush"+  , tfreq    = [ ("bush Lit", 1), ("shootoutSetLit", 30), ("escapeSetLit", 30)+               , ("bushClumpOver_f_Lit", 1) ]+  , tcolor   = BrGreen+  , tcolor2  = Green+  , talter   = 10+  , tfeature = [Clear]+  }+bushBurnt = bush+  { tname    = "burnt bush"+  , tfreq    = [ ("battleSet", 30), ("ambushSet", 4), ("zooSet", 30)+               , ("bush with fire", 70) ]+  , tcolor   = BrBlack+  , tcolor2  = BrBlack+  , tfeature = Dark : tfeature bush+  }+bushBurning = bush+  { tname    = "burning bush"+  , tfreq    = [("ambushSet", 40), ("zooSet", 300), ("bush with fire", 30)]+  , tcolor   = BrRed+  , tcolor2  = Red+  , talter   = 5+  , tfeature = Embed "small fire" : ChangeTo "bush with fire" : tfeature bush+  }++-- ** Walkable++-- *** Not clear++floorFog = TileKind+  { tsymbol  = ';'+  , tname    = "faint fog"+  , tfreq    = [ ("lit fog", 1), ("emptySet", 5), ("shootoutSetLit", 20)+               , ("noiseSet", 10), ("fogClumpOver_f_Lit", 60) ]+      -- lit fog is OK for shootout, because LOS is mutual, as opposed+      -- to dark fog, and so camper has little advantage, especially+      -- on big maps, where he doesn't know on which side of fog patch to hide+  , tcolor   = BrCyan+  , tcolor2  = Cyan+  , talter   = 0+  , tfeature = [Walkable, NoItem, Indistinct, OftenActor]+  }+floorFogDark = floorFog+  { tname    = "thick fog"+  , tfreq    = [("noiseSet", 10), ("escapeSetDark", 60)]+  , tfeature = Dark : tfeature floorFog+  }+floorSmoke = TileKind+  { tsymbol  = ';'+  , tname    = "billowing smoke"+  , tfreq    = [ ("lit smoke", 1)+               , ("ambushSet", 30), ("zooSet", 30), ("battleSet", 5)+               , ("labTrailLit", 1), ("stair terminal", 2)+               , ("smokeClumpOver_f_Lit", 1) ]+  , tcolor   = Brown+  , tcolor2  = BrBlack+  , talter   = 0+  , tfeature = [Walkable, NoItem, Indistinct]  -- not dark, embers+  }+floorSmokeDark = floorSmoke+  { tname    = "lingering smoke"+  , tfreq    = [("ambushSet", 30)]+  , tfeature = Dark : tfeature floorSmoke+  }++-- *** Clear++doorOpen = TileKind+  { tsymbol  = '-'+  , tname    = "open door"+  , tfreq    = [("open vertical door Lit", 1)]+  , tcolor   = Brown+  , tcolor2  = BrBlack+  , talter   = 4+  , tfeature = [ Walkable, Clear, NoItem, NoActor+               , CloseTo "closed vertical door Lit"+               ]+  }+doorOpenH = TileKind+  { tsymbol  = '|'+  , tname    = "open door"+  , tfreq    = [("open horizontal door Lit", 1)]+  , tcolor   = Brown+  , tcolor2  = BrBlack+  , talter   = 4+  , tfeature = [ Walkable, Clear, NoItem, NoActor+               , CloseTo "closed horizontal door Lit"+               ]+  }+floorCorridor = TileKind   { tsymbol  = '#'   , tname    = "corridor"-  , tfreq    = [("floorCorridorLit", 1)]+  , tfreq    = [("floorCorridorLit", 99), ("rubbleOrNot", 30)]   , tcolor   = BrWhite   , tcolor2  = defFG-  , tfeature = [Walkable, Clear]+  , talter   = 0+  , tfeature = [Walkable, Clear, Indistinct]   }-floorArenaLit = floorCorridorLit-  { tsymbol  = '.'+floorArena = floorCorridor+  { tsymbol  = floorSymbol   , tname    = "stone floor"-  , tfreq    = [ ("floorArenaLit", 1)-               , ("arenaSet", 1), ("emptySet", 1), ("noiseSet", 50)-               , ("battleSet", 1000), ("skirmishSet", 100)-               , ("ambushSet", 1000) ]+  , tfreq    = [ ("floorArenaLit", 1), ("rubbleSpiceOrNot", 30)+               , ("arenaSetLit", 1), ("emptySet", 97), ("zooSet", 1000) ]   }-floorActorLit = floorArenaLit-  { tfreq    = []-  , tfeature = OftenActor : tfeature floorArenaLit+floorNoise = floorArena+  { tname    = "damp stone floor"+  , tfreq    = [("noiseSet", 60), ("damp stone floor", 1)]   }-floorItemLit = floorArenaLit-  { tfreq    = []-  , tfeature = OftenItem : tfeature floorArenaLit+floorDirt = floorArena+  { tname    = "dirt"+  , tfreq    = [ ("battleSet", 1000), ("brawlSetLit", 1000)+               , ("shootoutSetLit", 1000), ("escapeSetLit", 1000)+               , ("ambushSet", 1000) ]   }-floorActorItemLit = floorItemLit-  { tfreq    = [("legendLit", 100)]  -- no OftenItem in legendDark-  , tfeature = OftenActor : tfeature floorItemLit+floorDirtSpice = floorDirt+  { tfreq    = [ ("treeShadeOver_s_Lit", 1), ("fogClumpOver_f_Lit", 40)+               , ("smokeClumpOver_f_Lit", 1), ("bushClumpOver_f_Lit", 1) ]+  , tfeature = Spice : tfeature floorDirt   }-floorArenaShade = floorActorLit-  { tname    = "stone floor"  -- TODO: "shaded ground"-  , tfreq    = [("treeShadeOver_s", 1)]-  , tcolor2  = BrBlack-  , tfeature = Dark : tfeature floorActorLit  -- no OftenItem+floorActor = floorArena+  { tfreq    = [("floorActorLit", 1)]  -- lit even in dark cave, so no items+  , tfeature = OftenActor : tfeature floorArena   }-floorRedLit = floorArenaLit-  { tname    = "brick pavement"-  , tfreq    = [("trailLit", 30), ("trailChessLit", 30)]+floorActorItem = floorActor+  { tfreq    = [("legendLit", 100)]+  , tfeature = OftenItem : tfeature floorActor+  }+floorRed = floorCorridor+  { tsymbol  = floorSymbol+  , tname    = "brick pavement"+  , tfreq    = [("trailLit", 30)]   , tcolor   = BrRed   , tcolor2  = Red-  , tfeature = Trail : tfeature floorArenaLit+  , tfeature = Trail : tfeature floorCorridor  -- no Indistinct   }-floorBlueLit = floorRedLit+floorBlue = floorRed   { tname    = "cobblestone path"-  , tfreq    = [("trailLit", 100), ("trailChessLit", 70)]+  , tfreq    = [("trailLit", 100)]   , tcolor   = BrBlue   , tcolor2  = Blue   }-floorGreenLit = floorRedLit+floorGreen = floorRed   { tname    = "mossy stone path"   , tfreq    = [("trailLit", 100)]   , tcolor   = BrGreen   , tcolor2  = Green   }-floorBrownLit = floorRedLit+floorBrown = floorRed   { tname    = "rotting mahogany deck"   , tfreq    = [("trailLit", 10)]   , tcolor   = BrMagenta   , tcolor2  = Magenta   }+floorArenaShade = floorActor+  { tname    = "shaded ground"+  , tfreq    = [("shaded ground", 1), ("treeShadeOver_s_Lit", 2)]+  , tcolor2  = BrBlack+  , tfeature = Dark : NoItem : tfeature floorActor+  }  makeDark :: TileKind -> TileKind makeDark k = let darkText :: GroupName TileKind -> GroupName TileKind@@ -298,7 +627,9 @@                  darkFeat (CloseTo t) = Just $ CloseTo $ darkText t                  darkFeat (ChangeTo t) = Just $ ChangeTo $ darkText t                  darkFeat (HideAs t) = Just $ HideAs $ darkText t+                 darkFeat (BuildAs t) = Just $ BuildAs $ darkText t                  darkFeat (RevealAs t) = Just $ RevealAs $ darkText t+                 darkFeat (ObscureAs t) = Just $ ObscureAs $ darkText t                  darkFeat OftenItem = Nothing  -- items not common in the dark                  darkFeat feat = Just feat              in k { tfreq    = darkFrequency

+ GameDefinition/InGameHelp.txt view

@@ -0,0 +1,178 @@+This is a snapshot of in-game help, rendered with default config file.+For more general gameplay information see PLAYING.md.+++Minimal cheat sheet for casual play (1/2).++ Walk throughout a level with mouse or numeric keypad (left diagram below)+ or its compact laptop replacement (middle) or the Vi text editor keys (right,+ enabled in config.ui.ini). Run, until disturbed, by adding Shift or Control.+ Go-to with LMB (left mouse button). Run collectively with RMB.++                7 8 9          7 8 9          y k u+                 \|/            \|/            \|/+                4-5-6          u-i-o          h-.-l+                 /|\            /|\            /|\+                1 2 3          j k l          b j n++ In aiming mode, the same keys (and mouse) move the x-hair (aiming crosshair).+ Press 'KP_5' ('5' on keypad, if present) to wait, bracing for impact,+ which reduces any damage taken and prevents displacement by foes. Press+ 'C-KP_5' (the same key with Control) to wait 0.1 of a turn, without bracing.+ You displace enemies by running into them with Shift/Control or RMB. Search,+ open, descend and attack by bumping into walls, doors, stairs and enemies.+ The best item to attack with is automatically chosen from among+ weapons in your personal equipment and your unwounded organs.+++Minimal cheat sheet for casual play (2/2).++ The following commands, joined with the basic set above, let you accomplish+ anything in the game, though not necessarily with the fewest keystrokes.+ You can also play the game exclusively with a mouse, or both mouse and+ keyboard. See the ending help screens for mouse commands.+ Lastly, you can select a command with arrows or mouse directly from the help+ screen and execute it on the spot.++ keys         command+ g or ,       grab item(s)+ c            close door+ P            manage item pack of the leader+ KP_* or !    cycle x-hair among enemies+ +            swerve the aiming line+ ESC          cancel aiming/open Main Menu+ RET or INS   accept target/open Help+ SPACE        clear messages/display history+ S-TAB        cycle among all party members+ =            select (or deselect) party member+++All terrain exploration and alteration commands.++ keys         command+ g or ,       grab item(s)+ d or .       drop item(s)+ ;            go to x-hair for 25 steps+ :            run to x-hair collectively for 25 steps+ x            explore nearest unknown spot+ X            autoexplore 25 times+ R            rest (wait 25 times)+ C-R          lurk (wait 0.1 turns 100 times)+ c            close door+++Item Menu commands.++ keys         command+ g or ,       grab item(s)+ d or .       drop item(s)+ f            fling projectile+ C-f          fling without aiming+ a            apply consumable+ C-a          apply and keep choice+ p            pack item+ e            equip item+ s            stash and share item+++Remaining item-related commands.++ keys         command+ ^            sort items by kind and stats+ P            manage item pack of the leader+ G            manage items on the ground+ E            manage equipment of the leader+ S            manage the shared party stash+ A            manage all owned items+ @            describe organs of the leader+ #            show stat summary of the leader+ ~            display known lore+ q            quaff potion+ r            read scroll+ t            throw missile+++Aiming.++ keys         command+ KP_* or !    cycle x-hair among enemies+ KP_/ or /    cycle x-hair among items+ \            cycle aiming modes+ +            swerve the aiming line+ -            unswerve the aiming line+ C-?          set x-hair to nearest unknown spot+ C-I          set x-hair to nearest item+ C-{          set x-hair to nearest upstairs+ C-}          set x-hair to nearest downstairs+ <            move aiming one level higher+ >            move aiming one level lower+ BACKSPACE    clear chosen item and target+ ESC          cancel aiming/open Main Menu+ RET or INS   accept target/open Help+++Assorted.++ keys         command+ SPACE        clear messages/display history+ ? or F1      display Help+ TAB          cycle among party members on the level+ S-TAB        cycle among all party members+ =            select (or deselect) party member+ _            deselect (or select) all on the level+ v            voice again the recorded commands+ V            voice recorded commands 100 times+ C-v          voice recorded commands 1000 times+ C-V          voice recorded commands 25 times+ '            start recording commands+ 0, 1 ... 6   pick a particular actor as the new leader+++Mouse overview.++ Screen area and UI mode (aiming/exploration) determine mouse click effects.+ Here is an overview of effects of each button over most of the game map area.+ The list includes not only left and right buttons, but also the optional+ middle mouse button (MMB) and even the mouse wheel, which is normally used+ over menus, to page-scroll them, rather than over game map.+ For mice without RMB, one can use C-LMB (Control key and left mouse button).++ keys         command+ LMB          set x-hair to enemy/go to pointer for 25 steps+ RMB or C-LMB fling at enemy/run to pointer collectively for 25 steps+ C-RMB        open or close door+ MMB          snap x-hair to floor under pointer+ WHEEL-UP     swerve the aiming line+ WHEEL-DN     unswerve the aiming line+++Mouse in aiming mode.++ area           LMB (left mouse button)          RMB (right mouse button)+ message line   clear messages/display history   display known lore+ the map area   set x-hair to enemy              fling at enemy under pointer+ level number   move aiming one level higher     move aiming one level lower+ level caption  accept target                    cancel aiming+ percent seen   set x-hair to nearest upstairs   set x-hair to nearest downstai$+ x-hair info    cycle x-hair among enemies       cycle x-hair among items+ party roster   pick new leader on screen        select party member on screen+ Calm gauge     rest (wait 25 times)             lurk (wait 0.1 turns 100 times)+ HP gauge       wait a turn, bracing for impact  wait 0.1 of a turn+ target info    manage item pack of the leader   clear chosen item and target+++Mouse in exploration mode.++ area           LMB (left mouse button)          RMB (right mouse button)+ message line   clear messages/display history   display known lore+ leader on map  grab item(s)                     drop item(s)+ party on map   pick new leader on screen        select party member on screen+ the map area   go to pointer for 25 steps       run to pointer collectively+ level number   move aiming one level higher     move aiming one level lower+ level caption  display Help                     open Main Menu+ percent seen   explore nearest unknown spot     autoexplore 25 times+ x-hair info    cycle x-hair among enemies       cycle x-hair among items+ party roster   pick new leader on screen        select party member on screen+ Calm gauge     rest (wait 25 times)             lurk (wait 0.1 turns 100 times)+ HP gauge       wait a turn, bracing for impact  wait 0.1 of a turn+ target info    manage item pack of the leader   fling without aiming

GameDefinition/Main.hs view

@@ -1,7 +1,14 @@ -- | The main source code file of LambdaHack the game. -- Module "TieKnot" is separated to make it usable in tests.-module Main ( main ) where+module Main+  ( main+  ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude++import Control.Concurrent.Async import System.Environment (getArgs)  import TieKnot@@ -11,4 +18,6 @@ main :: IO () main = do   args <- getArgs-  tieKnot args+  -- Avoid the bound thread that would slow down the communication.+  a <- async $ tieKnot args+  wait a

GameDefinition/MainMenu.ascii view

@@ -1,26 +1,24 @@------------------------------------------------------------------------------------|                                                                                |-|                      >> LambdaHack <<                                          |-|                                                                                |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                                                                                |-|                        Version X.X.X (frontend: gtk, engine: LambdaHack X.X.X) |-----------------------------------------------------------------------------------+fffffjjjjtti,:Lft:                tDEGLLGEKEK;   .    .   . .  .iEDEGL.;iiij ...+fLLLLfffjjjti;.fL .              GDDLfGDEDEf .    .  .      .    ;LDWEGi,;iit ..+LD#WWELfffjjtt;.if.:           .DEGLLGEDLti,   . .    . . .        ,tLKDG ,;itt.+fK#WWW#DLffjjtt;:;j...        tDEGfLDEDGtK.   .LambdaHack           itLEG::;itt.+;K#WWWWW Lfffjjti:.t...      tDEGfLDEDL,   ..  .  .                  tDGj.;itt.+ EWWWWKW  GLffjjti: t,      tDEGLGEEDj;  .                            tLDLi,ittj+ EKWWWEWG  GLffjjti: tt   .tDEGGDEDGi,                                ;fEG :iitj+ LEWWWKKK   GLfffjti: tt  tDDLGDEDGf.  {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ ;jGG :iitj+  DWWWKDWL   DLffjjti: jt.DDLGDEDLD    {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ ,jDG .ittj+  LEWWWEDKj   DLffjjti: jj.LGDEDLE     {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ ,jDG  ittj+   DKKWKDEKf   GLffjjti::ff.EEDLE      {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ ,fGG  ittj+    GWKWEDEEt   GLffjjji :fL.ELE       {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ :tGL  ittf+    EEWKKDGDEjt..DLfftjji.,fG:K,       {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ ,fGj,.tjjf+     EfKGKDLGDDDGDGLffiiti ttf:.       {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ .LG;i,;itt+    ..EDKEKEGjiLDDfGLLfijtii;fL:       {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{ jLj ,;tjtL+   . . KLEEKKDGLLLGLGLfffjji,;LL:,.    {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{,tfL.fijffL+  .......jDKEEKKKKKEDGLffffji;;LL:...  {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{j fGii tjff+..........KtGDKEDEEDGLGLfffjti,;Lf:::: {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{iDf j:jffL.+..........::,E,tjjifL,,LLfffjji.;fL.,: {{{{{{{{{{{{{{{{{{{{{{{{{{{{{{fiififffL .+ ......::,;tjLGGGGGLfji;LLfffjjt.,jft.                              ;t;i:jfff  .+ ..:::::,;;;,iiiiiiii;;;;LLfffjjt,,;LL:  ...                       ,iiijjfffL ..+..:::::,,;;;;;;;;;;;;;;;;;GLffffjt;j,jff,:::,                   ;ifLjjijifffL ..+.......::,,,,;;;;,,,,,,,,,:GLffffjjt:::tLiL                   LLLLGj;i,ffLLL ...+.    ..:::::,,,,,,,,,,, Version X.X.X (frontend: xxx, engine: LambdaHack X.X.X).

GameDefinition/PLAYING.md view

@@ -3,9 +3,9 @@  LambdaHack is a small dungeon crawler illustrating the roguelike game engine of the same name. Playing the game involves exploring spooky dungeons,-alone or in a party of fearless adventurers, setting up ambushes-for unwary creatures, hiding in shadows, bumping into unspeakable horrors,-hidden passages and gorgeous magical treasure and making creative use+alone or in a party of fearless explorers, avoiding and setting up ambushes,+hiding in shadows from the gaze of unspeakable horrors, discovering+secret passages and gorgeous magical treasure and making creative use of it all. The madness-inspiring abominations that multiply in the depths perform the same feats, due to their aberrant, abstract hyper-intelligence, while tirelessly chasing the elusive heroes by sight, sound and smell.@@ -13,202 +13,247 @@ Once the few basic command keys and on-screen symbols are learned, mastery and enjoyment of the game is the matter of tactical skill and literary imagination. To be honest, a lot of imagination is required-for this rudimentary set of scenarios, even though they are playable-and winnable. Contributions are welcome.+for this rudimentary example game, but it has its own quirky style+and is playable and winnable. Contributions are welcome.   Heroes ------  The heroes are marked on the map with symbols `@` and `1` through `9`.-Their goal is to explore the dungeon, battle the horrors within,-gather as much gold and gems as possible, and escape to tell the tale.--The currently chosen party leader is highlighted on the screen+The currently chosen party leader is highlighted on the map and his attributes are displayed at the bottommost status line,-which in its most complex form may look as follows.+which in its most complex form looks as follows. -    *@12 Adventurer  4d1+5% Calm: 20/60 HP: 33/50 Target: basilisk  [**__]+    *@12        4d1+5% Calm: 20/60 HP: 33/50 Target: basilisk  [**__] -The line starts with the list of party members (unless there's only one member)-and the shortened name of the team. Clicking on the list selects heroes and-the selected run together when `:` or `SHIFT`-left mouse button is pressed.+The line starts with the list of party members, with the leader highlighted.+Most commands involve only the leader, including movement with keyboard's+keypad or `LMB` (left mouse button). If more heroes are selected, e.g.,+by clicking on the list with `RMB` (right mouse button), they run together+whenever `:` or `RMB` over map area is pressed. -Then comes the damage of the highest damage dice weapon the leader can use,-then his current and maximum Calm (composure, focus, attentiveness), then-his current and maximum HP (hit points, health). At the end, the personal-target of the leader is described, in this case a basilisk monster,-with hit points drawn as a bar. Weapon damage and other item stats-are displayed using the dice notation `XdY`, which means X rolls-of Y-sided dice. A variant denoted `XdsY` is additionally-scaled by the level depth in proportion to the maximal dungeon depth.-You can read more about combat resolution in section Monsters below.+Next on the status line is the damage of the currently best melee weapon+the leader can use, then his current and maximum Calm (morale, composure,+focus, attentiveness), then his current and maximum HP (hit points, health).+At the end, the personal target of the leader is described, in this case+a basilisk monster, with hit points drawn as a bar. Additionally,+the colon after "Calm" turning into a dot signifies that the leader+is in a position without ambient illumination and a brace sign instead+of colon after "HP" means the leader is braced for combat (see section+[Basic Commands](#basic-commands)). -The second status line describes the current level in relation+Instead of a monster, the target area may describe a position on the map,+a recently spotted item on the floor or an item in inventory selected+for further action or, if none are available, just display the current+leader name. Weapon damage and other item stats are displayed using+the dice notation `XdY`, which means `X` rolls of `Y`-sided dice.+A variant denoted `XdlY` is additionally scaled by the level depth+in proportion to the maximal level depth. Section [Monsters](#monsters)+below describes combat resolution in detail, including the percentage+bonus seen in the example.++The second, upper status line describes the current level in relation to the party.      5  Lofty hall   [33% seen] X-hair: exact spot (71,12)  p15 l10  First comes the depth of the current level and its name. Then the percentage of its explorable tiles already seen by the heroes.-The 'X-hair' (meaning 'crosshair') is the common focus of the whole party,-denoted on the map by a white box and manipulated with movement keys-in aiming mode. At the end of the status line comes the length of the shortest-path from the leader to the crosshair position and the straight-line distance+The `X-hair` (aiming crosshair) is the common focus of the whole party,+marked on the map and manipulated with mouse or movement keys in aiming mode.+In this example, the corsshair points at an exact position on the map+and at the end of the status line comes the length of the shortest+path from the leader to the spot position and the straight-line distance between the two points.  -Dungeon--------+Game map+-------- -The dungeon of any particular scenario may consist of one or many+The map of any particular scenario may consist of one or many levels and each level consists of a large number of tiles.+The game world is persistent, i.e., every time the player visits+a level during a single game, its layout is the same. The basic tile kinds are as follows. -               dungeon terrain type               on-screen symbol-               ground                             .-               corridor                           #-               wall (horizontal and vertical)     - and |-               rock or tree                       O-               cache                              &-               stairs up                          <-               stairs down                        >-               open door                          | and --               closed door                        +-               bedrock                            blank+    game map terrain type                  on-screen symbol+    wall (horizontal and vertical)         - and |+    tree or rock or man-made column        O+    rubble                                 &+    bush, transparent obstacle             %+    trap, ice                              ^+    closed door                            ++    open door (horizontal and vertical)    | and -+    corridor                               #+    smoke or fog                           ;+    ground                                 .+    stairs or exit up                      <+    stairs or exit down                    >+    bedrock                                blank -The game world is persistent, i.e., every time the player visits a level-during a single game, its layout is the same.+So, for example, the following map shows a room with a closed door+connected by a corridor with a room with an open door, a pillar,+staircase down and rubble that obscures one of the corners. +    ----       ----+    |..|       |..&&+    |..+#######-.O.>&|+    |..|       |.....|+    ----       ------- -Commands--------- -You walk throughout a level using the left mouse button or the numeric-keypad (left diagram) or its compact laptop replacement (middle)-or Vi text editor keys (right, also known as "Rogue-like keys",-which have to be enabled in config.ui.ini).+Basic Commands+-------------- -                7 8 9          7 8 9          y k u-                 \|/            \|/            \|/-                4-5-6          u-i-o          h-.-l-                 /|\            /|\            /|\-                1 2 3          j k l          b j n+This section is a copy of the first two screens of in-game help+and a screen introducing mouse commands. The help pages are+automatically generated based on a game's keybinding content and+on overrides in the player's config file. The remaiing in-game help screens,+not shown here, list all game commands grouped by categories, in detail.+A text snapshot of the complete in-game help is in+[InGameHelp.txt](InGameHelp.txt). -In aiming mode (`KEYPAD_*` or `\`) the same keys (or the middle and right-mouse buttons) move the crosshair (the white box). In normal mode,-`SHIFT` (or `CTRL`) and a movement key make the current party leader-run in the indicated direction, until anything of interest is spotted.-The `5` keypad key and the `i` and `.` keys consume a turn and make you-brace for combat, which reduces any damage taken for a turn and makes it-impossible for foes to displace you. You displace enemies or friends-by bumping into them with `SHIFT` (or `CTRL`).+Walk throughout a level with mouse or numeric keypad (left diagram below)+or its compact laptop replacement (middle) or the Vi text editor keys (right,+enabled in config.ui.ini). Run, until disturbed, by adding Shift or Control.+Go-to with LMB (left mouse button). Run collectively with RMB. -Melee, searching for secret doors, looting and opening closed doors-can be done by bumping into a monster, a wall and a door, respectively.-Few commands other than movement, 'g'etting an item from the floor,-'a'pplying an item and 'f'linging an item are necessary for casual play.-Some are provided only as specialized versions of the more general-commands or as building blocks for more complex convenience macros.-E.g., the autoexplore command (key `X`) could be defined-by the player as a macro using `CTRL-?`, `CTRL-.` and `V`.+               7 8 9          7 8 9          y k u+                \|/            \|/            \|/+               4-5-6          u-i-o          h-.-l+                /|\            /|\            /|\+               1 2 3          j k l          b j n -The following minimal command set lets you accomplish almost anything-in the game, though not necessarily with the fewest number of keystrokes.-The full list of commands can be seen in the in-game help accessible-from the Main Menu.+In aiming mode, the same keys (and mouse) move the x-hair (aiming crosshair).+Press 'KP_5' ('5' on keypad, if present) to wait, bracing for impact,+which reduces any damage taken and prevents displacement by foes. Press+'C-KP_5' (the same key with Control) to wait 0.1 of a turn, without bracing.+You displace enemies by running into them with Shift/Control or RMB. Search,+open, descend and attack by bumping into walls, doors, stairs and enemies.+The best item to attack with is automatically chosen from among+weapons in your personal equipment and your unwounded organs. -        keys            command-        <               ascend a level-        >               descend a level-        c               close door-        E               manage equipment of the leader-        g or ,          get items-        a               apply consumable-        f               fling projectile-        +               swerve the aiming line-        D               display player diary-        T               toggle suspect terrain display-        SHIFT-TAB       cycle among all party members-        ESC             cancel action, open Main Menu+The following commands, joined with the basic set above, let you accomplish+anything in the game, though not necessarily with the fewest keystrokes.+You can also play the game exclusively with a mouse, or both mouse and+keyboard. See the ending help screens for mouse commands.+Lastly, you can select a command with arrows or mouse directly from the help+screen and execute it on the spot. -The only activity not possible with the commands above is the management-of non-leader party members. You don't need it, unless your non-leader actors-can move or fire opportunistically (via innate skills or rare equipment).-If really needed, you can manually set party tactics with `CTRL-T`-and you can assign individual targets to party members using the aiming-and targeting commands listed below.+    keys         command+    g or ,       grab item(s)+    c            close door+    P            manage item pack of the leader+    KP_* or !    cycle x-hair among enemies+    +            swerve the aiming line+    ESC          cancel aiming/open Main Menu+    RET or INS   accept target/open Help+    SPACE        clear messages/display history+    S-TAB        cycle among all party members+    =            select (or deselect) party member -        keys            command-        KEYPAD_* or \   aim at an enemy-        KEYPAD_/ or |   cycle aiming styles-        +               swerve the aiming line-        -               unswerve the aiming line-        CTRL-?          set crosshair to the closest unknown spot-        CTRL-I          set crosshair to the closest item-        CTRL-{          set crosshair to the closest stairs up-        CTRL-}          set crosshair to the closest stairs down-        BACKSPACE       reset target/crosshair-        RET or INSERT   accept target/choice+Screen area and UI mode (aiming/exploration) determine mouse click effects.+Here is an overview of effects of each button over most of the game map area.+The list includes not only left and right buttons, but also the optional+middle mouse button (MMB) and even the mouse wheel, which is normally used+over menus, to page-scroll them, rather than over game map.+For mice without RMB, one can use C-LMB (Control key and left mouse button). -For ranged attacks, setting the crosshair or individual targets-beforehand is not mandatory, because the crosshair is set automatically-as soon as a monster comes into view and can still be adjusted while-in the missile choice menu. However, if you want to assign persistent-personal targets or just inspect the level map closely, you can enter-the detailed aiming mode with the right mouse button or with-the `*` keypad key that selects enemies or the `/` keypad key that-marks a tile. You can move the aiming crosshair with direction keys-and assign a personal target to the leader with `RET`.-The details of the shared crosshair position and of the personal target-are described in the status lines at the bottom of the screen.+    keys         command+    LMB          set x-hair to enemy/go to pointer for 25 steps+    RMB or C-LMB fling at enemy/run to pointer collectively for 25 steps+    C-RMB        open or close door+    MMB          snap x-hair to floor under pointer+    WHEEL-UP     swerve the aiming line+    WHEEL-DN     unswerve the aiming line -Commands for saving and exiting the current game, starting a new game, etc.,++Advanced Commands+-----------------++For ranged attacks, setting the aiming crosshair beforehand is not mandatory,+because x-hair is set automatically as soon as a monster comes into view+and can still be adjusted for as long as the missile to fling is not chosen.+However, sometimes you want to examine the level map tile by tile+or assign persistent personal targets to party members.+The latter is essential in the rare cases when your henchmen+(non-leader characters) can move autonomously or fire opportunistically+(via innate skills or rare equipment). Also, if your henchman is adjacent+to more than one enemy, setting his target makes him melee a particular foe.++You can enter the detailed aiming mode with the `*` keypad key that selects+enemies or the `/` keypad key that cycles among items on the floor+and marks a tile underneath an item. You can move x-hair with direction keys+and assign a personal target to the leader with `RET` key (Return, Enter).+The details of the shared x-hair position and of the personal target+are described in the status lines at the bottom of the screen,+as explained in section [Heroes](#heroes) above.++Commands for saving and exiting the current game, starting a new game,+setting options for the current game and challenges for the next game, etc., are listed in the Main Menu, brought up by the `ESC` key.-Game difficulty setting affects hitpoints at birth for any actors-of any UI-using faction. For a person new to roguelikes, the Raid scenario-offers a gentle introduction. The subsequent game modes gradually introduce-squad combat, stealth, opportunity fire, asymmetric battles and more.+Game difficulty, from the challenges menu, determines+hitpoints at birth for any actor of any UI-using faction.+The "lone wolf" challenge mode reduces player's starting actors to exactly+one (consequently, this does not affect the initial 'raid' scenario).+The "cold fish" challenge mode makes it impossible for player characters+to be healed by actors from other factions (this is a significant+restriction in the final 'crawl' scenario). +For a person new to roguelikes, the 'raid' scenario offers a gentle+introduction. The subsequent game scenarios gradually introduce squad combat,+stealth, opportunity fire, asymmetric battles and more. + Monsters -------- -Heroes are not alone in the dungeon. Monstrosities, natural-and out of this world, roam the dark caves and crawl from damp holes+The life of the heroes is full of dangers. Monstrosities, natural+and out of this world, roam the dark corridors and crawl from damp holes day and night. While heroes pay attention to all other party members and take care to move one at a time, monsters don't care about each other and all move at once, sometimes brutally colliding by accident.  When the hero bumps into a monster or a monster attacks the hero, melee combat occurs. Heroes and monsters running into one another-(with the `SHIFT` key) do not inflict damage, but change places.+(with the `Shift` or `Control` key) do not inflict damage, but change places. This gives the opponent a free blow, but can improve the tactical situation or aid escape. In some circumstances actors are immune to the displacing, e.g., when both parties form a continuous front-line.  In melee combat, the best equipped weapon (or the best fighting organ) of each opponent is taken into account for determining the damage-and any extra effects of the blow. If a recharged weapon with a non-trivial-effect is in the equipment, it is preferred for combat. Otherwise combat-involves the weapon with the highest raw damage dice (the same as displayed-at bottommost status line).+and any extra effects of the blow. Since an item needs to be recharged+in order to have its full effect, weapons on timeout are only considered+according to their raw damage dice (the same as displayed at bottommost+status line).  To determine the damage dealt, the outcome of the weapon's damage dice roll-is multiplied by the melee damage bonus (summed from the equipped items-of the attacker) minus the melee armor modifier of the defender.-Regardless of the calculation, each attack inflicts at least 1 damage.+is multiplied by a percentage bonus. The bonus is calculated by taking+the damage bonus (summed from the equipped items of the attacker,+capped at 200%) minus the melee armor modifier of the defender+(capped at 200%, as well), with the outcome bounded between -99% and 99%,+which means that at least 1% of damage always gets through+and the damage is always lower than twice the dice roll. The current leader's melee bonus, armor modifier and other detailed-stats can be viewed via the `!` command.+stats can be viewed via the `#` command.  In ranged combat, the missile is assumed to be attacking the defender-in melee, using itself as the weapon, but the ranged damage bonus-and the ranged armor modifier are taken into account for calculations.-You may propel any item in your equipment, inventory pack and on the ground-(by default you are offered only the appropriate items; press `?`-to cycle item menu modes). Only items of a few kinds inflict any damage,-but some have other effects, beneficial, detrimental or mixed.+in melee, using itself as the weapon, with the usual dice and damage bonus.+This time, the ranged armor stat of the defender is taken into account+and, additionally, the speed of the missile (based on shape and weight)+figures in the calculation. You may propel any item from your inventory+(by default you are offered only the appropriate items; press `?`to cycle+item menu modes). Only items of a few kinds inflict any damage, but some+have other effects, beneficial, detrimental or mixed. +In-game detailed item descriptions contain melee and ranged damage estimates.+They do not take into account damage from effects and, if bonuses are not+known, they are guessed based on average bonuses for that kind of item.+The displayed figures are rounded, but the game internally keeps track+of minute fractions of HP.+ Whenever the monster's or hero's hit points reach zero, the combatant dies. When the last hero dies, the scenario ends in defeat. @@ -216,16 +261,17 @@ On Winning and Dying -------------------- -You win the scenario if you escape the dungeon alive or, in scenarios with+You win a scenario if you escape the location alive or, in scenarios with no exit locations, if you eliminate all opposition. In the former case,-your score is based on the gold and precious gems you've plundered.-In the latter case, your score is based on the number of turns you spent-overcoming your foes (the quicker the victory, the better; the slower-the demise, the better). Bonus points, based on the number of heroes lost,-are awarded if you win.+your score is based predominantly on the gold and precious gems you've+plundered. In the latter case, your score is most influenced by the number+of turns you spent overcoming your foes (the quicker the victory, the better;+the slower the demise, the better). Bonus points, affected by the number+of heroes lost, are awarded only if you win. The score is heavily+modified by the chosen game difficulty, but not by any other challenges.  When all your heroes fall, you are going to invariably see a new foolhardy-party of adventurers clamoring to be led into the dungeon. They start+party of adventurers clamoring to be led into danger. They start their conquest from a new entrance, with no experience and no equipment, and new, undaunted enemies bar their way. Lead the new hopeful explorers with wisdom and fortitude!

GameDefinition/TieKnot.hs view

@@ -1,7 +1,22 @@ -- | Here the knot of engine code pieces and the game-specific -- content definitions is tied, resulting in an executable game.-module TieKnot ( tieKnot ) where+module TieKnot+  ( tieKnot+  ) where +import Prelude ()++import Game.LambdaHack.Common.Prelude++import qualified System.Random as R++import Game.LambdaHack.Common.ContentDef+import qualified Game.LambdaHack.Common.Kind as Kind+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.SampleImplementation.SampleMonadServer (executorSer)+import Game.LambdaHack.Server+ import qualified Client.UI.Content.KeyKind as Content.KeyKind import qualified Content.CaveKind import qualified Content.ItemKind@@ -9,40 +24,63 @@ import qualified Content.PlaceKind import qualified Content.RuleKind import qualified Content.TileKind-import Game.LambdaHack.Client-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.SampleImplementation.SampleMonadClient (executorCli)-import Game.LambdaHack.SampleImplementation.SampleMonadServer (executorSer)-import Game.LambdaHack.Server  -- | Tie the LambdaHack engine client, server and frontend code -- with the game-specific content definitions, and run the game.+--+-- The action monad types to be used are determined by the 'executorSer'+-- and 'executorCli' calls. If other functions are used in their place+-- the types are different and so the whole pattern of computation+-- is different. Which of the frontends is run inside the UI client+-- depends on the flags supplied when compiling the engine library. tieKnot :: [String] -> IO () tieKnot args = do-  let -- Common content operations, created from content definitions.-      -- Evaluated fully to discover errors ASAP and free memory.-      !copsSlow = Kind.COps+  -- Options for the next game taken from the commandline.+  let sdebug@DebugModeSer{sallClear, sboostRandomItem, sdungeonRng} =+        debugArgs args+  -- This setup ensures the boosting option doesn't affect generating initial+  -- RNG for dungeon, etc., and also, that setting dungeon RNG on commandline+  -- equal to what was generated last time, ensures the same item boost.+  initialGen <- maybe R.getStdGen return sdungeonRng+  let sdebugNxt = sdebug {sdungeonRng = Just initialGen}+      -- Common content operations, created from content definitions.+      -- Evaluated fully to discover errors ASAP and to free memory.+      cotile = Kind.createOps Content.TileKind.cdefs+      boostItem :: ItemKind -> ItemKind+      boostItem i =+        let mainlineLabel (label, _) = label `elem` ["useful", "treasure"]+        in if any mainlineLabel (ifreq i)+           then i { ifreq = ("useful", 10000)+                            : filter (not . mainlineLabel) (ifreq i)+                  , ieffects = delete Unique $ ieffects i+                  }+           else i+      boostList :: [ItemKind] -> [ItemKind]+      boostList l | not sboostRandomItem = l+      boostList [] = []+      boostList l =+        let (r, _) = R.randomR (0, length l - 1) initialGen+        in case splitAt r l of+          (pre, i : post) -> pre ++ boostItem i : post+          _ -> assert `failure` l+      boostedItems = boostList Content.ItemKind.items+      cdefsItem =+        Content.ItemKind.cdefs+          {content = contentFromList+                     $ boostedItems ++ Content.ItemKind.otherItemContent}+      coitem = Kind.createOps cdefsItem+      !cops = Kind.COps         { cocave  = Kind.createOps Content.CaveKind.cdefs-        , coitem  = Kind.createOps Content.ItemKind.cdefs+        , coitem         , comode  = Kind.createOps Content.ModeKind.cdefs         , coplace = Kind.createOps Content.PlaceKind.cdefs         , corule  = Kind.createOps Content.RuleKind.cdefs-        , cotile  = Kind.createOps Content.TileKind.cdefs+        , cotile+        , coTileSpeedup = Tile.speedup sallClear cotile         }-      !copsShared = speedupCOps False copsSlow-      -- Client content operations.-      copsClient = Content.KeyKind.standardKeys-  sdebugNxt <- debugArgs args-  -- Fire up the frontend with the engine fueled by content.-  -- The action monad types to be used are determined by the 'exeSer'-  -- and 'executorCli' calls. If other functions are used in their place-  -- the types are different and so the whole pattern of computation-  -- is different. Which of the frontends is run depends on the flags supplied-  -- when compiling the engine library.-  let exeServer executorUI executorAI =-        executorSer $ loopSer copsShared sdebugNxt executorUI executorAI-  -- Currently a single frontend is started by the server,-  -- instead of each client starting it's own.-  srtFrontend (executorCli . loopUI)-              (executorCli . loopAI)-              copsClient copsShared (sdebugCli sdebugNxt) exeServer+      -- Client content operations containing default keypresses+      -- and command descriptions.+      !copsClient = Content.KeyKind.standardKeys+  -- Wire together game content, the main loops of game clients+  -- and the game server loop.+  executorSer cops copsClient sdebugNxt

GameDefinition/config.ui.default view

@@ -13,10 +13,8 @@ ; or elsewhere.  [extra_commands]-; A handy shorthand with Vi keys-Macro_1 = ("comma", ([CmdItem], Macro "" ["g"])) ; Angband compatibility (accept target)-Macro_2 = ("KP_Insert", ([CmdMeta], Macro "" ["Return"]))+Cmd_2 = ("KP_Insert", ([CmdAim], "", ByAimMode {exploration = Help, aiming = Accept}))  [hero_names] HeroName_0 = ("Haskell Alvin", "he")@@ -30,12 +28,17 @@ [ui] movementViKeys_hjklyubn = False movementLaptopKeys_uk8o79jl = True-; Monospace fonts that have fixed size regardless of boldness (on some OSes)-font = "Terminus,DejaVu Sans Mono,Consolas,Courier New,Liberation Mono,Courier,FreeMono,Monospace normal normal normal normal 14"-;font = "Terminus,DejaVu Sans Mono,Consolas,Courier New,Liberation Mono,Courier,FreeMono,Monospace normal normal normal normal 18"+; Monospace fonts that have fixed size regardless of boldness (on some OSes at least)+gtkFontFamily = "DejaVu Sans Mono,Consolas,Courier New,Liberation Mono,Courier,FreeMono,Monospace"+;sdlFontFile = "Fix15Mono-Bold.woff"+sdlFontFile = "16x16x.fon"+sdlTtfSizeAdd = -2+sdlFonSizeAdd = 1+fontSize = 16 colorIsBold = True ; New historyMax takes effect after removal of savefiles. historyMax = 5000 maxFps = 30 noAnim = False runStopMsgs = False+overrideCmdline = ""

+ GameDefinition/fonts/16x16x.fon view

binary file changed (absent → 9840 bytes)

+ GameDefinition/fonts/8x8x.fon view

binary file changed (absent → 3648 bytes)

+ GameDefinition/fonts/8x8xb.fon view

binary file changed (absent → 3648 bytes)

+ GameDefinition/fonts/Fix15Mono-Bold.woff view

binary file changed (absent → 96748 bytes)

+ GameDefinition/fonts/LICENSE.16x16x view

@@ -0,0 +1,339 @@+                    GNU GENERAL PUBLIC LICENSE+                       Version 2, June 1991++ Copyright (C) 1989, 1991 Free Software Foundation, Inc.,+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++                            Preamble++  The licenses for most software are designed to take away your+freedom to share and change it.  By contrast, the GNU General Public+License is intended to guarantee your freedom to share and change free+software--to make sure the software is free for all its users.  This+General Public License applies to most of the Free Software+Foundation's software and to any other program whose authors commit to+using it.  (Some other Free Software Foundation software is covered by+the GNU Lesser General Public License instead.)  You can apply it to+your programs, too.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+this service if you wish), that you receive source code or can get it+if you want it, that you can change the software or use pieces of it+in new free programs; and that you know you can do these things.++  To protect your rights, we need to make restrictions that forbid+anyone to deny you these rights or to ask you to surrender the rights.+These restrictions translate to certain responsibilities for you if you+distribute copies of the software, or if you modify it.++  For example, if you distribute copies of such a program, whether+gratis or for a fee, you must give the recipients all the rights that+you have.  You must make sure that they, too, receive or can get the+source code.  And you must show them these terms so they know their+rights.++  We protect your rights with two steps: (1) copyright the software, and+(2) offer you this license which gives you legal permission to copy,+distribute and/or modify the software.++  Also, for each author's protection and ours, we want to make certain+that everyone understands that there is no warranty for this free+software.  If the software is modified by someone else and passed on, we+want its recipients to know that what they have is not the original, so+that any problems introduced by others will not reflect on the original+authors' reputations.++  Finally, any free program is threatened constantly by software+patents.  We wish to avoid the danger that redistributors of a free+program will individually obtain patent licenses, in effect making the+program proprietary.  To prevent this, we have made it clear that any+patent must be licensed for everyone's free use or not licensed at all.++  The precise terms and conditions for copying, distribution and+modification follow.++                    GNU GENERAL PUBLIC LICENSE+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++  0. This License applies to any program or other work which contains+a notice placed by the copyright holder saying it may be distributed+under the terms of this General Public License.  The "Program", below,+refers to any such program or work, and a "work based on the Program"+means either the Program or any derivative work under copyright law:+that is to say, a work containing the Program or a portion of it,+either verbatim or with modifications and/or translated into another+language.  (Hereinafter, translation is included without limitation in+the term "modification".)  Each licensee is addressed as "you".++Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope.  The act of+running the Program is not restricted, and the output from the Program+is covered only if its contents constitute a work based on the+Program (independent of having been made by running the Program).+Whether that is true depends on what the Program does.++  1. You may copy and distribute verbatim copies of the Program's+source code as you receive it, in any medium, provided that you+conspicuously and appropriately publish on each copy an appropriate+copyright notice and disclaimer of warranty; keep intact all the+notices that refer to this License and to the absence of any warranty;+and give any other recipients of the Program a copy of this License+along with the Program.++You may charge a fee for the physical act of transferring a copy, and+you may at your option offer warranty protection in exchange for a fee.++  2. You may modify your copy or copies of the Program or any portion+of it, thus forming a work based on the Program, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++    a) You must cause the modified files to carry prominent notices+    stating that you changed the files and the date of any change.++    b) You must cause any work that you distribute or publish, that in+    whole or in part contains or is derived from the Program or any+    part thereof, to be licensed as a whole at no charge to all third+    parties under the terms of this License.++    c) If the modified program normally reads commands interactively+    when run, you must cause it, when started running for such+    interactive use in the most ordinary way, to print or display an+    announcement including an appropriate copyright notice and a+    notice that there is no warranty (or else, saying that you provide+    a warranty) and that users may redistribute the program under+    these conditions, and telling the user how to view a copy of this+    License.  (Exception: if the Program itself is interactive but+    does not normally print such an announcement, your work based on+    the Program is not required to print an announcement.)++These requirements apply to the modified work as a whole.  If+identifiable sections of that work are not derived from the Program,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works.  But when you+distribute the same sections as part of a whole which is a work based+on the Program, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Program.++In addition, mere aggregation of another work not based on the Program+with the Program (or with a work based on the Program) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++  3. You may copy and distribute the Program (or a work based on it,+under Section 2) in object code or executable form under the terms of+Sections 1 and 2 above provided that you also do one of the following:++    a) Accompany it with the complete corresponding machine-readable+    source code, which must be distributed under the terms of Sections+    1 and 2 above on a medium customarily used for software interchange; or,++    b) Accompany it with a written offer, valid for at least three+    years, to give any third party, for a charge no more than your+    cost of physically performing source distribution, a complete+    machine-readable copy of the corresponding source code, to be+    distributed under the terms of Sections 1 and 2 above on a medium+    customarily used for software interchange; or,++    c) Accompany it with the information you received as to the offer+    to distribute corresponding source code.  (This alternative is+    allowed only for noncommercial distribution and only if you+    received the program in object code or executable form with such+    an offer, in accord with Subsection b above.)++The source code for a work means the preferred form of the work for+making modifications to it.  For an executable work, complete source+code means all the source code for all modules it contains, plus any+associated interface definition files, plus the scripts used to+control compilation and installation of the executable.  However, as a+special exception, the source code distributed need not include+anything that is normally distributed (in either source or binary+form) with the major components (compiler, kernel, and so on) of the+operating system on which the executable runs, unless that component+itself accompanies the executable.++If distribution of executable or object code is made by offering+access to copy from a designated place, then offering equivalent+access to copy the source code from the same place counts as+distribution of the source code, even though third parties are not+compelled to copy the source along with the object code.++  4. You may not copy, modify, sublicense, or distribute the Program+except as expressly provided under this License.  Any attempt+otherwise to copy, modify, sublicense or distribute the Program is+void, and will automatically terminate your rights under this License.+However, parties who have received copies, or rights, from you under+this License will not have their licenses terminated so long as such+parties remain in full compliance.++  5. You are not required to accept this License, since you have not+signed it.  However, nothing else grants you permission to modify or+distribute the Program or its derivative works.  These actions are+prohibited by law if you do not accept this License.  Therefore, by+modifying or distributing the Program (or any work based on the+Program), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Program or works based on it.++  6. Each time you redistribute the Program (or any work based on the+Program), the recipient automatically receives a license from the+original licensor to copy, distribute or modify the Program subject to+these terms and conditions.  You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties to+this License.++  7. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Program at all.  For example, if a patent+license would not permit royalty-free redistribution of the Program by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Program.++If any portion of this section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply and the section as a whole is intended to apply in other+circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system, which is+implemented by public license practices.  Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++  8. If the distribution and/or use of the Program is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Program under this License+may add an explicit geographical distribution limitation excluding+those countries, so that distribution is permitted only in or among+countries not thus excluded.  In such case, this License incorporates+the limitation as if written in the body of this License.++  9. The Free Software Foundation may publish revised and/or new versions+of the General Public License from time to time.  Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++Each version is given a distinguishing version number.  If the Program+specifies a version number of this License which applies to it and "any+later version", you have the option of following the terms and conditions+either of that version or of any later version published by the Free+Software Foundation.  If the Program does not specify a version number of+this License, you may choose any version ever published by the Free Software+Foundation.++  10. If you wish to incorporate parts of the Program into other free+programs whose distribution conditions are different, write to the author+to ask for permission.  For software which is copyrighted by the Free+Software Foundation, write to the Free Software Foundation; we sometimes+make exceptions for this.  Our decision will be guided by the two goals+of preserving the free status of all derivatives of our free software and+of promoting the sharing and reuse of software generally.++                            NO WARRANTY++  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,+REPAIR OR CORRECTION.++  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE+POSSIBILITY OF SUCH DAMAGES.++                     END OF TERMS AND CONDITIONS++            How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+convey the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software; you can redistribute it and/or modify+    it under the terms of the GNU General Public License as published by+    the Free Software Foundation; either version 2 of the License, or+    (at your option) any later version.++    This program is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU General Public License for more details.++    You should have received a copy of the GNU General Public License along+    with this program; if not, write to the Free Software Foundation, Inc.,+    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.++Also add information on how to contact you by electronic and paper mail.++If the program is interactive, make it output a short notice like this+when it starts in an interactive mode:++    Gnomovision version 69, Copyright (C) year name of author+    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+    This is free software, and you are welcome to redistribute it+    under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License.  Of course, the commands you use may+be called something other than `show w' and `show c'; they could even be+mouse-clicks or menu items--whatever suits your program.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the program, if+necessary.  Here is a sample; alter the names:++  Yoyodyne, Inc., hereby disclaims all copyright interest in the program+  `Gnomovision' (which makes passes at compilers) written by James Hacker.++  <signature of Ty Coon>, 1 April 1989+  Ty Coon, President of Vice++This General Public License does not permit incorporating your program into+proprietary programs.  If your program is a subroutine library, you may+consider it more useful to permit linking proprietary applications with the+library.  If this is what you want to do, use the GNU Lesser General+Public License instead of this License.

+ GameDefinition/fonts/LICENSE.Fix15Mono-Bold view

@@ -0,0 +1,94 @@+Digitized data copyright (c) 2012-2015, The Mozilla Foundation and Telefonica S.A.
+with Reserved Font Name < Fira >, 
+
+This Font Software is licensed under the SIL Open Font License, Version 1.1.
+This license is copied below, and is also available with a FAQ at:
+http://scripts.sil.org/OFL
+
+
+-----------------------------------------------------------
+SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007
+-----------------------------------------------------------
+
+PREAMBLE
+The goals of the Open Font License (OFL) are to stimulate worldwide
+development of collaborative font projects, to support the font creation
+efforts of academic and linguistic communities, and to provide a free and
+open framework in which fonts may be shared and improved in partnership
+with others.
+
+The OFL allows the licensed fonts to be used, studied, modified and
+redistributed freely as long as they are not sold by themselves. The
+fonts, including any derivative works, can be bundled, embedded, 
+redistributed and/or sold with any software provided that any reserved
+names are not used by derivative works. The fonts and derivatives,
+however, cannot be released under any other type of license. The
+requirement for fonts to remain under this license does not apply
+to any document created using the fonts or their derivatives.
+
+DEFINITIONS
+"Font Software" refers to the set of files released by the Copyright
+Holder(s) under this license and clearly marked as such. This may
+include source files, build scripts and documentation.
+
+"Reserved Font Name" refers to any names specified as such after the
+copyright statement(s).
+
+"Original Version" refers to the collection of Font Software components as
+distributed by the Copyright Holder(s).
+
+"Modified Version" refers to any derivative made by adding to, deleting,
+or substituting -- in part or in whole -- any of the components of the
+Original Version, by changing formats or by porting the Font Software to a
+new environment.
+
+"Author" refers to any designer, engineer, programmer, technical
+writer or other person who contributed to the Font Software.
+
+PERMISSION & CONDITIONS
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of the Font Software, to use, study, copy, merge, embed, modify,
+redistribute, and sell modified and unmodified copies of the Font
+Software, subject to the following conditions:
+
+1) Neither the Font Software nor any of its individual components,
+in Original or Modified Versions, may be sold by itself.
+
+2) Original or Modified Versions of the Font Software may be bundled,
+redistributed and/or sold with any software, provided that each copy
+contains the above copyright notice and this license. These can be
+included either as stand-alone text files, human-readable headers or
+in the appropriate machine-readable metadata fields within text or
+binary files as long as those fields can be easily viewed by the user.
+
+3) No Modified Version of the Font Software may use the Reserved Font
+Name(s) unless explicit written permission is granted by the corresponding
+Copyright Holder. This restriction only applies to the primary font name as
+presented to the users.
+
+4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font
+Software shall not be used to promote, endorse or advertise any
+Modified Version, except to acknowledge the contribution(s) of the
+Copyright Holder(s) and the Author(s) or with their explicit written
+permission.
+
+5) The Font Software, modified or unmodified, in part or in whole,
+must be distributed entirely under this license, and must not be
+distributed under any other license. The requirement for fonts to
+remain under this license does not apply to any document created
+using the Font Software.
+
+TERMINATION
+This license becomes null and void if any of the above conditions are
+not met.
+
+DISCLAIMER
+THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT
+OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE
+COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
+DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM
+OTHER DEALINGS IN THE FONT SOFTWARE.

− GameDefinition/scores

binary file changed (903 → absent bytes)

LICENSE view

@@ -1,5 +1,20 @@-Copyright (c) 2008--2015 Andres Loeh-Copyright (c) 2010--2015 Mikolaj Konarski+Fonts 16x16x.fon, 8x8x.fon and 8x8xb.fon are are taken from+https://github.com/angband/angband, copyrighted by Leon Marrick,+Sheldon Simms III and Nick McConnell and released by them under+GNU GPL version 2. Any further modifications by authors of LambdaHack+are also released under GNU GPL version 2. The licence file is at+GameDefinition/fonts/LICENSE.16x16x++Font Fix15Mono-Bold.woff is a modified version of+https://github.com/mozilla/Fira/blob/master/ttf/FiraMono-Bold.ttf+that is copyright 2012-2015, The Mozilla Foundation and Telefonica S.A.+The modified font is released under the SIL Open Font License, as seen in+GameDefinition/fonts/LICENSE.Fix15Mono-Bold++The whole LambdaHack is licensed under the BSD3 licence, as follows.++Copyright (c) 2008--2017 Andres Loeh+Copyright (c) 2010--2017 Mikolaj Konarski  All rights reserved.

LambdaHack.cabal view

@@ -5,29 +5,37 @@ -- PVP summary:+-+------- breaking API changes --             | | +----- non-breaking API additions --             | | | +--- code changes with no API change-version:       0.5.0.0+version:       0.6.0.0 synopsis:      A game engine library for roguelike dungeon crawlers-description:   LambdaHack is a game engine library for roguelike games+description:   LambdaHack is a Haskell game engine library for roguelike games                of arbitrary theme, size and complexity,-               packaged together with a small example dungeon crawler.+               packaged together with a little example dungeon crawler.+               Try out the browser version of the LambdaHack sample game at+               <https://lambdahack.github.io>+               (It runs fastest on Chrome. Keyboard commands and savefiles+               are supported only on recent enough versions of browsers.+               Mouse should work everywhere.)                .-               <<https://raw.githubusercontent.com/LambdaHack/media/master/screenshot/safari1.png>>+               <<https://raw.githubusercontent.com/LambdaHack/media/master/screenshot/crawl-0.6.0.0-8x8xb.png>>                .                When completed, the engine will let you specify content                to be procedurally generated, define the AI behaviour                on top of the generic content-independent rules-               and compile a ready-to-play game binary, using either-               the supplied or a custom-made main loop.-               Several frontends are available (GTK is the default)+               and compile a ready-to-play game binary,+               using either the supplied or a custom-made main loop.+               Several frontends are available (SDL2 is the default+               for desktop and there is a Javascript browser frontend)                and many other generic engine components are easily overridden,                but the fundamental source of flexibility lies                in the strict and type-safe separation of code from the content                and of clients (human and AI-controlled) from the server.+               .                Please see the changelog file for recent improvements                and the issue tracker for short-term plans. Long term vision                revolves around procedural content generation and includes                in-game content creation, auto-balancing and persistent                content modification based on player behaviour.+               Contributions are welcome.                .                Games known to use the LambdaHack library:                .@@ -48,14 +56,24 @@                when developing the library --- library users are free                to access any modules, since the library authors are in                no position to guess their particular needs.-homepage:      http://github.com/LambdaHack/LambdaHack+homepage:      https://lambdahack.github.io bug-reports:   http://github.com/LambdaHack/LambdaHack/issues license:       BSD3 license-file:  LICENSE-tested-with:   GHC == 7.6, GHC == 7.8, GHC == 7.10-data-files:    GameDefinition/config.ui.default, GameDefinition/scores-               GameDefinition/PLAYING.md, README.md, LICENSE, CREDITS,-               CHANGELOG.md+tested-with:   GHC >= 7.10 && <= 8.2+data-files:    GameDefinition/config.ui.default,+               GameDefinition/fonts/16x16x.fon,+               GameDefinition/fonts/8x8xb.fon,+               GameDefinition/fonts/8x8x.fon,+               GameDefinition/fonts/LICENSE.16x16x,+               GameDefinition/fonts/Fix15Mono-Bold.woff,+               GameDefinition/fonts/LICENSE.Fix15Mono-Bold,+               GameDefinition/PLAYING.md,+               GameDefinition/InGameHelp.txt,+               README.md,+               CHANGELOG.md,+               LICENSE,+               CREDITS extra-source-files: GameDefinition/MainMenu.ascii, Makefile author:        Andres Loeh, Mikolaj Konarski maintainer:    Mikolaj Konarski <mikolaj.konarski@funktory.com>@@ -77,170 +95,181 @@   default:            False   manual:             True -flag expose_internal-  description:        expose internal functions and types, but don't switch on any other release mode options+flag gtk+  description:        switch to the GTK frontend   default:            False   manual:             True +flag sdl+  description:        switch to the SDL2 frontend+  default:            False+  manual:             True+ flag with_expensive_assertions   description:        turn on expensive assertions of well-tested code   default:            False   manual:             True  flag release-  description:        prepare for a release (expose, optimize, etc.)+  description:        prepare for a release (expose internal functions and types, etc.)   default:            True   manual:             True  library   exposed-modules:    Game.LambdaHack.Atomic-                      Game.LambdaHack.Atomic.CmdAtomic,-                      Game.LambdaHack.Atomic.BroadcastAtomicWrite,-                      Game.LambdaHack.Atomic.HandleAtomicWrite,-                      Game.LambdaHack.Atomic.MonadAtomic,-                      Game.LambdaHack.Atomic.MonadStateWrite,-                      Game.LambdaHack.Atomic.PosAtomicRead,-                      Game.LambdaHack.Client,+                      Game.LambdaHack.Atomic.CmdAtomic+                      Game.LambdaHack.Atomic.HandleAtomicWrite+                      Game.LambdaHack.Atomic.MonadAtomic+                      Game.LambdaHack.Atomic.MonadStateWrite+                      Game.LambdaHack.Atomic.PosAtomicRead+                      Game.LambdaHack.Client                       Game.LambdaHack.Client.AI-                      Game.LambdaHack.Client.AI.ConditionClient,-                      Game.LambdaHack.Client.AI.HandleAbilityClient,-                      Game.LambdaHack.Client.AI.PickActorClient-                      Game.LambdaHack.Client.AI.PickTargetClient-                      Game.LambdaHack.Client.AI.Preferences-                      Game.LambdaHack.Client.AI.Strategy,-                      Game.LambdaHack.Client.Bfs,-                      Game.LambdaHack.Client.BfsClient,-                      Game.LambdaHack.Client.CommonClient,-                      Game.LambdaHack.Client.HandleAtomicClient,-                      Game.LambdaHack.Client.HandleResponseClient,-                      Game.LambdaHack.Client.ItemSlot,-                      Game.LambdaHack.Client.Key,-                      Game.LambdaHack.Client.LoopClient,-                      Game.LambdaHack.Client.MonadClient,-                      Game.LambdaHack.Client.ProtocolClient,-                      Game.LambdaHack.Client.State,-                      Game.LambdaHack.Client.UI,-                      Game.LambdaHack.Client.UI.Animation,-                      Game.LambdaHack.Client.UI.Config,+                      Game.LambdaHack.Client.AI.ConditionM+                      Game.LambdaHack.Client.AI.HandleAbilityM+                      Game.LambdaHack.Client.AI.PickActorM+                      Game.LambdaHack.Client.AI.PickTargetM+                      Game.LambdaHack.Client.AI.Strategy+                      Game.LambdaHack.Client.Bfs+                      Game.LambdaHack.Client.BfsM+                      Game.LambdaHack.Client.CommonM+                      Game.LambdaHack.Client.HandleAtomicM+                      Game.LambdaHack.Client.HandleResponseM+                      Game.LambdaHack.Client.LoopM+                      Game.LambdaHack.Client.MonadClient+                      Game.LambdaHack.Client.Preferences+                      Game.LambdaHack.Client.State+                      Game.LambdaHack.Client.UI+                      Game.LambdaHack.Client.UI.ActorUI+                      Game.LambdaHack.Client.UI.Animation+                      Game.LambdaHack.Client.UI.Config                       Game.LambdaHack.Client.UI.Content.KeyKind-                      Game.LambdaHack.Client.UI.DrawClient,-                      Game.LambdaHack.Client.UI.DisplayAtomicClient,-                      Game.LambdaHack.Client.UI.Frontend,-                      Game.LambdaHack.Client.UI.Frontend.Chosen,-                      Game.LambdaHack.Client.UI.Frontend.Std,-                      Game.LambdaHack.Client.UI.HandleHumanGlobalClient,-                      Game.LambdaHack.Client.UI.HandleHumanLocalClient,-                      Game.LambdaHack.Client.UI.HandleHumanClient,-                      Game.LambdaHack.Client.UI.HumanCmd,-                      Game.LambdaHack.Client.UI.InventoryClient,-                      Game.LambdaHack.Client.UI.KeyBindings,-                      Game.LambdaHack.Client.UI.MonadClientUI,-                      Game.LambdaHack.Client.UI.MsgClient,-                      Game.LambdaHack.Client.UI.RunClient,-                      Game.LambdaHack.Client.UI.StartupFrontendClient-                      Game.LambdaHack.Client.UI.WidgetClient,-                      Game.LambdaHack.Common.Ability,-                      Game.LambdaHack.Common.Actor,-                      Game.LambdaHack.Common.ActorState,-                      Game.LambdaHack.Common.ClientOptions,-                      Game.LambdaHack.Common.Color,-                      Game.LambdaHack.Common.ContentDef,-                      Game.LambdaHack.Common.Dice,-                      Game.LambdaHack.Common.EffectDescription,-                      Game.LambdaHack.Common.Faction,-                      Game.LambdaHack.Common.File,-                      Game.LambdaHack.Common.Flavour,-                      Game.LambdaHack.Common.Frequency,-                      Game.LambdaHack.Common.HighScore,-                      Game.LambdaHack.Common.Item,-                      Game.LambdaHack.Common.ItemDescription,-                      Game.LambdaHack.Common.ItemStrongest,-                      Game.LambdaHack.Common.Kind,-                      Game.LambdaHack.Common.Level,-                      Game.LambdaHack.Common.LQueue,-                      Game.LambdaHack.Common.Misc,-                      Game.LambdaHack.Common.MonadStateRead,-                      Game.LambdaHack.Common.Msg,-                      Game.LambdaHack.Common.Perception,-                      Game.LambdaHack.Common.PointArray,-                      Game.LambdaHack.Common.Point,-                      Game.LambdaHack.Common.Random,-                      Game.LambdaHack.Common.RingBuffer,-                      Game.LambdaHack.Common.Save,-                      Game.LambdaHack.Common.Request,-                      Game.LambdaHack.Common.Response,-                      Game.LambdaHack.Common.State,-                      Game.LambdaHack.Common.Thread,-                      Game.LambdaHack.Common.Tile,-                      Game.LambdaHack.Common.Time,-                      Game.LambdaHack.Common.Vector,-                      Game.LambdaHack.Content.CaveKind,-                      Game.LambdaHack.Content.ItemKind,-                      Game.LambdaHack.Content.ModeKind,-                      Game.LambdaHack.Content.PlaceKind,-                      Game.LambdaHack.Content.RuleKind,-                      Game.LambdaHack.Content.TileKind,-                      Game.LambdaHack.SampleImplementation.SampleMonadClient,-                      Game.LambdaHack.SampleImplementation.SampleMonadServer,-                      Game.LambdaHack.Server,-                      Game.LambdaHack.Server.Commandline,-                      Game.LambdaHack.Server.CommonServer,-                      Game.LambdaHack.Server.DebugServer,-                      Game.LambdaHack.Server.DungeonGen,-                      Game.LambdaHack.Server.DungeonGen.Area,-                      Game.LambdaHack.Server.DungeonGen.AreaRnd,-                      Game.LambdaHack.Server.DungeonGen.Cave,-                      Game.LambdaHack.Server.DungeonGen.Place,-                      Game.LambdaHack.Server.EndServer,-                      Game.LambdaHack.Server.Fov,-                      Game.LambdaHack.Server.Fov.Common,-                      Game.LambdaHack.Server.Fov.Digital,-                      Game.LambdaHack.Server.Fov.Permissive,-                      Game.LambdaHack.Server.Fov.Shadow,-                      Game.LambdaHack.Server.HandleEffectServer,-                      Game.LambdaHack.Server.HandleRequestServer,-                      Game.LambdaHack.Server.ItemRev,-                      Game.LambdaHack.Server.ItemServer,-                      Game.LambdaHack.Server.LoopServer,-                      Game.LambdaHack.Server.MonadServer,-                      Game.LambdaHack.Server.PeriodicServer,-                      Game.LambdaHack.Server.ProtocolServer,-                      Game.LambdaHack.Server.StartServer,+                      Game.LambdaHack.Client.UI.DrawM+                      Game.LambdaHack.Client.UI.DisplayAtomicM+                      Game.LambdaHack.Client.UI.EffectDescription+                      Game.LambdaHack.Client.UI.Frame+                      Game.LambdaHack.Client.UI.FrameM+                      Game.LambdaHack.Client.UI.Frontend+                      Game.LambdaHack.Client.UI.Frontend.Chosen+                      Game.LambdaHack.Client.UI.Frontend.Common+                      Game.LambdaHack.Client.UI.Frontend.Teletype+                      Game.LambdaHack.Client.UI.HandleHelperM+                      Game.LambdaHack.Client.UI.HandleHumanGlobalM+                      Game.LambdaHack.Client.UI.HandleHumanLocalM+                      Game.LambdaHack.Client.UI.HandleHumanM+                      Game.LambdaHack.Client.UI.HumanCmd+                      Game.LambdaHack.Client.UI.InventoryM+                      Game.LambdaHack.Client.UI.ItemDescription+                      Game.LambdaHack.Client.UI.ItemSlot+                      Game.LambdaHack.Client.UI.Key+                      Game.LambdaHack.Client.UI.KeyBindings+                      Game.LambdaHack.Client.UI.MonadClientUI+                      Game.LambdaHack.Client.UI.Msg+                      Game.LambdaHack.Client.UI.MsgM+                      Game.LambdaHack.Client.UI.Overlay+                      Game.LambdaHack.Client.UI.OverlayM+                      Game.LambdaHack.Client.UI.RunM+                      Game.LambdaHack.Client.UI.SessionUI+                      Game.LambdaHack.Client.UI.Slideshow+                      Game.LambdaHack.Client.UI.SlideshowM+                      Game.LambdaHack.Common.Ability+                      Game.LambdaHack.Common.Actor+                      Game.LambdaHack.Common.ActorState+                      Game.LambdaHack.Common.ClientOptions+                      Game.LambdaHack.Common.Color+                      Game.LambdaHack.Common.ContentDef+                      Game.LambdaHack.Common.Dice+                      Game.LambdaHack.Common.Faction+                      Game.LambdaHack.Common.File+                      Game.LambdaHack.Common.Flavour+                      Game.LambdaHack.Common.Frequency+                      Game.LambdaHack.Common.HighScore+                      Game.LambdaHack.Common.Item+                      Game.LambdaHack.Common.ItemStrongest+                      Game.LambdaHack.Common.Kind+                      Game.LambdaHack.Common.KindOps+                      Game.LambdaHack.Common.Level+                      Game.LambdaHack.Common.Misc+                      Game.LambdaHack.Common.MonadStateRead+                      Game.LambdaHack.Common.Perception+                      Game.LambdaHack.Common.PointArray+                      Game.LambdaHack.Common.Point+                      Game.LambdaHack.Common.Prelude+                      Game.LambdaHack.Common.Random+                      Game.LambdaHack.Common.RingBuffer+                      Game.LambdaHack.Common.Save+                      Game.LambdaHack.Common.Request+                      Game.LambdaHack.Common.Response+                      Game.LambdaHack.Common.State+                      Game.LambdaHack.Common.Thread+                      Game.LambdaHack.Common.Tile+                      Game.LambdaHack.Common.Time+                      Game.LambdaHack.Common.Vector+                      Game.LambdaHack.Content.CaveKind+                      Game.LambdaHack.Content.ItemKind+                      Game.LambdaHack.Content.ModeKind+                      Game.LambdaHack.Content.PlaceKind+                      Game.LambdaHack.Content.RuleKind+                      Game.LambdaHack.Content.TileKind+                      Game.LambdaHack.SampleImplementation.SampleMonadClient+                      Game.LambdaHack.SampleImplementation.SampleMonadServer+                      Game.LambdaHack.Server+                      Game.LambdaHack.Server.BroadcastAtomic+                      Game.LambdaHack.Server.Commandline+                      Game.LambdaHack.Server.CommonM+                      Game.LambdaHack.Server.DebugM+                      Game.LambdaHack.Server.DungeonGen+                      Game.LambdaHack.Server.DungeonGen.Area+                      Game.LambdaHack.Server.DungeonGen.AreaRnd+                      Game.LambdaHack.Server.DungeonGen.Cave+                      Game.LambdaHack.Server.DungeonGen.Place+                      Game.LambdaHack.Server.EndM+                      Game.LambdaHack.Server.Fov+                      Game.LambdaHack.Server.FovDigital+                      Game.LambdaHack.Server.HandleAtomicM+                      Game.LambdaHack.Server.HandleEffectM+                      Game.LambdaHack.Server.HandleRequestM+                      Game.LambdaHack.Server.ItemRev+                      Game.LambdaHack.Server.ItemM+                      Game.LambdaHack.Server.LoopM+                      Game.LambdaHack.Server.MonadServer+                      Game.LambdaHack.Server.PeriodicM+                      Game.LambdaHack.Server.ProtocolM+                      Game.LambdaHack.Server.StartM                       Game.LambdaHack.Server.State+   other-modules:      Paths_LambdaHack-  build-depends:      array      >= 0.3.0.3 && < 1,-                      assert-failure >= 0.1 && < 1,-                      async      >= 2       && < 3,-                      base       >= 4       && < 5,-                      binary     >= 0.7     && < 1,-                      bytestring >= 0.9.2   && < 1,-                      containers >= 0.5.3.0 && < 1,-                      data-default,-                      deepseq    >= 1.3     && < 2,-                      directory  >= 1.1.0.1 && < 2,-                      enummapset-th >= 0.6.0.0 && < 1,-                      filepath   >= 1.2.0.1 && < 2,-                      ghc-prim   >= 0.2,-                      hashable   >= 1.1.2.5 && < 2,-                      hsini      >= 0.2     && < 2,-                      keys       >= 3       && < 4,-                      miniutter  >= 0.4.4   && < 2,-                      mtl        >= 2.0.1   && < 3,-                      old-time   >= 1.0.0.7 && < 2,-                      pretty-show >= 1.6    && < 2,-                      random     >= 1.1     && < 2,-                      stm        >= 2.4     && < 3,-                      text       >= 0.11.2.3 && < 2,-                      transformers >= 0.3   && < 1,-                      unordered-containers >= 0.2.3 && < 1,-                      vector     >= 0.10    && < 1,-                      vector-binary-instances >= 0.2 && < 1,-                      zlib       >= 0.5.3.1 && < 1+  build-depends:+                      assert-failure >= 0.1,+                      async      >= 2,+                      base       >= 4 && < 99,+                      base-compat >= 0.8.0,+                      binary     >= 0.8,+                      bytestring >= 0.9.2 ,+                      containers >= 0.5.3.0,+                      deepseq    >= 1.3,+                      directory  >= 1.1.0.1,+                      enummapset-th >= 0.6.0.0,+                      filepath   >= 1.2.0.1,+                      ghc-prim,+                      hashable   >= 1.1.2.5,+                      hsini      >= 0.2,+                      keys       >= 3,+                      miniutter  >= 0.4.5.0,+                      time       >= 1.4,+                      pretty-show >= 1.6,+                      random     >= 1.1,+                      stm        >= 2.4,+                      text       >= 0.11.2.3,+                      transformers >= 0.4,+                      unordered-containers >= 0.2.3,+                      vector     >= 0.10,+                      vector-binary-instances >= 0.2.3.1    default-language:   Haskell2010   default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings-                      BangPatterns, RecordWildCards, NamedFieldPuns-  other-extensions:   CPP, TemplateHaskell, MultiParamTypeClasses, RankNTypes,+                      BangPatterns, RecordWildCards, NamedFieldPuns, MultiWayIf,+                      CPP+  other-extensions:   TemplateHaskell, MultiParamTypeClasses, RankNTypes,                       TypeFamilies, FlexibleContexts, FlexibleInstances,                       DeriveFunctor, FunctionalDependencies,                       GeneralizedNewtypeDeriving, TupleSections,@@ -248,43 +277,47 @@                       ExistentialQuantification, GADTs, StandaloneDeriving,                       DataKinds, KindSignatures --, DeriveGeneric-  ghc-options:        -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas-  ghc-options:        -fno-warn-auto-orphans -fno-warn-implicit-prelude-  ghc-options:        -fno-ignore-asserts -funbox-strict-fields-  ghc-prof-options:   -fprof-auto-calls+  ghc-options:        -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-unrecognised-pragmas+  ghc-options:        -fno-warn-implicit-prelude -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively -  if flag(curses) {-    other-modules:    Game.LambdaHack.Client.UI.Frontend.Curses-    build-depends:    hscurses >= 1.4.1 && < 2-    cpp-options:      -DCURSES+  if impl(ghcjs) {+    other-modules:    Game.LambdaHack.Client.UI.Frontend.Dom+    build-depends:    ghcjs-dom >= 0.2+    cpp-options:      -DUSE_BROWSER -DUSE_JSFILE   } else { if flag(vty) {     other-modules:    Game.LambdaHack.Client.UI.Frontend.Vty-    build-depends:    vty >= 5 && < 6-    cpp-options:      -DVTY+    build-depends:    vty >= 5+    cpp-options:      -DUSE_VTY+  } else { if flag(curses) {+    other-modules:    Game.LambdaHack.Client.UI.Frontend.Curses+    build-depends:    hscurses >= 1.4.1+    cpp-options:      -DUSE_CURSES+  } else { if flag(gtk) {+    other-modules:    Game.LambdaHack.Client.UI.Frontend.Gtk+    build-depends:    gtk3 >= 0.12.1+    cpp-options:      -DUSE_GTK+  } else { if flag(sdl) {+    other-modules:    Game.LambdaHack.Client.UI.Frontend.Sdl+    build-depends:    sdl2 >= 2, sdl2-ttf >= 1 && < 2+    cpp-options:      -DUSE_SDL   } else {-    if impl(ghc > 7.8) {-      other-modules:    Game.LambdaHack.Client.UI.Frontend.Gtk-      build-depends:    gtk >= 0.12.1 && < 0.14-      pkgconfig-depends: gtk+-2.0-    } else {-      other-modules:    Game.LambdaHack.Client.UI.Frontend.Gtk-      build-depends:    gtk >= 0.12.1 && < 0.13-      pkgconfig-depends: gtk+-2.0-    }-  } }+    other-modules:    Game.LambdaHack.Client.UI.Frontend.Sdl+    build-depends:    sdl2 >= 2, sdl2-ttf >= 1 && < 2+    cpp-options:      -DUSE_SDL+  } } } } } -  if flag(expose_internal)-    cpp-options:      -DEXPOSE_INTERNAL+  if impl(ghcjs) {+    other-modules:    Game.LambdaHack.Common.JSFile+  } else {+    other-modules:    Game.LambdaHack.Common.HSFile+    build-depends:    zlib >= 0.5.3.1+  }    if flag(with_expensive_assertions)     cpp-options:      -DWITH_EXPENSIVE_ASSERTIONS -  if flag(release) {+  if flag(release)     cpp-options:      -DEXPOSE_INTERNAL--- 7.6.3 has broken -O2, apparently-    if impl(ghc > 7.8)-      ghc-options:      -O2 -fno-ignore-asserts-  }  executable LambdaHack   hs-source-dirs:     GameDefinition@@ -292,6 +325,7 @@   other-modules:      Client.UI.Content.KeyKind,                       Content.CaveKind,                       Content.ItemKind,+                      Content.ItemKindEmbed,                       Content.ItemKindActor,                       Content.ItemKindOrgan,                       Content.ItemKindBlast,@@ -304,95 +338,105 @@                       TieKnot,                       Paths_LambdaHack   build-depends:      LambdaHack,-                      template-haskell >= 2.6 && < 3,+                      template-haskell >= 2.6, -                      array      >= 0.3.0.3 && < 1,-                      assert-failure >= 0.1 && < 1,-                      async      >= 2       && < 3,-                      base       >= 4       && < 5,-                      binary     >= 0.7     && < 1,-                      bytestring >= 0.9.2   && < 1,-                      containers >= 0.5.3.0 && < 1,-                      data-default,-                      deepseq    >= 1.3     && < 2,-                      directory  >= 1.1.0.1 && < 2,-                      enummapset-th >= 0.6.0.0 && < 1,-                      filepath   >= 1.2.0.1 && < 2,-                      ghc-prim   >= 0.2,-                      hashable   >= 1.1.2.5 && < 2,-                      hsini      >= 0.2     && < 2,-                      keys       >= 3       && < 4,-                      miniutter  >= 0.4.4   && < 2,-                      mtl        >= 2.0.1   && < 3,-                      old-time   >= 1.0.0.7 && < 2,-                      pretty-show >= 1.6    && < 2,-                      random     >= 1.1     && < 2,-                      stm        >= 2.4     && < 3,-                      text       >= 0.11.2.3 && < 2,-                      transformers >= 0.3   && < 1,-                      unordered-containers >= 0.2.3 && < 1,-                      vector     >= 0.10    && < 1,-                      vector-binary-instances >= 0.2 && < 1,-                      zlib       >= 0.5.3.1 && < 1+                      assert-failure >= 0.1,+                      async      >= 2,+                      base       >= 4 && < 99,+                      base-compat >= 0.8.0,+                      binary     >= 0.8,+                      bytestring >= 0.9.2 ,+                      containers >= 0.5.3.0,+                      deepseq    >= 1.3,+                      directory  >= 1.1.0.1,+                      enummapset-th >= 0.6.0.0,+                      filepath   >= 1.2.0.1,+                      ghc-prim,+                      hashable   >= 1.1.2.5,+                      hsini      >= 0.2,+                      keys       >= 3,+                      miniutter  >= 0.4.5.0,+                      time       >= 1.4,+                      pretty-show >= 1.6,+                      random     >= 1.1,+                      stm        >= 2.4,+                      text       >= 0.11.2.3,+                      transformers >= 0.4,+                      unordered-containers >= 0.2.3,+                      vector     >= 0.10,+                      vector-binary-instances >= 0.2.3.1    default-language:   Haskell2010   default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings-                      BangPatterns, RecordWildCards, NamedFieldPuns+                      BangPatterns, RecordWildCards, NamedFieldPuns, MultiWayIf   other-extensions:   TemplateHaskell-  ghc-options:        -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas-  ghc-options:        -fno-warn-auto-orphans -fno-warn-implicit-prelude-  ghc-options:        -fno-ignore-asserts -funbox-strict-fields-  ghc-options:        -threaded "-with-rtsopts=-C0.005" -rtsopts+  ghc-options:        -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-unrecognised-pragmas+  ghc-options:        -fno-warn-implicit-prelude -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively+  ghc-options:        -threaded -rtsopts -  if flag(release)-    ghc-options:      -O2 -fno-ignore-asserts "-with-rtsopts=-N1"--- TODO: -N+  if impl(ghcjs) {+-- This is the largest GHCJS_BUSY_YIELD value that does not cause dropped frames+-- on my machine with default --maxFps.+    cpp-options:      -DGHCJS_BUSY_YIELD=50+-- Minimize median lag at the cost of occasional huge lag when GC kicks in+-- (and some of the GCs fit into idle time, while the player ponders+-- or game is being saved):+    ghc-options:      "-with-rtsopts=-A99m"+  } else {+    build-depends:    zlib >= 0.5.3.1+-- The -A options makes it slightly faster, especially with short sessions:+    ghc-options:      "-with-rtsopts=-A99m -K1000K"+-- TODO: get back to -K1K when I can use pretty-1.1.3.4 (TH depends on an old one)+  }  test-suite test   type:               exitcode-stdio-1.0   hs-source-dirs:     GameDefinition, test   main-is:            test.hs   build-depends:      LambdaHack,-                      template-haskell >= 2.6 && < 3,+                      template-haskell >= 2.6, -                      array      >= 0.3.0.3 && < 1,-                      assert-failure >= 0.1 && < 1,-                      async      >= 2       && < 3,-                      base       >= 4       && < 5,-                      binary     >= 0.7     && < 1,-                      bytestring >= 0.9.2   && < 1,-                      containers >= 0.5.3.0 && < 1,-                      data-default,-                      deepseq    >= 1.3     && < 2,-                      directory  >= 1.1.0.1 && < 2,-                      enummapset-th >= 0.6.0.0 && < 1,-                      filepath   >= 1.2.0.1 && < 2,-                      ghc-prim   >= 0.2,-                      hashable   >= 1.1.2.5 && < 2,-                      hsini      >= 0.2     && < 2,-                      keys       >= 3       && < 4,-                      miniutter  >= 0.4.4   && < 2,-                      mtl        >= 2.0.1   && < 3,-                      old-time   >= 1.0.0.7 && < 2,-                      pretty-show >= 1.6    && < 2,-                      random     >= 1.1     && < 2,-                      stm        >= 2.4     && < 3,-                      text       >= 0.11.2.3 && < 2,-                      transformers >= 0.3   && < 1,-                      unordered-containers >= 0.2.3 && < 1,-                      vector     >= 0.10    && < 1,-                      vector-binary-instances >= 0.2 && < 1,-                      zlib       >= 0.5.3.1 && < 1+                      assert-failure >= 0.1,+                      async      >= 2,+                      base       >= 4 && < 99,+                      base-compat >= 0.8.0,+                      binary     >= 0.8,+                      bytestring >= 0.9.2 ,+                      containers >= 0.5.3.0,+                      deepseq    >= 1.3,+                      directory  >= 1.1.0.1,+                      enummapset-th >= 0.6.0.0,+                      filepath   >= 1.2.0.1,+                      ghc-prim,+                      hashable   >= 1.1.2.5,+                      hsini      >= 0.2,+                      keys       >= 3,+                      miniutter  >= 0.4.5.0,+                      time       >= 1.4,+                      pretty-show >= 1.6,+                      random     >= 1.1,+                      stm        >= 2.4,+                      text       >= 0.11.2.3,+                      transformers >= 0.4,+                      unordered-containers >= 0.2.3,+                      vector     >= 0.10,+                      vector-binary-instances >= 0.2.3.1    default-language:   Haskell2010   default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings-                      BangPatterns, RecordWildCards, NamedFieldPuns+                      BangPatterns, RecordWildCards, NamedFieldPuns, MultiWayIf   other-extensions:   TemplateHaskell-  ghc-options:        -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas-  ghc-options:        -fno-warn-auto-orphans -fno-warn-implicit-prelude-  ghc-options:        -fno-ignore-asserts -funbox-strict-fields-  ghc-options:        -threaded "-with-rtsopts=-C0.005" -rtsopts+  ghc-options:        -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-unrecognised-pragmas+  ghc-options:        -fno-warn-implicit-prelude -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively+  ghc-options:        -threaded -rtsopts -  if flag(release)-    ghc-options:      -O2 -fno-ignore-asserts "-with-rtsopts=-N1"--- TODO: -N+  if impl(ghcjs) {+-- This is the largest GHCJS_BUSY_YIELD value that does not cause dropped frames+-- on my machine with default --maxFps.+    cpp-options:      -DGHCJS_BUSY_YIELD=50+    ghc-options:      "-with-rtsopts=-A99m"+  } else {+    build-depends:    zlib >= 0.5.3.1+    ghc-options:      "-with-rtsopts=-A99m -K1000K"+-- get back to -K1K when I can use pretty-1.1.3.4 (TH depends on an old one)+  }

Makefile view

@@ -1,259 +1,192 @@-# All xc* tests assume a profiling build (for stack traces).-# See the install-debug target below.--install-debug:-	cabal install --enable-library-profiling --enable-executable-profiling --ghc-options="-fprof-auto-calls" --disable-optimization+play:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --dumpInitRngs  configure-debug:-	cabal configure --enable-library-profiling --enable-executable-profiling --ghc-options="-fprof-auto-calls" --disable-optimization---xcplay:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --dumpInitRngs--xcfrontendCampaign:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame 1 --maxFps 60 --dumpInitRngs --automateAll --gameMode campaign--xcfrontendRaid:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame 5 --maxFps 60 --dumpInitRngs --automateAll --gameMode raid+	cabal configure --enable-profiling --profiling-detail=all-functions -fwith_expensive_assertions --disable-optimization -xcfrontendSkirmish:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame 5 --maxFps 60 --dumpInitRngs --automateAll --gameMode skirmish+configure-prof:+	cabal configure --enable-profiling --profiling-detail=exported-functions -frelease -xcfrontendAmbush:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame 5 --maxFps 60 --dumpInitRngs --automateAll --gameMode ambush+ghcjs-configure:+	cabal configure --disable-library-profiling --disable-profiling --ghcjs --ghcjs-option=-dedupe -f-release -xcfrontendBattle:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame 2 --maxFps 60 --dumpInitRngs --automateAll --gameMode battle+chrome-prof:+	google-chrome --no-sandbox --js-flags="--logfile=%t.log --prof" ../lambdahack.github.io/index.html -xcfrontendBattleSurvival:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame 8 --maxFps 60 --dumpInitRngs --automateAll --gameMode "battle survival"+minific:+	ccjs dist/build/LambdaHack/LambdaHack.jsexe/all.js --compilation_level=ADVANCED_OPTIMIZATIONS --isolation_mode=IIFE --assume_function_wrapper --jscomp_off="*" --externs=node > ../lambdahack.github.io/lambdahack.all.js -xcfrontendSafari:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame 2 --maxFps 60 --dumpInitRngs --automateAll --gameMode safari+frontendRaid:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode raid -xcfrontendSafariSurvival:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame 8 --maxFps 60 --dumpInitRngs --automateAll --gameMode "safari survival"+frontendBrawl:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode brawl -xcfrontendDefense:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame 9 --maxFps 60 --dumpInitRngs --automateAll --gameMode defense+frontendShootout:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode shootout +frontendEscape:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix test --newGame 3 --dumpInitRngs --automateAll --gameMode escape -play:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --dumpInitRngs+frontendZoo:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix test --newGame 2 --dumpInitRngs --automateAll --gameMode zoo -frontendCampaign:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 1 --maxFps 60 --dumpInitRngs --automateAll --gameMode campaign+frontendAmbush:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode ambush -frontendRaid:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --maxFps 60 --dumpInitRngs --automateAll --gameMode raid+frontendExploration:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix test --newGame 1 --dumpInitRngs --automateAll --gameMode exploration -frontendSkirmish:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --maxFps 60 --dumpInitRngs --automateAll --gameMode skirmish+frontendSafari:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix test --newGame 2 --dumpInitRngs --automateAll --gameMode safari -frontendAmbush:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --maxFps 60 --dumpInitRngs --automateAll --gameMode ambush+frontendSafariSurvival:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode "safari survival"  frontendBattle:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --maxFps 60 --dumpInitRngs --automateAll --gameMode battle+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode battle  frontendBattleSurvival:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 8 --maxFps 60 --dumpInitRngs --automateAll --gameMode "battle survival"--frontendSafari:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --maxFps 60 --dumpInitRngs --automateAll --gameMode safari--frontendSafariSurvival:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 8 --maxFps 60 --dumpInitRngs --automateAll --gameMode "safari survival"+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode "battle survival"  frontendDefense:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 9 --maxFps 60 --dumpInitRngs --automateAll --gameMode defense+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix test --newGame 9 --dumpInitRngs --automateAll --gameMode defense -benchCampaign:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 1 --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 60 --automateAll --keepAutomated --gameMode campaign --setDungeonRng 42 --setMainRng 42 +RTS -N1 -RTS +benchMemoryAnim:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 1 --maxFps 100000 --benchmark --stopAfterFrames 33000 --automateAll --keepAutomated --gameMode exploration --setDungeonRng 120 --setMainRng 47 --frontendNull --noAnim +RTS -s -A1M -RTS+ benchBattle:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 60 --automateAll --keepAutomated --gameMode battle --setDungeonRng 42 --setMainRng 42 +RTS -N1 -RTS+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 3 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 1500 --automateAll --keepAutomated --gameMode battle --setDungeonRng 7 --setMainRng 7 -benchFrontendCampaign:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 1 --maxFps 100000 --benchmark --stopAfter 60 --automateAll --keepAutomated --gameMode campaign --setDungeonRng 42 --setMainRng 42 +RTS -N1 -RTS+benchAnimBattle:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 3 --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 7000 --automateAll --keepAutomated --gameMode battle --setDungeonRng 7 --setMainRng 7  benchFrontendBattle:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --maxFps 100000 --benchmark --stopAfter 60 --automateAll --keepAutomated --gameMode battle --setDungeonRng 42 --setMainRng 42 +RTS -N1 -RTS+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 3 --noAnim --maxFps 100000 --benchmark --stopAfterFrames 1500 --automateAll --keepAutomated --gameMode battle --setDungeonRng 7 --setMainRng 7 -benchNull: benchCampaign benchBattle+benchExploration:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 1 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 7000 --automateAll --keepAutomated --gameMode exploration --setDungeonRng 0 --setMainRng 0 -bench: benchCampaign benchFrontendCampaign benchBattle benchFrontendBattle+benchFrontendExploration:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 1 --noAnim --maxFps 100000 --benchmark --stopAfterFrames 7000 --automateAll --keepAutomated --gameMode exploration --setDungeonRng 0 --setMainRng 0 +benchNull: benchBattle benchAnimBattle benchExploration -test-travis-short: test-short+bench: benchBattle benchAnimBattle benchFrontendBattle benchExploration benchFrontendExploration -test-travis-medium: test-short test-medium+nativeBenchExploration:+	dist/build/LambdaHack/LambdaHack		   --dbgMsgSer --newGame 2 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 2000 --automateAll --keepAutomated --gameMode exploration --setDungeonRng 0 --setMainRng 0 -test-travis-medium-no-safari: test-short test-medium-no-safari+nativeBenchBattle:+	dist/build/LambdaHack/LambdaHack		   --dbgMsgSer --newGame 3 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 1000 --automateAll --keepAutomated --gameMode battle --setDungeonRng 0 --setMainRng 0 -test-travis-long: test-short test-long+nativeBench: nativeBenchBattle nativeBenchExploration -test-travis-long-no-safari: test-short test-long-no-safari+nodeBenchExploration:+	node dist/build/LambdaHack/LambdaHack.jsexe/all.js --dbgMsgSer --newGame 2 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 2000 --automateAll --keepAutomated --gameMode exploration --setDungeonRng 0 --setMainRng 0 -test: test-short test-medium test-long+nodeBenchBattle:+	node dist/build/LambdaHack/LambdaHack.jsexe/all.js --dbgMsgSer --newGame 3 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 1000 --automateAll --keepAutomated --gameMode battle --setDungeonRng 0 --setMainRng 0 -test-short: test-short-new test-short-load+nodeBench: nodeBenchBattle nodeBenchExploration -test-medium: testCampaign-medium testRaid-medium testSkirmish-medium testAmbush-medium testBattle-medium testBattleSurvival-medium testSafari-medium testSafariSurvival-medium testPvP-medium testCoop-medium testDefense-medium -test-medium-no-safari: testCampaign-medium testRaid-medium testSkirmish-medium testAmbush-medium testBattle-medium testBattleSurvival-medium testPvP-medium testCoop-medium testDefense-medium--test-long: testCampaign-long testRaid-medium testSkirmish-medium testAmbush-medium testBattle-long testBattleSurvival-long testSafari-long testSafariSurvival-long testPvP-medium testDefense-long+test-travis-short: test-short -test-long-no-safari: testCampaign-long testRaid-medium testSkirmish-medium testAmbush-medium testBattle-long testBattleSurvival-long testPvP-medium testDefense-long+test-travis: test-short test-medium benchNull -testCampaign-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 1 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 500 --dumpInitRngs --automateAll --keepAutomated --gameMode campaign > /tmp/stdtest.log+test: test-short test-medium benchNull -testCampaign-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 1 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --keepAutomated --gameMode campaign > /tmp/stdtest.log+test-short: test-short-new test-short-load -testRaid-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --keepAutomated --gameMode raid > /tmp/stdtest.log+test-medium: testRaid-medium testBrawl-medium testShootout-medium testEscape-medium testZoo-medium testAmbush-medium testExploration-medium testSafari-medium testSafariSurvival-medium testBattle-medium testBattleSurvival-medium  testRaid-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --keepAutomated --gameMode raid > /tmp/stdtest.log--testSkirmish-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --keepAutomated --gameMode skirmish > /tmp/stdtest.log--testSkirmish-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --keepAutomated --gameMode skirmish > /tmp/stdtest.log--testAmbush-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --keepAutomated --gameMode ambush > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 20 --dumpInitRngs --automateAll --keepAutomated --gameMode raid 2> /tmp/teletypetest.log -testAmbush-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --keepAutomated --gameMode ambush > /tmp/stdtest.log+testBrawl-medium:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 20 --dumpInitRngs --automateAll --keepAutomated --gameMode brawl 2> /tmp/teletypetest.log -testBattle-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 100 --dumpInitRngs --automateAll --keepAutomated --gameMode battle > /tmp/stdtest.log+testShootout-medium:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 20 --dumpInitRngs --automateAll --keepAutomated --gameMode shootout 2> /tmp/teletypetest.log -testBattle-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 50 --dumpInitRngs --automateAll --keepAutomated --gameMode battle > /tmp/stdtest.log+testEscape-medium:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 3 --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 40 --dumpInitRngs --automateAll --keepAutomated --gameMode escape 2> /tmp/teletypetest.log -testBattleSurvival-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 8 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 100 --dumpInitRngs --automateAll --keepAutomated --gameMode "battle survival" > /tmp/stdtest.log+testZoo-medium:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 2 --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 100 --dumpInitRngs --automateAll --keepAutomated --gameMode zoo 2> /tmp/teletypetest.log -testBattleSurvival-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 8 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 50 --dumpInitRngs --automateAll --keepAutomated --gameMode "battle survival" > /tmp/stdtest.log+testAmbush-medium:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 20 --dumpInitRngs --automateAll --keepAutomated --gameMode ambush 2> /tmp/teletypetest.log -testSafari-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --keepAutomated --gameMode safari > /tmp/stdtest.log+testExploration-medium:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 1 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 200 --dumpInitRngs --automateAll --keepAutomated --gameMode exploration 2> /tmp/teletypetest.log  testSafari-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 200 --dumpInitRngs --automateAll --keepAutomated --gameMode safari > /tmp/stdtest.log--testSafariSurvival-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 8 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --keepAutomated --gameMode "safari survival" > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 2 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 100 --dumpInitRngs --automateAll --keepAutomated --gameMode safari 2> /tmp/teletypetest.log  testSafariSurvival-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 8 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 200 --dumpInitRngs --automateAll --keepAutomated --gameMode "safari survival" > /tmp/stdtest.log---testPvP-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --keepAutomated --gameMode PvP > /tmp/stdtest.log--testPvP-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 5 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --keepAutomated --gameMode PvP > /tmp/stdtest.log--testCoop-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 500 --dumpInitRngs --automateAll --keepAutomated --gameMode Coop > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 8 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 60 --dumpInitRngs --automateAll --keepAutomated --gameMode "safari survival" 2> /tmp/teletypetest.log -testCoop-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 300 --dumpInitRngs --automateAll --keepAutomated --gameMode Coop > /tmp/stdtest.log+testBattle-medium:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 3 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 20 --dumpInitRngs --automateAll --keepAutomated --gameMode battle 2> /tmp/teletypetest.log -testDefense-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 9 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 500 --dumpInitRngs --automateAll --keepAutomated --gameMode defense > /tmp/stdtest.log+testBattleSurvival-medium:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 7 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 60 --dumpInitRngs --automateAll --keepAutomated --gameMode "battle survival" 2> /tmp/teletypetest.log  testDefense-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 9 --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 300 --dumpInitRngs --automateAll --keepAutomated --gameMode defense > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 9 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 500 --dumpInitRngs --automateAll --keepAutomated --gameMode defense 2> /tmp/teletypetest.log  test-short-new:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix campaign --dumpInitRngs --automateAll --keepAutomated --gameMode campaign --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix raid --dumpInitRngs --automateAll --keepAutomated --gameMode raid --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix skirmish --dumpInitRngs --automateAll --keepAutomated --gameMode skirmish --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix ambush --dumpInitRngs --automateAll --keepAutomated --gameMode ambush --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix battle --dumpInitRngs --automateAll --keepAutomated --gameMode battle --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix battleSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "battle survival" --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix safari --dumpInitRngs --automateAll --keepAutomated --gameMode safari --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix safariSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "safari survival" --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix PvP --dumpInitRngs --automateAll --keepAutomated --gameMode PvP --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix Coop --dumpInitRngs --automateAll --keepAutomated --gameMode Coop --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 5 --savePrefix defense --dumpInitRngs --automateAll --keepAutomated --gameMode defense --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --savePrefix raid --dumpInitRngs --automateAll --keepAutomated --gameMode raid --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --savePrefix brawl --dumpInitRngs --automateAll --keepAutomated --gameMode brawl --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --savePrefix shootout --dumpInitRngs --automateAll --keepAutomated --gameMode shootout --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --savePrefix escape --dumpInitRngs --automateAll --keepAutomated --gameMode escape --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --savePrefix zoo --dumpInitRngs --automateAll --keepAutomated --gameMode zoo --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --savePrefix ambush --dumpInitRngs --automateAll --keepAutomated --gameMode ambush --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --savePrefix exploration --dumpInitRngs --automateAll --keepAutomated --gameMode exploration --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --savePrefix safari --dumpInitRngs --automateAll --keepAutomated --gameMode safari --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --savePrefix safariSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "safari survival" --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --savePrefix battle --dumpInitRngs --automateAll --keepAutomated --gameMode battle --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --savePrefix battleSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "battle survival" --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log +# "--setDungeonRng 0 --setMainRng 0" is needed for determinism relative to seed+# generated before game save test-short-load:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix campaign --dumpInitRngs --automateAll --keepAutomated --gameMode campaign --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix raid --dumpInitRngs --automateAll --keepAutomated --gameMode raid --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix skirmish --dumpInitRngs --automateAll --keepAutomated --gameMode skirmish --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix ambush --dumpInitRngs --automateAll --keepAutomated --gameMode ambush --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix battle --dumpInitRngs --automateAll --keepAutomated --gameMode battle --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix battleSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "battle survival" --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix safari --dumpInitRngs --automateAll --keepAutomated --gameMode safari --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix safariSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "safari survival" --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix PvP --dumpInitRngs --automateAll --keepAutomated --gameMode PvP --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix Coop --dumpInitRngs --automateAll --keepAutomated --gameMode Coop --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix defense --dumpInitRngs --automateAll --keepAutomated --gameMode defense --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix raid --dumpInitRngs --automateAll --keepAutomated --gameMode raid --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix brawl --dumpInitRngs --automateAll --keepAutomated --gameMode brawl --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix shootout --dumpInitRngs --automateAll --keepAutomated --gameMode shootouti --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix escape --dumpInitRngs --automateAll --keepAutomated --gameMode escape --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix zoo --dumpInitRngs --automateAll --keepAutomated --gameMode zoo --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix ambush --dumpInitRngs --automateAll --keepAutomated --gameMode ambush --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix exploration --dumpInitRngs --automateAll --keepAutomated --gameMode exploration --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix safari --dumpInitRngs --automateAll --keepAutomated --gameMode safari --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix safariSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "safari survival" --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix battle --dumpInitRngs --automateAll --keepAutomated --gameMode battle --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix battleSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "battle survival" --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log  -build-binary:-	cabal configure -frelease --prefix=/-	cabal build exe:LambdaHack-	rm -rf /tmp/LambdaHack_x_ubuntu-12.04-amd64.tar.gz-	rm -rf /tmp/LambdaHackTheGameInstall-	rm -rf /tmp/LambdaHackTheGame-	mkdir -p /tmp/LambdaHackTheGame/GameDefinition-	cabal copy --destdir=/tmp/LambdaHackTheGameInstall-	cp /tmp/LambdaHackTheGameInstall/bin/LambdaHack /tmp/LambdaHackTheGame-	cp GameDefinition/PLAYING.md /tmp/LambdaHackTheGame/GameDefinition-	cp GameDefinition/scores /tmp/LambdaHackTheGame/GameDefinition-	cp GameDefinition/config.ui.default /tmp/LambdaHackTheGame/GameDefinition-	cp CHANGELOG.md /tmp/LambdaHackTheGame-	cp CREDITS /tmp/LambdaHackTheGame-	cp LICENSE /tmp/LambdaHackTheGame-	cp README.md /tmp/LambdaHackTheGame-	tar -czf /tmp/LambdaHack_x_ubuntu-12.04-amd64.tar.gz -C /tmp LambdaHackTheGame--build-binary-i386:-	cabal configure -frelease --prefix=/ --ghc-option="-optc-m32" --ghc-option="-opta-m32" --ghc-option="-optl-m32" --ld-option="-melf_i386"+build-binary-common:+	cabal install --disable-library-profiling --disable-profiling --disable-documentation -f-release --only-dependencies+	cabal configure --disable-library-profiling --disable-profiling -f-release --prefix=/ --datadir=. --datasubdir=. 	cabal build exe:LambdaHack-	rm -rf /tmp/LambdaHack_x_ubuntu-12.04-i386.tar.gz-	rm -rf /tmp/LambdaHackTheGameInstall-	rm -rf /tmp/LambdaHackTheGame-	mkdir -p /tmp/LambdaHackTheGame/GameDefinition-	cabal copy --destdir=/tmp/LambdaHackTheGameInstall-	cp /tmp/LambdaHackTheGameInstall/bin/LambdaHack /tmp/LambdaHackTheGame-	cp GameDefinition/PLAYING.md /tmp/LambdaHackTheGame/GameDefinition-	cp GameDefinition/scores /tmp/LambdaHackTheGame/GameDefinition-	cp GameDefinition/config.ui.default /tmp/LambdaHackTheGame/GameDefinition-	cp CHANGELOG.md /tmp/LambdaHackTheGame-	cp CREDITS /tmp/LambdaHackTheGame-	cp LICENSE /tmp/LambdaHackTheGame-	cp README.md /tmp/LambdaHackTheGame-	tar -czf /tmp/LambdaHack_x_ubuntu-12.04-i386.tar.gz -C /tmp LambdaHackTheGame+	mkdir -p LambdaHackTheGame/GameDefinition/fonts+	cabal copy --destdir=LambdaHackTheGameInstall+	cp GameDefinition/config.ui.default LambdaHackTheGame/GameDefinition+	cp GameDefinition/fonts/16x16x.fon LambdaHackTheGame/GameDefinition/fonts+	cp GameDefinition/fonts/8x8xb.fon LambdaHackTheGame/GameDefinition/fonts+	cp GameDefinition/fonts/8x8x.fon LambdaHackTheGame/GameDefinition/fonts+	cp GameDefinition/fonts/LICENSE.16x16x LambdaHackTheGame/GameDefinition/fonts+	cp GameDefinition/fonts/Fix15Mono-Bold.woff LambdaHackTheGame/GameDefinition/fonts+	cp GameDefinition/fonts/LICENSE.Fix15Mono-Bold LambdaHackTheGame/GameDefinition/fonts+	cp GameDefinition/PLAYING.md LambdaHackTheGame/GameDefinition+	cp GameDefinition/InGameHelp.txt LambdaHackTheGame/GameDefinition+	cp README.md LambdaHackTheGame+	cp CHANGELOG.md LambdaHackTheGame+	cp LICENSE LambdaHackTheGame+	cp CREDITS LambdaHackTheGame -# TODO: figure out, whey this must be so different from Linux-build-binary-windows-i386:-	wine cabal configure -frelease-	wine cabal build exe:LambdaHack-	rm -rf /tmp/LambdaHack_x_windows-i386.zip-	rm -rf /tmp/LambdaHackTheGameInstall-	rm -rf /tmp/LambdaHackTheGame-	mkdir -p /tmp/LambdaHackTheGame/GameDefinition-	wine cabal copy --destdir=Z:/tmp/LambdaHackTheGameInstall-	cp /tmp/LambdaHackTheGameInstall/users/mikolaj/Application\ Data/cabal/bin/LambdaHack.exe /tmp/LambdaHackTheGame-	cp GameDefinition/PLAYING.md /tmp/LambdaHackTheGame/GameDefinition-	cp GameDefinition/scores /tmp/LambdaHackTheGame/GameDefinition-	cp GameDefinition/config.ui.default /tmp/LambdaHackTheGame/GameDefinition-	cp CHANGELOG.md /tmp/LambdaHackTheGame-	cp CREDITS /tmp/LambdaHackTheGame-	cp LICENSE /tmp/LambdaHackTheGame-	cp README.md /tmp/LambdaHackTheGame-	cp /home/mikolaj/.wine/drive_c/users/mikolaj/gtk/bin/zlib1.dll /tmp/LambdaHackTheGame-	wine Z:/home/mikolaj/.local/share/wineprefixes/7zip/drive_c/Program\ Files/7-Zip/7z.exe a -ssc -sfx Z:/tmp/LambdaHack_x_windows-i386.exe Z:/tmp/LambdaHackTheGame+build-binary: build-binary-common+	cp LambdaHackTheGameInstall/bin/LambdaHack LambdaHackTheGame+	tar -czf LambdaHack_x_ubuntu-16.04-amd64.tar.gz LambdaHackTheGame

README.md view

@@ -1,142 +1,192 @@-LambdaHack [![Build Status](https://travis-ci.org/LambdaHack/LambdaHack.svg?branch=master)](https://travis-ci.org/LambdaHack/LambdaHack)[![Build Status](https://drone.io/github.com/LambdaHack/LambdaHack/status.png)](https://drone.io/github.com/LambdaHack/LambdaHack/latest)+LambdaHack ========== -LambdaHack is a [Haskell] [1] game engine library for [roguelike] [2]-games of arbitrary theme, size and complexity. You specify the content-to be procedurally generated, including game rules and AI behaviour.-The library lets you compile a ready-to-play game binary, using either-the supplied or a custom-made main loop. Several frontends are available-(GTK is the default) and many other generic engine components-are easily overridden, but the fundamental source of flexibility lies-in the strict and type-safe separation of code and content and of clients-(human and AI-controlled) and server. Long-term goals for LambdaHack include-support for multiplayer tactical squad combat, in-game content creation,-auto-balancing and persistent content modification based on player behaviour.+[![Build Status](https://travis-ci.org/LambdaHack/LambdaHack.svg?branch=master)](https://travis-ci.org/LambdaHack/LambdaHack)+[![Hackage](https://img.shields.io/hackage/v/LambdaHack.svg)](https://hackage.haskell.org/package/LambdaHack)+[![Join the chat at https://gitter.im/LambdaHack/LambdaHack](https://badges.gitter.im/LambdaHack/LambdaHack.svg)](https://gitter.im/LambdaHack/LambdaHack?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) -The engine comes with a sample code for a little dungeon crawler,-called LambdaHack and described in [PLAYING.md](GameDefinition/PLAYING.md).+LambdaHack is a Haskell[1] game engine library for roguelike[2] games+of arbitrary theme, size and complexity,+packaged together with a little sample dungeon crawler.+Try out the browser version of the LambdaHack sample game at+[https://lambdahack.github.io](https://lambdahack.github.io)!+(It runs fastest on Chrome. Keyboard commands and savefiles+are supported only on recent enough versions of browsers.+Mouse should work everywhere.) -![gameplay screenshot](https://raw.githubusercontent.com/LambdaHack/media/master/screenshot/raid1.png)+![gameplay screenshot](https://raw.githubusercontent.com/LambdaHack/media/master/screenshot/crawl-0.6.0.0-8x8xb.png) +To use the engine, you need to specify the content to be+procedurally generated, including game rules and AI behaviour.+The library lets you compile a ready-to-play game binary,+using either the supplied or a custom-made main loop.+Several frontends are available (SDL2 is the default+for desktop and there is a Javascript browser frontend)+and many other generic engine components are easily overridden,+but the fundamental source of flexibility lies+in the strict and type-safe separation of code from the content+and of clients (human and AI-controlled) from the server.++Please see the changelog file for recent improvements+and the issue tracker for short-term plans. Long term vision+revolves around procedural content generation and includes+in-game content creation, auto-balancing and persistent+content modification based on player behaviour.+Contributions are welcome.+ Other games known to use the LambdaHack library: -* [Allure of the Stars] [6], a near-future Sci-Fi game-* [Space Privateers] [8], an adventure game set in far future+* Allure of the Stars[6], a near-future Sci-Fi game+* Space Privateers[8], an adventure game set in far future  Note: the engine and the example game are bundled together in a single-[Hackage] [3] package released under the permissive `BSD3` license.+Hackage[3] package released under the permissive `BSD3` license. You are welcome to create your own games by forking and modifying the single package, but please consider eventually splitting your changes into a separate content-only package that depends on the upstream engine library. This will help us exchange ideas and share improvements to the common codebase. Alternatively, you can already start the development-in separation by cloning and rewriting [Allure of the Stars] [10]-or any other pure game content package and mix and merge with the example-LambdaHack game rules at will. Note that the LambdaHack sample game-derives from the [Hack/Nethack visual and narrative tradition] [9],-while Allure of the Stars uses the more free-form Moria/Angband style-(it also uses the `AGPL` license, and `BSD3 + AGPL = AGPL`,+in separation by cloning and rewriting Allure of the Stars[10]+and mix and merge with the example LambdaHack game rules at will.+Note that the LambdaHack sample game derives from the Hack/Nethack visual+and narrative tradition[9], while Allure of the Stars uses the more free-form+Moria/Angband style (it also uses the `AGPL` license, and `BSD3 + AGPL = AGPL`, so make sure you want to liberate your code and content to such an extent). +When creating a new game based on LambdaHack I've found it useful to place+completely new content at the end of the content files to distinguish from+merely modified original LambdaHack content and thus help merging with new+releases. Removals of LambdaHack content merge reasonably well, so there are+no special considerations. When modifying individual content items,+it makes sense to keep their Haskell identifier names and change only+in-game names and possibly frequency group names. -Installation from binary archives---------------------------------- -Pre-compiled game binaries for some platforms are available through-the [release page] [11] and from the [Nix Packages Collection] [12].-To manually install a binary archive, make sure you have the GTK-libraries suite on your system, unpack the LambdaHack archive-and run the executable in the unpacked directory.+Installation of the sample game from binary archives+---------------------------------------------------- -On Windows, if you don't already have GTK installed (e.g., for the GIMP-picture editor) please download and run (with default settings)-the GTK installer from+The game runs rather slowly in the browser (fastest on Chrome)+and you are limited to only one font, though it's scalable.+Keyboard input and saving game progress requires recent enough+version of a browser (but mouse input is enough to play the game).+Also, savefiles are prone to corruption on the browser,+e.g., when it's closed while the game is still saving progress+(which takes a long time). Hence, after trying out the game,+you may prefer to use a native binary for your architecture, if it exists. -http://sourceforge.net/projects/gtk-win/+Pre-compiled game binaries for some platforms are available through+the release page[11] and from the Nix Packages Collection[12] (Linux)+and AppVeyor (Windows 32bit[17] and Windows 64bit[18]; note that these+no longer work on Windows XP, since Cygwin and MSYS2 dropped support for XP;+they may also be broken in other ways; feedback and help appreciated).+To use a pre-compiled binary archive, unpack it and run the executable+in the unpacked directory. +On Linux, make sure you have the SDL2 libraries suite installed on your system+(e.g., libsdl2, libsdl2-ttf). For Windows, the SDL2 and all other needed+libraries are already contained in the game's binary archive. + Screen and keyboard configuration ---------------------------------  The game UI can be configured via a config file.-A file with the default settings, the same as built into the binary, is in-[GameDefinition/config.ui.default](GameDefinition/config.ui.default).-When the game is run for the first time, the file is copied to the official-location, which is `~/.LambdaHack/config.ui.ini` on Linux and-`C:\Users\<username>\AppData\Roaming\LambdaHack\config.ui.ini`-(or `C:\Documents And Settings\user\Application Data\LambdaHack\config.ui.ini`-or something else altogether) on Windows.+A file with the default settings, the same that is built into the binary,+is in [GameDefinition/config.ui.default](https://github.com/LambdaHack/LambdaHack/blob/master/GameDefinition/config.ui.default).+When the game is run for the first time, the file is copied to the default+user data folder, which is `~/.LambdaHack/` on Linux,+`C:\Users\<username>\AppData\Roaming\LambdaHack\`+(or `C:\Documents And Settings\user\Application Data\LambdaHack\`+or something else altogether) on Windows, and in RMB menu, under+`Inspect/Application/Local Storage` when run inside the Chrome browser. -Screen font can be changed and enlarged by editing the config file-at its official location or by CTRL-right-clicking on the game window.+Screen font can be changed by editing the config file in the user+data folder. For a small game window, the highly optimized+bitmap fonts 16x16x.fon, 8x8x.fon and 8x8xb.fon are the best,+but for larger window sizes or if you require international characters+(e.g. to give custom names to player characters), a modern scalable font+supplied with the game is the only option. The game window automatically+scales according to the specified font size. Display on SDL2+and in the browser is superior to all the other frontends,+due to custom square font and less intrusive ways of highlighting+interesting squares. -If you use the numeric keypad, use the NumLock key on your keyboard-to toggle the game keyboard mode. With NumLock off, you walk with the numeric-keys and run with SHIFT (or CONTROL) and the keys. This mode is probably-the best if you use mouse for running. When you turn NumLock on,-the reversed key setup enforces good playing habits by setting as the default-the run command (which automatically stops at threats, keeping you safe)-and requiring SHIFT (or CONTROL) for the error-prone step by step walking.+If you don't have a numeric keypad, you can use mouse or laptop keys+(uk8o79jl) for movement or you can enable the Vi keys (aka roguelike keys)+in the config file. If numeric keypad doesn't work, toggling+the Num Lock key sometimes helps. If running with the Shift key+and keypad keys doesn't work, try Control key instead.+The game is fully playable with mouse only, as well as with keyboard only,+but the most efficient combination for some players is mouse for go-to,+inspecting, and aiming at distant positions and keyboard for everything else. -If you don't have the numeric keypad, you can use laptop keys (uk8o79jl)-or you can enable the Vi keys (aka roguelike keys) in the config file.+If you are using a terminal frontend, numeric keypad may not work+correctly depending on versions of the libraries, terminfo and terminal+emulators. Toggling the Num Lock key may help.+The curses frontend is not fully supported due to the limitations+of the curses library. With the vty frontend started in an xterm,+Control-keypad keys for running seem to work OK, but on rxvt they do not.+The commands that require pressing Control and Shift together won't+work either, but fortunately they are not crucial to gameplay.  -Compilation from source------------------------+Compilation of the library and sample game from source+------------------------------------------------------ -If you want to compile your own binaries from the source code,+If you want to compile native binaries from the source code, use Cabal (already a part of your OS distribution, or available within-[The Haskell Platform] [7]), which also takes care of all the dependencies.-You also need the GTK libraries for your OS. On Linux, remember to install-the -dev versions as well. On Windows follow [the same steps as for Wine] [13].-On OSX, if you encounter problems, you may want to-[compile the GTK libraries from sources] [14].+The Haskell Platform[7]), which also takes care of all the dependencies. -The latest official version of the library can be downloaded,-compiled and installed automatically by Cabal from [Hackage] [3] as follows+The recommended frontend is based on SDL2, so you need the SDL2 libraries+for your OS. On Linux, remember to install the -dev versions as well,+e.g., libsdl2-dev and libsdl2-ttf-dev on Ubuntu Linux 16.04.+(Compilation to Javascript for the browser is more complicated+and requires the ghcjs[15] compiler and optionally the Google Closure+Compiler[16] as well. See the+[Makefile](https://github.com/LambdaHack/LambdaHack/blob/master/Makefile)+for more details.) +The latest official version of the LambdaHack library can be downloaded,+compiled for SDL2 and installed automatically by Cabal from Hackage[3]+as follows+     cabal update-    cabal install gtk2hs-buildtools-    cabal install LambdaHack --force-reinstalls+    cabal install LambdaHack -For a newer snapshot, download source from a development branch-at [github] [5] and run Cabal from the main directory+For a newer snapshot, download the source code from github[5]+and run Cabal from the main directory -    cabal install gtk2hs-buildtools-    cabal install --force-reinstalls+    cabal install -For the example game, the best frontend (wrt keyboard support and colours)-is the default gtk. To compile with one of the terminal frontends,+There is a built-in line terminal frontend, suitable for teletype terminals+or a keyboard and a printer (but it's going to use a lot of paper,+unless you disable animations with `--noAnim`). To compile with+one of the less rudimentary terminal frontends (in which case you are+on your own regarding font choice and color setup and you won't have+the spiffy colorful squares around special positions, only crude highlights), use Cabal flags, e.g, -    cabal install -fvty --force-reinstalls-+    cabal install -fvty -Compatibility notes--------------------+To compile with GTK2 (deprecated but still supported; beware that+the font is not square and special position highlights are annoying),+you need GTK libraries for your OS. On Windows follow the same steps+as for Wine[13]. On OSX, if you encounter problems, you may want to+compile the GTK libraries from sources[14]. Invoke Cabal as follows -If you are using a terminal frontend, numeric keypad may not work-correctly depending on versions of the libraries, terminfo and terminal-emulators. The curses frontend is not fully supported due to the limitations-of the curses library. With the vty frontend started in an xterm,-CTRL-keypad keys for running seem to work OK, but on rxvt they do not.-The commands that require pressing CTRL and SHIFT together won't-work either, but fortunately they are not crucial to gameplay.-For movement, laptop (uk8o79jl) and Vi keys (hjklyubn, if enabled-in config.ui.ini) should work everywhere. GTK works fine, too, both-with numeric keypad and with mouse.+    cabal install -fgtk gtk2hs-buildtools .   Testing and debugging --------------------- -The [Makefile](Makefile) contains many sample test commands.+The [Makefile](https://github.com/LambdaHack/LambdaHack/blob/master/Makefile)+contains many sample test commands. Numerous tests that use the screensaver game modes (AI vs. AI)-and the dumb `stdout` frontend are gathered in `make test`.-Of these, travis runs `test-travis-*` on each push to the repo.+and the teletype frontend are gathered in `make test`.+Of these, travis runs `test-travis` on each push to github. Test commands with prefix `frontend` start AI vs. AI games-with the standard, user-friendly gtk frontend.+with the standard, user-friendly frontend.  Run `LambdaHack --help` to see a brief description of all debug options. Of these, `--sniffIn` and `--sniffOut` are very useful (though verbose@@ -146,9 +196,7 @@ merged at some point).  You can use HPC with the game as follows (details vary according-to HPC version). A quick manual playing session-after the automated tests would be in order, as well, since the tests don't-touch the topmost UI layer.+to HPC version).      cabal clean     cabal install --enable-coverage@@ -156,17 +204,20 @@     hpc report --hpcdir=dist/hpc/dyn/mix/LambdaHack --hpcdir=dist/hpc/dyn/mix/LambdaHack-xxx/ LambdaHack     hpc markup --hpcdir=dist/hpc/dyn/mix/LambdaHack --hpcdir=dist/hpc/dyn/mix/LambdaHack-xxx/ LambdaHack -Note that debug option `--stopAfter` is required to cleanly terminate-any automated test. This is needed to gather any HPC info, because HPC-requires a clean exit to save data files.+A quick manual playing session after the automated tests would be in order,+as well, since the tests don't touch the topmost UI layer.+Note that a debug option of the form `--stopAfter*` is required to cleanly+terminate any automated test. This is needed to gather any HPC info,+because HPC requires a clean exit to save data files.   Further information ------------------- -For more information, visit the [wiki] [4]-and see [PLAYING.md](GameDefinition/PLAYING.md), [CREDITS](CREDITS)-and [LICENSE](LICENSE).+For more information, visit the wiki[4]+and see [PLAYING.md](https://github.com/LambdaHack/LambdaHack/blob/master/GameDefinition/PLAYING.md),+[CREDITS](https://github.com/LambdaHack/LambdaHack/blob/master/CREDITS)+and [LICENSE](https://github.com/LambdaHack/LambdaHack/blob/master/LICENSE).  Have fun! @@ -181,9 +232,12 @@ [7]: http://www.haskell.org/platform [8]: https://github.com/tuturto/space-privateers [9]: https://github.com/LambdaHack/LambdaHack/wiki/Sample-dungeon-crawler- [10]: https://github.com/AllureOfTheStars/Allure [11]: https://github.com/LambdaHack/LambdaHack/releases/latest-[12]: http://hydra.cryp.to/search?query=LambdaHack+[12]: http://hydra.nixos.org/search?query=LambdaHack [13]: http://www.haskell.org/haskellwiki/GHC_under_Wine#Code_that_uses_gtk2hs [14]: http://www.edsko.net/2014/04/27/haskell-including-gtk-on-mavericks+[15]: https://github.com/ghcjs/ghcjs+[16]: https://www.npmjs.com/package/google-closure-compiler+[17]: https://ci.appveyor.com/project/Mikolaj/lambdahack-4hh0j/build/artifacts+[18]: https://ci.appveyor.com/project/Mikolaj/lambdahack/build/artifacts

test/test.hs view

@@ -2,5 +2,5 @@  main :: IO () main =-  tieKnot $ tail $ words "dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 6 --automateAll --keepAutomated --gameMode campaign --setDungeonRng 42 --setMainRng 42"-  -- tieKnot $ tail $ words "dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame 2 --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 6 --automateAll --keepAutomated --gameMode battle --setDungeonRng 42 --setMainRng 42"+  tieKnot $ words "--dbgMsgSer --newGame 2 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 100 --automateAll --keepAutomated --gameMode exploration --setDungeonRng 42 --setMainRng 42"+  -- tieKnot $ words "--dbgMsgSer --newGame 2 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 100 --automateAll --keepAutomated --gameMode battle --setDungeonRng 42 --setMainRng 42"