diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,12 @@ +## [v0.8.3.0](https://github.com/LambdaHack/LambdaHack/compare/v0.8.1.2...v0.8.3.0) + +- Add a hack to run SDL2 on the main thread, fixing the OS X crash +- Warn visually when impressed and Calm running low, risking domination +- Display actor as red when low Calm and impressed or when low HP +- Fix, complete and fine tune UI, AI and server skill and weapon checks +- Fix a bug where item aspects look different to clients than to the server +- Change the requirements for the main menu ASCII art + ## [v0.8.1.2](https://github.com/LambdaHack/LambdaHack/compare/v0.8.1.1...v0.8.1.2) - Fix typos detected by lintian diff --git a/CREDITS b/CREDITS --- a/CREDITS +++ b/CREDITS @@ -6,6 +6,7 @@ Tuukka Turto Veronika Romashkina @Peritract +Pablo Reszczynski Fonts 16x16x.fon, 8x8x.fon and 8x8xb.fon are are taken from diff --git a/Game/LambdaHack/Atomic/CmdAtomic.hs b/Game/LambdaHack/Atomic/CmdAtomic.hs --- a/Game/LambdaHack/Atomic/CmdAtomic.hs +++ b/Game/LambdaHack/Atomic/CmdAtomic.hs @@ -104,12 +104,12 @@ | UpdTimeItem ItemId Container ItemTimer ItemTimer | UpdAgeGame [LevelId] | UpdUnAgeGame [LevelId] - | UpdDiscover Container ItemId (ContentId ItemKind) IA.ItemSeed - | UpdCover Container ItemId (ContentId ItemKind) IA.ItemSeed + | UpdDiscover Container ItemId (ContentId ItemKind) IA.AspectRecord + | UpdCover Container ItemId (ContentId ItemKind) IA.AspectRecord | UpdDiscoverKind Container ItemKindIx (ContentId ItemKind) | UpdCoverKind Container ItemKindIx (ContentId ItemKind) - | UpdDiscoverSeed Container ItemId IA.ItemSeed - | UpdCoverSeed Container ItemId IA.ItemSeed + | UpdDiscoverAspect Container ItemId IA.AspectRecord + | UpdCoverAspect Container ItemId IA.AspectRecord | UpdDiscoverServer ItemId IA.AspectRecord | UpdCoverServer ItemId IA.AspectRecord | UpdPerception LevelId Perception Perception @@ -215,12 +215,14 @@ UpdTimeItem iid c fromIt toIt -> Just $ UpdTimeItem iid c toIt fromIt 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 + UpdDiscover c iid ik aspectRecord -> Just $ UpdCover c iid ik aspectRecord + UpdCover c iid ik aspectRecord -> Just $ UpdDiscover c iid ik aspectRecord UpdDiscoverKind c ix ik -> Just $ UpdCoverKind c ix ik UpdCoverKind c ix ik -> Just $ UpdDiscoverKind c ix ik - UpdDiscoverSeed c iid seed -> Just $ UpdCoverSeed c iid seed - UpdCoverSeed c iid seed -> Just $ UpdDiscoverSeed c iid seed + UpdDiscoverAspect c iid aspectRecord -> + Just $ UpdCoverAspect c iid aspectRecord + UpdCoverAspect c iid aspectRecord -> + Just $ UpdDiscoverAspect c iid aspectRecord UpdDiscoverServer iid aspectRecord -> Just $ UpdCoverServer iid aspectRecord UpdCoverServer iid aspectRecord -> Just $ UpdDiscoverServer iid aspectRecord UpdPerception lid outPer inPer -> Just $ UpdPerception lid inPer outPer diff --git a/Game/LambdaHack/Atomic/HandleAtomicWrite.hs b/Game/LambdaHack/Atomic/HandleAtomicWrite.hs --- a/Game/LambdaHack/Atomic/HandleAtomicWrite.hs +++ b/Game/LambdaHack/Atomic/HandleAtomicWrite.hs @@ -17,7 +17,7 @@ , updAlterSmell, updSpotSmell, updLoseSmell, updTimeItem , updAgeGame, updUnAgeGame, ageLevel, updDiscover, updCover , updDiscoverKind, discoverKind, updCoverKind - , updDiscoverSeed, discoverSeed, updCoverSeed + , updDiscoverAspect, discoverAspect, updCoverAspect , updDiscoverServer, updCoverServer , updRestart, updRestartServer, updResumeServer #endif @@ -107,12 +107,12 @@ UpdTimeItem iid c fromIt toIt -> updTimeItem iid c fromIt toIt UpdAgeGame lids -> updAgeGame lids UpdUnAgeGame lids -> updUnAgeGame lids - UpdDiscover c iid ik seed -> updDiscover c iid ik seed - UpdCover c iid ik seed -> updCover c iid ik seed + UpdDiscover c iid ik aspectRecord -> updDiscover c iid ik aspectRecord + UpdCover c iid ik aspectRecord -> updCover c iid ik aspectRecord UpdDiscoverKind c ix ik -> updDiscoverKind c ix ik UpdCoverKind c ix ik -> updCoverKind c ix ik - UpdDiscoverSeed c iid seed -> updDiscoverSeed c iid seed - UpdCoverSeed c iid seed -> updCoverSeed c iid seed + UpdDiscoverAspect c iid aspectRecord -> updDiscoverAspect c iid aspectRecord + UpdCoverAspect c iid aspectRecord -> updCoverAspect c iid aspectRecord UpdDiscoverServer iid aspectRecord -> updDiscoverServer iid aspectRecord UpdCoverServer iid aspectRecord -> updCoverServer iid aspectRecord UpdPerception _ outPer inPer -> @@ -557,30 +557,31 @@ updateLevel lid $ \lvl -> lvl {ltime = timeShift (ltime lvl) delta} updDiscover :: MonadStateWrite m - => Container -> ItemId -> ContentId ItemKind -> IA.ItemSeed -> m () -updDiscover _c iid ik seed = do + => Container -> ItemId -> ContentId ItemKind -> IA.AspectRecord + -> m () +updDiscover _c iid ik aspectRecord = do itemD <- getsState sitemD COps{coItemSpeedup} <- getsState scops let kmIsConst = IA.kmConst $ IK.getKindMean ik coItemSpeedup discoKind <- getsState sdiscoKind - let discoverAtMostSeed = do + let discoverAtMostAspect = do discoAspect <- getsState sdiscoAspect if kmIsConst || iid `EM.member` discoAspect then atomicFail "item already fully discovered" - else discoverSeed iid seed + else discoverAspect iid aspectRecord case EM.lookup iid itemD of Nothing -> atomicFail "discovered item unheard of" Just item -> case jkind item of - IdentityObvious _ -> discoverAtMostSeed + IdentityObvious _ -> discoverAtMostAspect IdentityCovered ix _ik -> case EM.lookup ix discoKind of - Just{} -> discoverAtMostSeed + Just{} -> discoverAtMostAspect Nothing -> do discoverKind ix ik - unless kmIsConst $ discoverSeed iid seed + unless kmIsConst $ discoverAspect iid aspectRecord resetActorAspect -updCover :: Container -> ItemId -> ContentId ItemKind -> IA.ItemSeed -> m () -updCover _c _iid _ik _seed = undefined +updCover :: Container -> ItemId -> ContentId ItemKind -> IA.AspectRecord -> m () +updCover _c _iid _ik _aspectRecord = undefined updDiscoverKind :: MonadStateWrite m => Container -> ItemKindIx -> ContentId ItemKind -> m () @@ -602,9 +603,9 @@ updCoverKind :: Container -> ItemKindIx -> ContentId ItemKind -> m () updCoverKind _c _ix _ik = undefined -updDiscoverSeed :: MonadStateWrite m - => Container -> ItemId -> IA.ItemSeed -> m () -updDiscoverSeed _c iid seed = do +updDiscoverAspect :: MonadStateWrite m + => Container -> ItemId -> IA.AspectRecord -> m () +updDiscoverAspect _c iid aspectRecord = do COps{coItemSpeedup} <- getsState scops itemD <- getsState sitemD case EM.lookup iid itemD of @@ -615,27 +616,21 @@ discoAspect <- getsState sdiscoAspect let kmIsConst = IA.kmConst $ IK.getKindMean kindId coItemSpeedup if kmIsConst || iid `EM.member` discoAspect - then atomicFail "item seed already discovered" + then atomicFail "item aspectRecord already discovered" else do - discoverSeed iid seed + discoverAspect iid aspectRecord resetActorAspect -discoverSeed :: MonadStateWrite m => ItemId -> IA.ItemSeed -> m () -discoverSeed iid seed = do - item <- getsState $ getItemBody iid - totalDepth <- getsState stotalDepth - Level{ldepth} <- getLevel $ jlid item - -- Here we know the kind information is exact, hence @getItemKindServer@. - kind <- getsState $ getItemKindServer item - let aspects = IA.seedToAspect seed (IK.iaspects kind) ldepth totalDepth - f Nothing = Just aspects - f Just{} = error $ "already discovered" `showFailure` (iid, seed) +discoverAspect :: MonadStateWrite m => ItemId -> IA.AspectRecord -> m () +discoverAspect iid aspectRecord = do + let f Nothing = Just aspectRecord + f Just{} = error $ "already discovered" `showFailure` (iid, aspectRecord) -- At this point we know the item is not @kmConst@. modifyState $ updateDiscoAspect $ \discoAspect1 -> EM.alter f iid discoAspect1 -updCoverSeed :: Container -> ItemId -> IA.ItemSeed -> m () -updCoverSeed _c _iid _seed = undefined +updCoverAspect :: Container -> ItemId -> IA.AspectRecord -> m () +updCoverAspect _c _iid _aspectRecord = undefined updDiscoverServer :: MonadStateWrite m => ItemId -> IA.AspectRecord -> m () updDiscoverServer iid aspectRecord = diff --git a/Game/LambdaHack/Atomic/PosAtomicRead.hs b/Game/LambdaHack/Atomic/PosAtomicRead.hs --- a/Game/LambdaHack/Atomic/PosAtomicRead.hs +++ b/Game/LambdaHack/Atomic/PosAtomicRead.hs @@ -136,8 +136,8 @@ UpdCover c _ _ _ -> singleContainer c UpdDiscoverKind c _ _ -> singleContainer c UpdCoverKind c _ _ -> singleContainer c - UpdDiscoverSeed c _ _ -> singleContainer c - UpdCoverSeed c _ _ -> singleContainer c + UpdDiscoverAspect c _ _ -> singleContainer c + UpdCoverAspect c _ _ -> singleContainer c UpdDiscoverServer{} -> return PosSer UpdCoverServer{} -> return PosSer UpdPerception{} -> return PosNone diff --git a/Game/LambdaHack/Client.hs b/Game/LambdaHack/Client.hs --- a/Game/LambdaHack/Client.hs +++ b/Game/LambdaHack/Client.hs @@ -9,12 +9,11 @@ ( -- * Re-exported from "Game.LambdaHack.Client.LoopM" loopCli -- * Re-exported from "Game.LambdaHack.Client.Request" - , RequestAI, ReqAI(..), RequestUI, ReqUI(..) - , RequestAnyAbility(..), RequestTimed(..) + , RequestAI, ReqAI(..), RequestUI, ReqUI(..), RequestTimed(..) -- * Re-exported from "Game.LambdaHack.Client.Response" , Response (..) -- * Re-exported from "Game.LambdaHack.Client.ClientOptions" - , ClientOptions, defClientOptions, sbenchmark + , ClientOptions(..), defClientOptions -- * Re-exported from "Game.LambdaHack.Client.UI" , KeyKind , UIOptions, applyUIOptions, uCmdline, mkUIOptions diff --git a/Game/LambdaHack/Client/AI.hs b/Game/LambdaHack/Client/AI.hs --- a/Game/LambdaHack/Client/AI.hs +++ b/Game/LambdaHack/Client/AI.hs @@ -1,4 +1,3 @@ -{-# 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 @@ -41,7 +40,7 @@ (aidToMove, treq, oldFlee) <- pickActorAndAction Nothing aid (aidToMove2, treq2) <- case treq of - RequestAnyAbility ReqWait | mleader == Just aid -> do + ReqWait | mleader == Just aid -> do -- Leader waits; a waste; try once to pick a yet different leader. -- Undo state changes in @pickAction@: modifyClient $ \cli -> cli @@ -58,8 +57,8 @@ -- | Pick an actor to move and an action for him to perform, given an optional -- previous candidate actor and action and the server-proposed actor. pickActorAndAction :: MonadClient m - => Maybe (ActorId, RequestAnyAbility) -> ActorId - -> m (ActorId, RequestAnyAbility, Maybe Point) + => Maybe (ActorId, RequestTimed) -> ActorId + -> m (ActorId, RequestTimed, Maybe Point) -- This inline speeds up execution by 15% and decreases allocation by 15%, -- despite probably bloating executable: {-# INLINE pickActorAndAction #-} diff --git a/Game/LambdaHack/Client/AI/HandleAbilityM.hs b/Game/LambdaHack/Client/AI/HandleAbilityM.hs --- a/Game/LambdaHack/Client/AI/HandleAbilityM.hs +++ b/Game/LambdaHack/Client/AI/HandleAbilityM.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} -- | AI procedure for picking the best action for an actor. module Game.LambdaHack.Client.AI.HandleAbilityM ( pickAction @@ -8,7 +7,7 @@ , waitBlockNow, pickup, equipItems, toShare, yieldUnneeded, unEquipItems , groupByEqpSlot, bestByEqpSlot, harmful, meleeBlocker, meleeAny , trigger, projectItem, ApplyItemGroup, applyItem, flee - , displaceFoe, displaceBlocker, displaceTowards + , displaceFoe, displaceBlocker, displaceTgt , chase, moveTowards, moveOrRunAid #endif ) where @@ -56,7 +55,7 @@ import Game.LambdaHack.Content.ModeKind -- | Pick the most desirable AI ation for the actor. -pickAction :: MonadClient m => ActorId -> Bool -> m RequestAnyAbility +pickAction :: MonadClient m => ActorId -> Bool -> m RequestTimed {-# INLINE pickAction #-} pickAction aid retry = do side <- getsClient sside @@ -77,15 +76,10 @@ -- Run the AI: chose an action from those given by the AI strategy. rndToAction $ frequency bestAction -type ToAny a = Strategy (RequestTimed a) -> Strategy RequestAnyAbility - -toAny :: ToAny a -toAny strat = RequestAnyAbility <$> strat - -- AI strategy based on actor's sight, smell, etc. -- Never empty. actionStrategy :: forall m. MonadClient m - => ActorId -> Bool -> m (Strategy RequestAnyAbility) + => ActorId -> Bool -> m (Strategy RequestTimed) {-# INLINE actionStrategy #-} actionStrategy aid retry = do body <- getsState $ getActorBody aid @@ -136,8 +130,10 @@ canFleeFromLight = not $ null $ aCanDeLightL `intersect` map snd fleeL actorMaxSk = IA.aSkills ar abInMaxSkill ab = EM.findWithDefault 0 ab actorMaxSk > 0 - stratToFreq :: Int -> m (Strategy RequestAnyAbility) - -> m (Frequency RequestAnyAbility) + runSkills = [AbMove, AbDisplace, AbAlter] + stratToFreq :: Int + -> m (Strategy RequestTimed) + -> m (Frequency RequestTimed) stratToFreq scale mstrat = do st <- mstrat return $! if scale == 0 @@ -146,13 +142,13 @@ -- 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, suffix :: [([Ability], m (Strategy RequestTimed), Bool)] prefix = - [ ( [AbApply], (toAny :: ToAny 'AbApply) - <$> applyItem aid ApplyFirstAid + [ ( [AbApply] + , applyItem aid ApplyFirstAid , not condAnyFoeAdj && condHpTooLow) - , ( [AbAlter], (toAny :: ToAny 'AbAlter) - <$> trigger aid ViaStairs + , ( [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 @@ -163,16 +159,16 @@ , ( [AbDisplace] , displaceFoe aid -- only swap with an enemy to expose him , condAnyFoeAdj && condBlocksFriends) -- later checks foe eligible - , ( [AbMoveItem], (toAny :: ToAny 'AbMoveItem) - <$> pickup aid True + , ( [AbMoveItem] + , pickup aid True , condNoEqpWeapon -- we assume organ weapons usually inferior && condFloorWeapon && not condHpTooLow && abInMaxSkill AbMelee ) - , ( [AbAlter], (toAny :: ToAny 'AbAlter) - <$> trigger aid ViaEscape + , ( [AbAlter] + , trigger aid ViaEscape , condAdjTriggerable && not condAimEnemyPresent && not condDesirableFloorItem ) -- collect the last loot - , ( [AbMove] + , ( runSkills , 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, @@ -200,24 +196,24 @@ not condInMelee && heavilyDistressed && (not condCanProject || canFleeFromLight) ) - , ( [AbMelee], (toAny :: ToAny 'AbMelee) - <$> meleeBlocker aid -- only melee blocker + , ( [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 + , ( [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 + , ( [AbMelee] + , meleeAny aid , condAnyFoeAdj ) -- won't flee nor displace, so let it melee - , ( [AbMove] + , ( runSkills , flee aid panicFleeL -- ultimate panic mode, displaces foes , condAnyFoeAdj ) ] @@ -226,16 +222,15 @@ -- 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 :: [([Ability], m (Frequency RequestTimed), Bool)] distant = [ ( [AbMoveItem] , stratToFreq (if condInMelee then 2 else 20000) - $ (toAny :: ToAny 'AbMoveItem) - <$> yieldUnneeded aid -- 20000 to unequip ASAP, unless is thrown + $ 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 + , stratToFreq 1 + $ equipItems aid -- doesn't take long, very useful if safe , not (condInMelee || condDesirableFloorItem || condNotCalmEnough @@ -243,14 +238,13 @@ , ( [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 + $ projectItem aid -- equivalent of @condCanProject@ called inside , condAimEnemyPresent && not condInMelee ) , ( [AbApply] - , stratToFreq 1 $ (toAny :: ToAny 'AbApply) - <$> applyItem aid ApplyAll -- use any potion or scroll + , stratToFreq 1 + $ applyItem aid ApplyAll -- use any potion or scroll , condAimEnemyPresent || condThreat 9 ) -- can affect enemies - , ( [AbMove] + , ( runSkills , stratToFreq (if | condInMelee -> 400 -- friends pummeled by target, go to help | not condAimEnemyPresent -> @@ -275,13 +269,13 @@ ] -- Order matters again. suffix = - [ ( [AbMoveItem], (toAny :: ToAny 'AbMoveItem) - <$> pickup aid False -- e.g., to give to other party members + [ ( [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 + , ( [AbMoveItem] + , unEquipItems aid -- late, because these items not bad , not condInMelee ) - , ( [AbMove] + , ( runSkills , chase aid (not condInMelee && heavilyDistressed && aCanDeLight) retry @@ -289,8 +283,8 @@ else not (condThreat 2) || not condMeleeBad ) ] fallback = - [ ( [AbWait], (toAny :: ToAny 'AbWait) - <$> waitBlockNow + [ ( [AbWait] + , waitBlockNow -- Wait until friends sidestep; ensures strategy is never empty. , True ) ] @@ -298,7 +292,7 @@ -- 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 + checkAction (abts, _, cond) = any abInSkill abts && cond sumS abAction = do let as = filter checkAction abAction strats <- mapM (\(_, m, _) -> m) as @@ -314,11 +308,10 @@ sumFallback <- sumS fallback return $! sumPrefix .| comDistant .| sumSuffix .| sumFallback -waitBlockNow :: MonadClient m => m (Strategy (RequestTimed 'AbWait)) +waitBlockNow :: MonadClient m => m (Strategy RequestTimed) waitBlockNow = return $! returN "wait" ReqWait -pickup :: MonadClient m - => ActorId -> Bool -> m (Strategy (RequestTimed 'AbMoveItem)) +pickup :: MonadClient m => ActorId -> Bool -> m (Strategy RequestTimed) pickup aid onlyWeapon = do benItemL <- benGroundItems aid b <- getsState $ getActorBody aid @@ -356,8 +349,7 @@ -- 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 :: MonadClient m => ActorId -> m (Strategy RequestTimed) equipItems aid = do body <- getsState $ getActorBody aid ar <- getsState $ getActorAspect aid @@ -421,8 +413,7 @@ toShare IA.EqpSlotMiscAbility = False toShare _ = True -yieldUnneeded :: MonadClient m - => ActorId -> m (Strategy (RequestTimed 'AbMoveItem)) +yieldUnneeded :: MonadClient m => ActorId -> m (Strategy RequestTimed) yieldUnneeded aid = do body <- getsState $ getActorBody aid ar <- getsState $ getActorAspect aid @@ -457,8 +448,7 @@ -- 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 :: MonadClient m => ActorId -> m (Strategy RequestTimed) unEquipItems aid = do body <- getsState $ getActorBody aid ar <- getsState $ getActorAspect aid @@ -561,7 +551,7 @@ not $ benInEqp $ discoBenefit EM.! iid -- Everybody melees in a pinch, even though some prefer ranged attacks. -meleeBlocker :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbMelee)) +meleeBlocker :: MonadClient m => ActorId -> m (Strategy RequestTimed) meleeBlocker aid = do b <- getsState $ getActorBody aid actorAspect <- getsState sactorAspect @@ -588,8 +578,8 @@ -- 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 -> + || bproj body2 -- displacing saves a move, so don't melee + && EM.findWithDefault 0 AbDisplace actorSk > 0 -> return reject | isFoe (bfid b) fact (bfid body2) -- at war with us, so hit, not displace @@ -606,7 +596,7 @@ -- Everybody melees in a pinch, skills and weapons allowing, -- even though some prefer ranged attacks. -meleeAny :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbMelee)) +meleeAny :: MonadClient m => ActorId -> m (Strategy RequestTimed) meleeAny aid = do b <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid b) . sfactionD @@ -634,7 +624,7 @@ -- the actor doesn't target a visible enemy at this point. trigger :: MonadClient m => ActorId -> FleeViaStairsOrEscape - -> m (Strategy (RequestTimed 'AbAlter)) + -> m (Strategy RequestTimed) trigger aid fleeVia = do b <- getsState $ getActorBody aid lvl <- getLevel (blid b) @@ -647,8 +637,7 @@ [ (ceiling benefit, ReqAlter pos) | (benefit, (pos, _)) <- efeat ] -projectItem :: MonadClient m - => ActorId -> m (Strategy (RequestTimed 'AbProject)) +projectItem :: MonadClient m => ActorId -> m (Strategy RequestTimed) projectItem aid = do btarget <- getsClient $ getTarget aid b <- getsState $ getActorBody aid @@ -698,7 +687,7 @@ deriving Eq applyItem :: MonadClient m - => ActorId -> ApplyItemGroup -> m (Strategy (RequestTimed 'AbApply)) + => ActorId -> ApplyItemGroup -> m (Strategy RequestTimed) applyItem aid applyGroup = do actorSk <- currentSkillsClient aid b <- getsState $ getActorBody aid @@ -796,7 +785,7 @@ -- and as far from the attackers, as possible. Usually fleeing from -- foes will lead towards friends, but we don't insist on that. flee :: MonadClient m - => ActorId -> [(Int, Point)] -> m (Strategy RequestAnyAbility) + => ActorId -> [(Int, Point)] -> m (Strategy RequestTimed) flee aid fleeL = do b <- getsState $ getActorBody aid -- Regardless if fleeing accomplished, mark the need. @@ -807,7 +796,7 @@ -- 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 :: MonadClient m => ActorId -> m (Strategy RequestTimed) displaceFoe aid = do COps{coTileSpeedup} <- getsState scops b <- getsState $ getActorBody aid @@ -815,11 +804,13 @@ fact <- getsState $ (EM.! bfid b) . sfactionD friends <- getsState $ friendRegularList (bfid b) (blid b) adjacentAssocs <- getsState $ actorAdjacentAssocs b - let foe (_, b2) = - not (bproj b2) && isFoe (bfid b) fact (bfid b2) && bhp b2 > 0 + let foe (_, b2) = not (bproj b2) && isFoe (bfid b) fact (bfid b2) + -- DisplaceProjectiles adjFoes = filter foe adjacentAssocs - displaceable body = -- DisplaceAccess - Tile.isWalkable coTileSpeedup (lvl `at` bpos body) + walkable p = -- DisplaceAccess + Tile.isWalkable coTileSpeedup (lvl `at` p) + notLooping body p = -- avoid displace loops + boldpos body /= Just p || waitedLastTurn body nFriends body = length $ filter (adjacent (bpos body) . bpos) friends nFrNew = nFriends b + 1 qualifyActor (aid2, body2) = do @@ -827,40 +818,40 @@ 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) + return $! if walkable (bpos body2) && dEnemy && nFrOld < nFrNew + && notLooping b (bpos body2) + then Just (nFrOld * nFrOld, ReqDisplace aid2) else Nothing - vFoes <- mapM qualifyActor adjFoes - let str = liftFrequency $ toFreq "displaceFoe" $ catMaybes vFoes - mapStrategyM (moveOrRunAid aid) str + foes <- mapM qualifyActor adjFoes + return $! liftFrequency $ toFreq "displaceFoe" $ catMaybes foes -displaceBlocker :: MonadClient m - => ActorId -> Bool -> m (Strategy RequestAnyAbility) +displaceBlocker :: MonadClient m => ActorId -> Bool -> m (Strategy RequestTimed) displaceBlocker aid retry = do b <- getsState $ getActorBody aid mtgtMPath <- getsClient $ EM.lookup aid . stargetD - str <- case mtgtMPath of + 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 + displaceTgt 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 +displaceTgt :: MonadClient m + => ActorId -> Point -> Bool -> m (Strategy RequestTimed) +displaceTgt aid target retry = do 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 + let walkable p = -- DisplaceAccess + Tile.isWalkable coTileSpeedup (lvl `at` p) + notLooping body p = -- avoid displace loops + boldpos body /= Just p || waitedLastTurn body + if walkable target && notLooping b target then do mleader <- getsClient sleader mBlocker <- getsState $ posToAssocs target (blid b) case mBlocker of @@ -881,20 +872,21 @@ -- 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 + return $! returN "displace friend" $ ReqDisplace aid2 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 + -- DisplaceDying, DisplaceBraced, DisplaceImmobile, + -- DisplaceSupported if not (isFoe (bfid b2) tfact (bfid b)) || dEnemy then - return $! returN "displace other" $ target `vectorToFrom` source - else return reject -- DisplaceDying, etc. + return $! returN "displace other" $ ReqDisplace aid2 + else return reject _ -> return reject -- DisplaceProjectiles or trying to displace leader else return reject -chase :: MonadClient m - => ActorId -> Bool -> Bool -> m (Strategy RequestAnyAbility) +chase :: MonadClient m => ActorId -> Bool -> Bool -> m (Strategy RequestTimed) chase aid avoidAmbient retry = do COps{coTileSpeedup} <- getsState scops body <- getsState $ getActorBody aid @@ -955,15 +947,17 @@ -- 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 :: MonadClient m => ActorId -> Vector -> m (Maybe RequestTimed) moveOrRunAid source dir = do 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 + let walkable = -- DisplaceAccess + Tile.isWalkable coTileSpeedup (lvl `at` tpos) + notLooping body p = -- avoid displace loops + boldpos body /= Just p || waitedLastTurn body spos = bpos sb -- source position tpos = spos `shift` dir -- target position t = lvl `at` tpos @@ -973,44 +967,27 @@ -- (tiles can't be invisible). tgts <- getsState $ posToAssocs tpos lid case tgts of - [(target, b2)] -> do + [(target, b2)] | walkable + && EM.findWithDefault 0 AbDisplace actorSk > 0 + && notLooping sb tpos -> 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 - | isFoe (bfid b2) 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 -> - error $ "AI causes AlterUnwalked" `showFailure` (source, dir) - | EM.member tpos $ lfloor lvl -> - -- Only possible if items allowed inside unwalkable tiles. - error $ "AI causes AlterBlockItem" `showFailure` (source, dir) - | otherwise -> - -- Not walkable, but alter skill suffices, so search or alter the tile. - return $ Just $ RequestAnyAbility $ ReqAlter tpos + -- DisplaceDying, DisplaceBraced, DisplaceImmobile, DisplaceSupported + if isFoe (bfid b2) tfact (bfid sb) && not dEnemy + then return Nothing + else return $ Just $ ReqDisplace target + [] | walkable && EM.findWithDefault 0 AbMove actorSk > 0 -> + -- Movement requires full access. The potential invisible actor is hit. + return $ Just $ ReqMove dir + [] | not walkable + && EM.findWithDefault 0 AbAlter actorSk + >= Tile.alterMinWalk coTileSpeedup t -- AlterUnwalked + -- Only possible if items allowed inside unwalkable tiles: + && EM.notMember tpos (lfloor lvl) -> -- AlterBlockItem + -- Not walkable, but alter skill suffices, so search or alter the tile. + -- We assume that unalterable unwalkable tiles are protected + -- by high skill req. We don't alter walkable tiles (e.g., close doors). + return $ Just $ ReqAlter tpos + _ -> return Nothing -- can't displace, move nor alter diff --git a/Game/LambdaHack/Client/CommonM.hs b/Game/LambdaHack/Client/CommonM.hs --- a/Game/LambdaHack/Client/CommonM.hs +++ b/Game/LambdaHack/Client/CommonM.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} -- | Common client monad operations. module Game.LambdaHack.Client.CommonM ( getPerFid, aidTgtToPos, makeLine @@ -136,7 +135,7 @@ -- primitive and random here as well. pickWeaponClient :: MonadClient m => ActorId -> ActorId - -> m (Maybe (RequestTimed 'Ability.AbMelee)) + -> m (Maybe RequestTimed) pickWeaponClient source target = do eqpAssocs <- getsState $ kitAssocs source [CEqp] bodyAssocs <- getsState $ kitAssocs source [COrgan] diff --git a/Game/LambdaHack/Client/HandleAtomicM.hs b/Game/LambdaHack/Client/HandleAtomicM.hs --- a/Game/LambdaHack/Client/HandleAtomicM.hs +++ b/Game/LambdaHack/Client/HandleAtomicM.hs @@ -6,7 +6,7 @@ -- * Internal operations , wipeBfsIfItemAffectsSkills, tileChangeAffectsBfs, createActor, destroyActor , addItemToDiscoBenefit, perception - , discoverKind, coverKind, discoverSeed, coverSeed + , discoverKind, coverKind, discoverAspect, coverAspect , killExit #endif ) where @@ -148,7 +148,7 @@ UpdLoseTile lid ts -> do updateSalter lid ts invalidateBfsLid lid -- from known to unknown tiles - UpdDiscover c iid ik seed -> do + UpdDiscover c iid ik aspectRecord -> do item <- getsState $ getItemBody iid discoKind <- getsState sdiscoKind case jkind item of @@ -156,9 +156,9 @@ IdentityCovered ix _ik | ix `EM.notMember` discoKind -> discoverKind c ix ik IdentityCovered _ix _ik -> return () - discoverSeed c iid seed - UpdCover c iid ik seed -> do - coverSeed c iid seed + discoverAspect c iid aspectRecord + UpdCover c iid ik aspectRecord -> do + coverAspect c iid aspectRecord item <- getsState $ getItemBody iid discoKind <- getsState sdiscoKind case jkind item of @@ -168,8 +168,8 @@ IdentityCovered _ix _ik -> return () UpdDiscoverKind c ix ik -> discoverKind c ix ik UpdCoverKind c ix ik -> coverKind c ix ik - UpdDiscoverSeed c iid seed -> discoverSeed c iid seed - UpdCoverSeed c iid seed -> coverSeed c iid seed + UpdDiscoverAspect c iid aspectRecord -> discoverAspect c iid aspectRecord + UpdCoverAspect c iid aspectRecord -> coverAspect c iid aspectRecord UpdPerception lid outPer inPer -> perception lid outPer inPer UpdRestart side sfper s scurChal soptions -> do COps{cocave, comode} <- getsState scops @@ -276,8 +276,9 @@ cops <- getsState scops discoBenefit <- getsClient sdiscoBenefit case EM.lookup iid discoBenefit of - Just{} -> return () -- already there, with real or provisional aspects, - -- but we haven't learned anything new about the item + Just{} -> return () + -- already there, with real or provisional aspect record, + -- but we haven't learned anything new about the item Nothing -> do side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD @@ -332,8 +333,9 @@ coverKind :: Container -> ItemKindIx -> ContentId ItemKind -> m () coverKind _c _ix _ik = undefined -discoverSeed :: MonadClient m => Container -> ItemId -> IA.ItemSeed -> m () -discoverSeed _c iid _seed = do +discoverAspect :: MonadClient m + => Container -> ItemId -> IA.AspectRecord -> m () +discoverAspect _c iid _aspectRecord = do cops <- getsState scops -- Wipe out BFS, because the player could potentially learn that his items -- affect his actors' skills relevant to BFS. @@ -346,8 +348,8 @@ modifyClient $ \cli -> cli {sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli)} -coverSeed :: Container -> ItemId -> IA.ItemSeed -> m () -coverSeed _c _iid _seed = undefined +coverAspect :: Container -> ItemId -> IA.AspectRecord -> m () +coverAspect _c _iid _aspectRecord = undefined killExit :: MonadClient m => m () killExit = do diff --git a/Game/LambdaHack/Client/Request.hs b/Game/LambdaHack/Client/Request.hs --- a/Game/LambdaHack/Client/Request.hs +++ b/Game/LambdaHack/Client/Request.hs @@ -1,18 +1,15 @@ -{-# LANGUAGE DataKinds, GADTs, KindSignatures, StandaloneDeriving #-} -- | Abstract syntax of requests. -- -- See -- . module Game.LambdaHack.Client.Request - ( RequestAI, ReqAI(..), RequestUI, ReqUI(..) - , RequestAnyAbility(..), RequestTimed(..) + ( RequestAI, ReqAI(..), RequestUI, ReqUI(..), RequestTimed(..) ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item @@ -28,7 +25,7 @@ -- | Possible forms of requests sent by AI clients. data ReqAI = ReqAINop - | ReqAITimed RequestAnyAbility + | ReqAITimed RequestTimed deriving Show -- | Requests sent by UI clients to the server. If faction leader is to be @@ -38,7 +35,7 @@ -- | Possible forms of requests sent by UI clients. data ReqUI = ReqUINop - | ReqUITimed RequestAnyAbility + | ReqUITimed RequestTimed | ReqUIGameRestart (GroupName ModeKind) Challenge | ReqUIGameDropAndExit | ReqUIGameSaveAndExit @@ -47,22 +44,16 @@ | ReqUIAutomate deriving Show --- | Basic form of requests, sent by both AI and UI clients to the server. -data RequestAnyAbility = forall a. RequestAnyAbility (RequestTimed a) - -deriving instance Show RequestAnyAbility - -- | Requests that take game time, indexed by actor ability -- that is needed for performing the corresponding actions. -data RequestTimed :: Ability -> * where - ReqMove :: Vector -> RequestTimed 'AbMove - ReqMelee :: ActorId -> ItemId -> CStore -> RequestTimed 'AbMelee - ReqDisplace :: ActorId -> RequestTimed 'AbDisplace - ReqAlter :: Point -> RequestTimed 'AbAlter - ReqWait :: RequestTimed 'AbWait - ReqWait10 :: RequestTimed 'AbWait - ReqMoveItems :: [(ItemId, Int, CStore, CStore)] -> RequestTimed 'AbMoveItem - ReqProject :: Point -> Int -> ItemId -> CStore -> RequestTimed 'AbProject - ReqApply :: ItemId -> CStore -> RequestTimed 'AbApply - -deriving instance Show (RequestTimed a) +data RequestTimed = + ReqMove Vector + | ReqMelee ActorId ItemId CStore + | ReqDisplace ActorId + | ReqAlter Point + | ReqWait + | ReqWait10 + | ReqMoveItems [(ItemId, Int, CStore, CStore)] + | ReqProject Point Int ItemId CStore + | ReqApply ItemId CStore + deriving Show diff --git a/Game/LambdaHack/Client/UI/DisplayAtomicM.hs b/Game/LambdaHack/Client/UI/DisplayAtomicM.hs --- a/Game/LambdaHack/Client/UI/DisplayAtomicM.hs +++ b/Game/LambdaHack/Client/UI/DisplayAtomicM.hs @@ -296,8 +296,8 @@ UpdCover{} -> return () -- don't spam when doing undo UpdDiscoverKind{} -> return () -- don't spam when server tweaks stuff UpdCoverKind{} -> return () -- don't spam when doing undo - UpdDiscoverSeed{} -> return () -- don't spam when server tweaks stuff - UpdCoverSeed{} -> return () -- don't spam when doing undo + UpdDiscoverAspect{} -> return () -- don't spam when server tweaks stuff + UpdCoverAspect{} -> return () -- don't spam when doing undo UpdDiscoverServer{} -> error "server command leaked to client" UpdCoverServer{} -> error "server command leaked to client" UpdPerception{} -> return () diff --git a/Game/LambdaHack/Client/UI/DrawM.hs b/Game/LambdaHack/Client/UI/DrawM.hs --- a/Game/LambdaHack/Client/UI/DrawM.hs +++ b/Game/LambdaHack/Client/UI/DrawM.hs @@ -270,12 +270,11 @@ drawFrameActor :: forall m. MonadClientUI m => LevelId -> m FrameForall drawFrameActor drawnLevelId = do - SessionUI{sselected} <- getSession + SessionUI{sactorUI, sselected, sUIOptions} <- getSession Level{lxsize, lactor} <- getLevel drawnLevelId side <- getsClient sside mleader <- getsClient sleader s <- getState - sactorUI <- getsSession sactorUI let {-# INLINE viewActor #-} viewActor _ as = case as of aid : _ -> @@ -292,8 +291,14 @@ then Color.HighlightWhite else Color.HighlightMagenta | otherwise -> Color.HighlightNone - in Color.attrCharToW32 - $ Color.AttrChar Color.Attr{fg=bcolor, bg} symbol + fg | bfid /= side || bproj || bhp <= 0 = bcolor + | otherwise = + let (hpCheckWarning, calmCheckWarning) = + checkWarnings sUIOptions aid s + in if hpCheckWarning || calmCheckWarning + then Color.Red + else bcolor + in Color.attrCharToW32 $ Color.AttrChar Color.Attr{..} symbol [] -> error $ "lactor not sparse" `showFailure` () mapVAL :: forall a s. (Point -> a -> Color.AttrCharW32) -> [(Point, a)] -> FrameST s @@ -501,29 +506,36 @@ $ T.take 29 (lvlN <+> T.justifyLeft 26 ' ' (cname ck)) <+> seenStatus +checkWarnings :: UIOptions -> ActorId -> State -> (Bool, Bool) +checkWarnings UIOptions{uhpWarningPercent} leader s = + let b = getActorBody leader s + ar = getActorAspect leader s + isImpression iid = + maybe False (> 0) $ lookup "impressed" $ IK.ifreq $ getIidKind iid s + isImpressed = any isImpression $ EM.keys $ borgan b + hpCheckWarning = bhp b <= xM (uhpWarningPercent * IA.aMaxHP ar `div` 100) + calmCheckWarning = + bcalm b <= xM (uhpWarningPercent * IA.aMaxCalm ar `div` 100) + && isImpressed + in (hpCheckWarning, calmCheckWarning) + drawLeaderStatus :: MonadClientUI m => Int -> m AttrLine drawLeaderStatus waitT = do let calmHeaderText = "Calm" hpHeaderText = "HP" - UIOptions{uhpWarningPercent} <- getsSession sUIOptions + sUIOptions <- getsSession sUIOptions mleader <- getsClient sleader case mleader of Just leader -> do + b <- getsState $ getActorBody leader ar <- getsState $ getActorAspect leader - s <- getState + (hpCheckWarning, calmCheckWarning) + <- getsState $ checkWarnings sUIOptions leader + bdark <- getsState $ \s -> not (actorInAmbient b s) let showTrunc x = let t = show x in if length t > 3 then if x > 0 then "***" else "---" else t - (bhpM, darkL, bracedL, hpDelta, calmDelta, - ahpS, bhpS, acalmS, bcalmS) = - let b@Actor{bhp, bcalm} = getActorBody leader s - in ( bhp, not (actorInAmbient b s) - , braced b, bhpDelta b, bcalmDelta b - , showTrunc $ max 0 $ IA.aMaxHP ar - , showTrunc (bhp `divUp` oneM) - , showTrunc $ max 0 $ IA.aMaxCalm ar - , showTrunc (bcalm `divUp` oneM)) -- This is a valuable feedback for the otherwise hard to observe -- 'wait' command. slashes = ["/", "|", "\\", "|"] @@ -535,30 +547,33 @@ | snd resCurrentTurn > 0 || snd resPreviousTurn > 0 = addColor Color.BrGreen | otherwise = stringToAL -- only if nothing at all noteworthy - checkWarning = - if bhpM <= xM (uhpWarningPercent * IA.aMaxHP ar `div` 100) - then addColor Color.Red - else stringToAL - calmAddAttr = checkDelta calmDelta + calmAddAttr = checkDelta $ bcalmDelta b -- 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 = "." + darkPick | bdark = "." | otherwise = ":" calmHeader = calmAddAttr $ calmHeaderText <> darkPick - calmText = bcalmS <> (if darkL || not bracedL - then slashPick - else "/") <> acalmS - bracePick | bracedL = "}" + calmText = showTrunc (bcalm b `divUp` oneM) + <> (if bdark || not (braced b) + then slashPick + else "/") + <> showTrunc (max 0 $ IA.aMaxCalm ar) + bracePick | braced b = "}" | otherwise = ":" - hpAddAttr = checkDelta hpDelta + hpAddAttr = checkDelta $ bhpDelta b hpHeader = hpAddAttr $ hpHeaderText <> bracePick - hpText = bhpS <> (if bracedL || not darkL - then slashPick - else "/") <> ahpS + hpText = showTrunc (bhp b `divUp` oneM) + <> (if braced b || not bdark + then slashPick + else "/") + <> showTrunc (max 0 $ IA.aMaxHP ar) justifyRight n t = replicate (n - length t) ' ' ++ t - return $! calmHeader <> stringToAL (justifyRight 7 calmText) - <+:> hpHeader <> checkWarning (justifyRight 7 hpText) + colorWarning w = if w then addColor Color.Red else stringToAL + return $! calmHeader + <> colorWarning calmCheckWarning (justifyRight 7 calmText) + <+:> hpHeader + <> colorWarning hpCheckWarning (justifyRight 7 hpText) Nothing -> return $! stringToAL (calmHeaderText ++ ": --/--") <+:> stringToAL (hpHeaderText <> ": --/--") diff --git a/Game/LambdaHack/Client/UI/Frontend/Common.hs b/Game/LambdaHack/Client/UI/Frontend/Common.hs --- a/Game/LambdaHack/Client/UI/Frontend/Common.hs +++ b/Game/LambdaHack/Client/UI/Frontend/Common.hs @@ -10,12 +10,12 @@ 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 Game.LambdaHack.Client.UI.Key (KMP (..)) import qualified Game.LambdaHack.Client.UI.Key as K +import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point -- | Raw frontend definition. The minimal closed set of values that need @@ -28,11 +28,26 @@ , fprintScreen :: IO () } +-- | Start up a frontend on a bound thread. +-- +-- In fact, it is started on the very main thread, via a hack, because +-- apparently some SDL backends are not thread-safe +-- (; +-- "this should only be run in the thread that initialized the video subsystem, +-- and for extra safety, you should consider only doing those things +-- on the main thread in any case") +-- and at least the newer OS X obtusely requires the main thread, see +-- https://github.com/AllureOfTheStars/Allure/issues/79 +-- In case any other exotic architecture requires the main thread, +-- we make the hack the default for all (on frontends that require a bound +-- thread, e.g., SLD2 or GTK). startupBound :: (MVar RawFrontend -> IO ()) -> IO RawFrontend startupBound k = do rfMVar <- newEmptyMVar - a <- asyncBound $ k rfMVar - link a + putMVar workaroundOnMainThreadMVar $ k rfMVar + -- The following would run frontend on a bound thread, but it's not enough: + -- a <- asyncBound $ k rfMVar + -- link a takeMVar rfMVar createRawFrontend :: (SingleFrame -> IO ()) -> IO () -> IO RawFrontend diff --git a/Game/LambdaHack/Client/UI/Frontend/Sdl.hs b/Game/LambdaHack/Client/UI/Frontend/Sdl.hs --- a/Game/LambdaHack/Client/UI/Frontend/Sdl.hs +++ b/Game/LambdaHack/Client/UI/Frontend/Sdl.hs @@ -71,14 +71,8 @@ -- | Set up and start the main loop providing input and output. -- --- Apparently some SDL backends are not thread-safe --- (; --- "this should only be run in the thread that initialized the video subsystem, --- and for extra safety, you should consider only doing those things --- on the main thread in any case") --- so we stick to a single bound thread (but not to the main thread; --- enough is enough and at least in the case of OpenGL all bound threads --- are supposed to be as good as the main thread). +-- Because of Windows and OS X, SDL2 needs to be on a bound thread, +-- so we can't avoid the communication overhead of bound threads. startup :: ClientOptions -> IO RawFrontend startup soptions = startupBound $ startupFun soptions diff --git a/Game/LambdaHack/Client/UI/HandleHumanGlobalM.hs b/Game/LambdaHack/Client/UI/HandleHumanGlobalM.hs --- a/Game/LambdaHack/Client/UI/HandleHumanGlobalM.hs +++ b/Game/LambdaHack/Client/UI/HandleHumanGlobalM.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds, GADTs #-} -- | Semantics of "Game.LambdaHack.Client.UI.HumanCmd" -- client commands that return server requests. -- A couple of them do not take time, the rest does. @@ -25,8 +24,8 @@ #ifdef EXPOSE_INTERNAL -- * Internal operations , areaToRectangles, meleeAid, displaceAid, moveSearchAlter, goToXhair - , multiActorGoTo, selectItemsToMove, moveItems, projectItem, applyItem - , alterTile, alterTileAtPos, verifyAlters, verifyEscape, guessAlter + , multiActorGoTo, moveOrSelectItem, selectItemsToMove, moveItems, projectItem + , applyItem, alterTile, alterTileAtPos, verifyAlters, verifyEscape, guessAlter , artWithVersion, generateMenu, nxtGameMode #endif ) where @@ -230,25 +229,32 @@ -- * Wait -- | Leader waits a turn (and blocks, etc.). -waitHuman :: MonadClientUI m => m (RequestTimed 'AbWait) +waitHuman :: MonadClientUI m => m (FailOrCmd RequestTimed) waitHuman = do - modifySession $ \sess -> sess {swaitTimes = abs (swaitTimes sess) + 1} - return ReqWait + actorSk <- leaderSkillsClientUI + if EM.findWithDefault 0 AbWait actorSk > 0 then do + modifySession $ \sess -> sess {swaitTimes = abs (swaitTimes sess) + 1} + return $ Right ReqWait + else failSer WaitUnskilled -- * Wait10 -- | Leader waits a 1/10th of a turn (and doesn't block, etc.). -waitHuman10 :: MonadClientUI m => m (RequestTimed 'AbWait) +waitHuman10 :: MonadClientUI m => m (FailOrCmd RequestTimed) waitHuman10 = do - modifySession $ \sess -> sess {swaitTimes = abs (swaitTimes sess) + 1} - return ReqWait10 + actorSk <- leaderSkillsClientUI + if EM.findWithDefault 0 AbWait actorSk > 0 then do + modifySession $ \sess -> sess {swaitTimes = abs (swaitTimes sess) + 1} + return $ Right ReqWait10 + else failSer WaitUnskilled -- * MoveDir and RunDir moveRunHuman :: MonadClientUI m => Bool -> Bool -> Bool -> Bool -> Vector - -> m (FailOrCmd RequestAnyAbility) + -> m (FailOrCmd RequestTimed) moveRunHuman initialStep finalGoal run runAhead dir = do + actorSk <- leaderSkillsClientUI arena <- getArenaUI leader <- getLeaderUI sb <- getsState $ getActorBody leader @@ -292,32 +298,40 @@ -- Don't check @initialStep@ and @finalGoal@ -- and don't stop going to target: door opening is mundane enough. return $ Right runCmd - [(target, _)] | run && initialStep -> + [(target, _)] | run + && initialStep + && EM.findWithDefault 0 AbDisplace actorSk > 0 -> -- No @stopPlayBack@: initial displace is benign enough. -- Displacing requires accessibility, but it's checked later on. - RequestAnyAbility <$$> displaceAid target - _ : _ : _ | run && initialStep -> do + displaceAid target + _ : _ : _ | run + && initialStep + && EM.findWithDefault 0 AbDisplace actorSk > 0 -> do let !_A = assert (all (bproj . snd) tgts) () failSer DisplaceProjectiles - (target, tb) : _ | initialStep && finalGoal -> do + (target, tb) : _ | not run + && initialStep && finalGoal + && bfid tb == bfid sb && not (bproj tb) -> do + stopPlayBack -- don't ever auto-repeat leader choice + -- We always see actors from our own faction. + -- Select one of adjacent actors by bumping into him. Takes no time. + success <- pickLeader True target + let !_A = assert (success `blame` "bump self" + `swith` (leader, target, tb)) () + failWith "by bumping" + (target, tb) : _ | not run + && initialStep && finalGoal + && (bfid tb /= bfid sb || bproj tb) + && EM.findWithDefault 0 AbMelee actorSk > 0 -> 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" - `swith` (leader, target, tb)) () - failWith "by bumping" - else - -- Attacking does not require full access, adjacency is enough. - RequestAnyAbility <$$> meleeAid target + meleeAid target _ : _ -> failWith "actor in the way" -- | Actor attacks an enemy actor or his own projectile. meleeAid :: MonadClientUI m - => ActorId -> m (FailOrCmd (RequestTimed 'AbMelee)) + => ActorId -> m (FailOrCmd RequestTimed) meleeAid target = do leader <- getLeaderUI sb <- getsState $ getActorBody leader @@ -352,7 +366,7 @@ -- | Actor swaps position with another. displaceAid :: MonadClientUI m - => ActorId -> m (FailOrCmd (RequestTimed 'AbDisplace)) + => ActorId -> m (FailOrCmd RequestTimed) displaceAid target = do COps{coTileSpeedup} <- getsState scops leader <- getLeaderUI @@ -389,14 +403,15 @@ else failSer DisplaceAccess -- | Leader moves or searches or alters. No visible actor at the position. -moveSearchAlter :: MonadClientUI m => Vector -> m (FailOrCmd RequestAnyAbility) +moveSearchAlter :: MonadClientUI m => Vector -> m (FailOrCmd RequestTimed) moveSearchAlter dir = do COps{coTileSpeedup} <- getsState scops + actorSk <- leaderSkillsClientUI leader <- getLeaderUI sb <- getsState $ getActorBody leader ar <- getsState $ getActorAspect leader - actorSk <- leaderSkillsClientUI let calmE = calmEnough sb ar + moveSkill = EM.findWithDefault 0 AbMove actorSk alterSkill = EM.findWithDefault 0 AbAlter actorSk applySkill = EM.findWithDefault 0 AbApply actorSk spos = bpos sb -- source position @@ -418,12 +433,13 @@ || Tile.isSuspect coTileSpeedup t runStopOrCmd <- -- Movement requires full access. - if | Tile.isWalkable coTileSpeedup t -> + if | Tile.isWalkable coTileSpeedup t && moveSkill > 0 -> -- A potential invisible actor is hit. War started without asking. - return $ Right $ RequestAnyAbility $ ReqMove dir - -- No free access, so search and/or alter the tile. + return $ Right $ ReqMove dir + -- No free access or skill, so search and/or alter the tile. | not (modifiable || canApplyEmbeds) -> - failWith "never mind" -- misclick? related to AlterNothing + failWith "never mind" + -- misclick? walkable but no move skill? related to AlterNothing | alterSkill <= 1 -> failSer AlterUnskilled | not (Tile.isSuspect coTileSpeedup t) && alterSkill < alterMinSkill -> failSer AlterUnwalked @@ -432,7 +448,7 @@ | otherwise -> do -- promising verAlters <- verifyAlters (blid sb) tpos case verAlters of - Right() -> return $ Right $ RequestAnyAbility $ ReqAlter tpos + Right() -> return $ Right $ ReqAlter tpos Left err -> return $ Left err -- We don't use ReqMove, because we don't hit invisible actors, -- e.g., hidden in a wall. If server performed an attack for free @@ -448,7 +464,7 @@ -- * RunOnceAhead -runOnceAheadHuman :: MonadClientUI m => m (Either MError ReqUI) +runOnceAheadHuman :: MonadClientUI m => m (Either MError RequestTimed) runOnceAheadHuman = do side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD @@ -483,14 +499,14 @@ then weaveJust <$> failWith ("run stop:" <+> stopMsg) else return $ Left Nothing Right runCmd -> - return $ Right $ ReqUITimed runCmd + return $ Right runCmd -- * MoveOnceToXhair -moveOnceToXhairHuman :: MonadClientUI m => m (FailOrCmd RequestAnyAbility) +moveOnceToXhairHuman :: MonadClientUI m => m (FailOrCmd RequestTimed) moveOnceToXhairHuman = goToXhair True False -goToXhair :: MonadClientUI m => Bool -> Bool -> m (FailOrCmd RequestAnyAbility) +goToXhair :: MonadClientUI m => Bool -> Bool -> m (FailOrCmd RequestTimed) goToXhair initialStep run = do aimMode <- getsSession saimMode -- Movement is legal only outside aiming mode. @@ -501,9 +517,10 @@ xhairPos <- xhairToPos case xhairPos of Nothing -> failWith "crosshair position invalid" - Just c | c == bpos b -> - if initialStep - then return $ Right $ RequestAnyAbility ReqWait + Just c | c == bpos b -> do + actorSk <- leaderSkillsClientUI + if initialStep && EM.findWithDefault 0 AbWait actorSk > 0 + then return $ Right $ ReqWait else failWith "position reached" Just c -> do running <- getsSession srunning @@ -574,24 +591,33 @@ -- * RunOnceToXhair -runOnceToXhairHuman :: MonadClientUI m => m (FailOrCmd RequestAnyAbility) +runOnceToXhairHuman :: MonadClientUI m => m (FailOrCmd RequestTimed) runOnceToXhairHuman = goToXhair True True -- * ContinueToXhair -continueToXhairHuman :: MonadClientUI m => m (FailOrCmd RequestAnyAbility) +continueToXhairHuman :: MonadClientUI m => m (FailOrCmd RequestTimed) 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)) + -> m (FailOrCmd RequestTimed) moveItemHuman cLegalRaw destCStore mverb auto = do + actorSk <- leaderSkillsClientUI + if EM.findWithDefault 0 AbMoveItem actorSk > 0 then + moveOrSelectItem cLegalRaw destCStore mverb auto + else failSer MoveItemUnskilled + +-- 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 price. +moveOrSelectItem :: forall m. MonadClientUI m + => [CStore] -> CStore -> Maybe MU.Part -> Bool + -> m (FailOrCmd RequestTimed) +moveOrSelectItem cLegalRaw destCStore mverb auto = do itemSel <- getsSession sitemSel modifySession $ \sess -> sess {sitemSel = Nothing} -- prevent surprise case itemSel of @@ -680,7 +706,7 @@ moveItems :: forall m. MonadClientUI m => [CStore] -> (CStore, [(ItemId, ItemFullKit)]) -> CStore - -> m (FailOrCmd (RequestTimed 'AbMoveItem)) + -> m (FailOrCmd RequestTimed) moveItems cLegalRaw (fromCStore, l) destCStore = do leader <- getLeaderUI b <- getsState $ getActorBody leader @@ -736,25 +762,29 @@ -- * Project -projectHuman :: MonadClientUI m => m (FailOrCmd (RequestTimed 'AbProject)) +projectHuman :: MonadClientUI m => m (FailOrCmd RequestTimed) projectHuman = do - itemSel <- getsSession sitemSel - case itemSel of - Just (iid, fromCStore, _) -> 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 - itemFull <- getsState $ itemToFull iid - let i = (fromCStore, (iid, itemFull)) - projectItem i - Nothing -> failWith "no item to fling" + actorSk <- leaderSkillsClientUI + if EM.findWithDefault 0 AbProject actorSk <= 0 then -- detailed check later + failSer ProjectUnskilled + else do + itemSel <- getsSession sitemSel + case itemSel of + Just (iid, fromCStore, _) -> 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 + itemFull <- getsState $ itemToFull iid + let i = (fromCStore, (iid, itemFull)) + projectItem i + Nothing -> failWith "no item to fling" projectItem :: MonadClientUI m => (CStore, (ItemId, ItemFull)) - -> m (FailOrCmd (RequestTimed 'AbProject)) + -> m (FailOrCmd RequestTimed) projectItem (fromCStore, (iid, itemFull)) = do leader <- getLeaderUI b <- getsState $ getActorBody leader @@ -780,24 +810,28 @@ -- * Apply -applyHuman :: MonadClientUI m => m (FailOrCmd (RequestTimed 'AbApply)) +applyHuman :: MonadClientUI m => m (FailOrCmd RequestTimed) applyHuman = do - itemSel <- getsSession sitemSel - case itemSel of - Just (iid, fromCStore, _) -> 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 - itemFull <- getsState $ itemToFull iid - applyItem (fromCStore, (iid, (itemFull, kit))) - Nothing -> failWith "no item to apply" + actorSk <- leaderSkillsClientUI + if EM.findWithDefault 0 AbApply actorSk <= 0 then -- detailed check later + failSer ApplyUnskilled + else do + itemSel <- getsSession sitemSel + case itemSel of + Just (iid, fromCStore, _) -> 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 + itemFull <- getsState $ itemToFull iid + applyItem (fromCStore, (iid, (itemFull, kit))) + Nothing -> failWith "no item to apply" applyItem :: MonadClientUI m => (CStore, (ItemId, ItemFullKit)) - -> m (FailOrCmd (RequestTimed 'AbApply)) + -> m (FailOrCmd RequestTimed) applyItem (fromCStore, (iid, (itemFull, kit))) = do leader <- getLeaderUI b <- getsState $ getActorBody leader @@ -814,7 +848,7 @@ -- | Ask for a direction and alter a tile in the specified way, if possible. alterDirHuman :: MonadClientUI m - => [TriggerTile] -> m (FailOrCmd (RequestTimed 'AbAlter)) + => [TriggerTile] -> m (FailOrCmd RequestTimed) alterDirHuman ts = do UIOptions{uVi, uLaptop} <- getsSession sUIOptions let verb1 = case ts of @@ -844,7 +878,7 @@ -- | Try to alter a tile using a feature in the given direction. alterTile :: MonadClientUI m - => [TriggerTile] -> Vector -> m (FailOrCmd (RequestTimed 'AbAlter)) + => [TriggerTile] -> Vector -> m (FailOrCmd RequestTimed) alterTile ts dir = do leader <- getLeaderUI b <- getsState $ getActorBody leader @@ -860,7 +894,7 @@ -- the time will be wasted and the server will describe the failure in detail. alterTileAtPos :: MonadClientUI m => [TriggerTile] -> Point -> Text - -> m (FailOrCmd (RequestTimed 'AbAlter)) + -> m (FailOrCmd RequestTimed) alterTileAtPos ts tpos pText = do cops@COps{cotile, coTileSpeedup} <- getsState scops leader <- getLeaderUI @@ -956,7 +990,7 @@ -- | Try to alter a tile using a feature under the pointer. alterWithPointerHuman :: MonadClientUI m - => [TriggerTile] -> m (FailOrCmd (RequestTimed 'AbAlter)) + => [TriggerTile] -> m (FailOrCmd RequestTimed) alterWithPointerHuman ts = do COps{cotile} <- getsState scops lidV <- viewedLevelUI @@ -1174,8 +1208,8 @@ let stdRuleset = getStdRuleset cops lxsize = fst normalLevelBound + 1 lysize = snd normalLevelBound + 4 - xoffset = (110 - lxsize) `div` 2 - yoffset = (60 - lysize) `div` 2 + xoffset = (80 - lxsize) `div` 2 + yoffset = (45 - lysize) `div` 2 tlines = T.lines $ rmainMenuArt stdRuleset f = T.take lxsize . T.drop xoffset return $! map f $ take lysize $ drop yoffset tlines diff --git a/Game/LambdaHack/Client/UI/HandleHumanM.hs b/Game/LambdaHack/Client/UI/HandleHumanM.hs --- a/Game/LambdaHack/Client/UI/HandleHumanM.hs +++ b/Game/LambdaHack/Client/UI/HandleHumanM.hs @@ -3,7 +3,7 @@ ( cmdHumanSem #ifdef EXPOSE_INTERNAL -- * Internal operations - , noRemoteHumanCmd, cmdAction, addNoError, fmapTimedToUI + , noRemoteHumanCmd, cmdAction, addNoError #endif ) where @@ -69,23 +69,23 @@ LoopOnNothing cmd1 -> loopOnNothingHuman (cmdAction cmd1) ExecuteIfClear cmd1 -> executeIfClearHuman (cmdAction cmd1) - Wait -> weaveJust <$> Right <$> fmapTimedToUI waitHuman - Wait10 -> weaveJust <$> Right <$> fmapTimedToUI waitHuman10 + Wait -> weaveJust <$> (ReqUITimed <$$> waitHuman) + Wait10 -> weaveJust <$> (ReqUITimed <$$> waitHuman10) MoveDir v -> weaveJust <$> (ReqUITimed <$$> moveRunHuman True True False False v) RunDir v -> weaveJust <$> (ReqUITimed <$$> moveRunHuman True True True True v) - RunOnceAhead -> runOnceAheadHuman + RunOnceAhead -> ReqUITimed <$$> runOnceAheadHuman MoveOnceToXhair -> weaveJust <$> (ReqUITimed <$$> moveOnceToXhairHuman) RunOnceToXhair -> weaveJust <$> (ReqUITimed <$$> runOnceToXhairHuman) ContinueToXhair -> weaveJust <$> (ReqUITimed <$$> continueToXhairHuman) MoveItem cLegalRaw toCStore mverb auto -> weaveJust - <$> (fmapTimedToUI <$> moveItemHuman cLegalRaw toCStore mverb auto) - Project -> weaveJust <$> (fmapTimedToUI <$> projectHuman) - Apply -> weaveJust <$> (fmapTimedToUI <$> applyHuman) - AlterDir ts -> weaveJust <$> (fmapTimedToUI <$> alterDirHuman ts) + <$> (ReqUITimed <$$> moveItemHuman cLegalRaw toCStore mverb auto) + Project -> weaveJust <$> (ReqUITimed <$$> projectHuman) + Apply -> weaveJust <$> (ReqUITimed <$$> applyHuman) + AlterDir ts -> weaveJust <$> (ReqUITimed <$$> alterDirHuman ts) AlterWithPointer ts -> weaveJust - <$> (fmapTimedToUI <$> alterWithPointerHuman ts) + <$> (ReqUITimed <$$> alterWithPointerHuman ts) Help -> helpHuman cmdAction Hint -> hintHuman cmdAction ItemMenu -> itemMenuHuman cmdAction @@ -145,6 +145,3 @@ addNoError :: Monad m => m () -> m (Either MError ReqUI) addNoError cmdCli = cmdCli >> return (Left Nothing) - -fmapTimedToUI :: Monad m => m (RequestTimed a) -> m ReqUI -fmapTimedToUI mr = ReqUITimed . RequestAnyAbility <$> mr diff --git a/Game/LambdaHack/Client/UI/InventoryM.hs b/Game/LambdaHack/Client/UI/InventoryM.hs --- a/Game/LambdaHack/Client/UI/InventoryM.hs +++ b/Game/LambdaHack/Client/UI/InventoryM.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} -- | UI of inventory management. module Game.LambdaHack.Client.UI.InventoryM ( Suitability(..) diff --git a/Game/LambdaHack/Client/UI/RunM.hs b/Game/LambdaHack/Client/UI/RunM.hs --- a/Game/LambdaHack/Client/UI/RunM.hs +++ b/Game/LambdaHack/Client/UI/RunM.hs @@ -46,7 +46,7 @@ -- | Continue running in the given direction. continueRun :: MonadClientUI m => LevelId -> RunParams - -> m (Either Text RequestAnyAbility) + -> m (Either Text RequestTimed) continueRun arena paramOld = case paramOld of RunParams{ runMembers = [] , runStopMsg = Just stopMsg } -> return $ Left stopMsg @@ -88,7 +88,7 @@ s <- getState modifyClient $ updateLeader r s modifySession $ \sess -> sess {srunning = Just paramNew} - return $ Right $ RequestAnyAbility $ ReqMove dir + return $ Right $ 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 diff --git a/Game/LambdaHack/Common/Actor.hs b/Game/LambdaHack/Common/Actor.hs --- a/Game/LambdaHack/Common/Actor.hs +++ b/Game/LambdaHack/Common/Actor.hs @@ -99,7 +99,7 @@ actorCanMelee actorAspect aid b = let ar = actorAspect EM.! aid actorMaxSk = IA.aSkills ar - condUsableWeapon = bweapon b >= 0 + condUsableWeapon = bweapon b > 0 canMelee = EM.findWithDefault 0 Ability.AbMelee actorMaxSk > 0 in condUsableWeapon && canMelee diff --git a/Game/LambdaHack/Common/Item.hs b/Game/LambdaHack/Common/Item.hs --- a/Game/LambdaHack/Common/Item.hs +++ b/Game/LambdaHack/Common/Item.hs @@ -45,9 +45,9 @@ -- Then they are presented as having a template kind that is really -- not their own, though usually close. Full kind information about -- item's kind is available through the @ItemKindIx@ index once the item --- is identified and full information about the value of item's aspects +-- is identified and full information about the value of item's aspect record -- is available elsewhere (both @IdentityObvious@ and @IdentityCovered@ --- items may or may not need identification of their aspects). +-- items may or may not need identification of their aspect record). data Item = Item { jkind :: ItemIdentity -- ^ the kind of the item, or an indiretion , jlid :: LevelId -- ^ lowest level the item was created at @@ -74,7 +74,8 @@ instance Binary ItemIdentity --- | The map of item ids to item aspects. The full map is known by the server. +-- | The map of item ids to item aspect reocrd. The full map is known +-- by the server. type DiscoveryAspect = EM.EnumMap ItemId IA.AspectRecord -- | An index of the kind identifier of an item. Clients have partial knowledge @@ -84,7 +85,7 @@ deriving (Show, Eq, Ord, Enum, Ix.Ix, Hashable, Binary) -- | The secret part of the information about an item. If a faction --- knows the aspects of the item (the @kmConst@ flag is set or +-- knows the aspect record of the item (the @kmConst@ flag is set or -- the @itemAspect@ field is @Left@), this is a complete secret information. -- Items that don't need second identification may be identified or not and both -- cases are OK (their display flavour will differ and that may be the point). @@ -166,7 +167,7 @@ itemKind = okind coitem itemKindId km = IK.getKindMean itemKindId coItemSpeedup -- If the kind is not identified, we know nothing about the real - -- aspects, so we at least assume they are variable. + -- aspect record, so we at least assume they are variable. itemAspectMean | itemSuspect = km {IA.kmConst = False} | otherwise = km itemDisco = case EM.lookup iid discoAspect of diff --git a/Game/LambdaHack/Common/ItemAspect.hs b/Game/LambdaHack/Common/ItemAspect.hs --- a/Game/LambdaHack/Common/ItemAspect.hs +++ b/Game/LambdaHack/Common/ItemAspect.hs @@ -1,9 +1,9 @@ {-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} -- | The type of item aspects and its operations. module Game.LambdaHack.Common.ItemAspect - ( Aspect(..), AspectRecord(..), KindMean(..), ItemSeed, EqpSlot(..) + ( Aspect(..), AspectRecord(..), KindMean(..), EqpSlot(..) , emptyAspectRecord, addMeanAspect, castAspect, aspectsRandom - , sumAspectRecord, aspectRecordToList, seedToAspect, prEqpSlot + , sumAspectRecord, aspectRecordToList, rollAspectRecord, prEqpSlot #ifdef EXPOSE_INTERNAL -- * Internal operations , ceilingMeanDice @@ -65,20 +65,14 @@ -- | Partial information about an item, deduced from its item kind. -- These are assigned to each 'ItemKind'. The @kmConst@ flag says whether --- the item's aspects are constant rather than random or dependent +-- the item's aspect record is constant rather than random or dependent -- on item creation dungeon level. data KindMean = KindMean { kmConst :: Bool -- ^ whether the item doesn't need second identification - , kmMean :: AspectRecord -- ^ mean value of item's possible aspects + , kmMean :: AspectRecord -- ^ mean value of item's possible aspect records } deriving (Show, Eq, Ord, Generic) --- | 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) - -- | AI and UI hints about the role of the item. data EqpSlot = EqpSlotMiscBonus @@ -272,11 +266,10 @@ ++ [AddAggression $ Dice.intToDice aAggression | aAggression /= 0] ++ [AddAbility ab $ Dice.intToDice n | (ab, n) <- EM.assocs aSkills, n /= 0] -seedToAspect :: ItemSeed -> [Aspect] -> Dice.AbsDepth -> Dice.AbsDepth - -> AspectRecord -seedToAspect (ItemSeed itemSeed) ass ldepth totalDepth = - let rollM = foldlM' (castAspect ldepth totalDepth) emptyAspectRecord ass - in St.evalState rollM (R.mkStdGen itemSeed) +rollAspectRecord :: [Aspect] -> Dice.AbsDepth -> Dice.AbsDepth + -> Rnd AspectRecord +rollAspectRecord ass ldepth totalDepth = + foldlM' (castAspect ldepth totalDepth) emptyAspectRecord ass prEqpSlot :: EqpSlot -> AspectRecord -> Int prEqpSlot eqpSlot ar@AspectRecord{..} = diff --git a/Game/LambdaHack/Common/Misc.hs b/Game/LambdaHack/Common/Misc.hs --- a/Game/LambdaHack/Common/Misc.hs +++ b/Game/LambdaHack/Common/Misc.hs @@ -11,12 +11,14 @@ , toGroupName, describeTactic , makePhrase, makeSentence, squashedWWandW, normalLevelBound , appDataDir, xM, xD, minusM, minusM1, oneM, tenthM + , workaroundOnMainThreadMVar ) where import Prelude () import Game.LambdaHack.Common.Prelude +import Control.Concurrent import Control.DeepSeq import Data.Binary import qualified Data.Char as Char @@ -34,6 +36,7 @@ import qualified NLP.Miniutter.English as MU import System.Directory (getAppUserDataDirectory) import System.Environment (getProgName) +import System.IO.Unsafe (unsafePerformIO) import Game.LambdaHack.Common.Point @@ -205,6 +208,11 @@ minusM1 = xM (-1) - 1 oneM = xM 1 tenthM = 100000 + +-- Global variable for passing the action to run on main thread, if any. +workaroundOnMainThreadMVar :: MVar (IO ()) +{-# NOINLINE workaroundOnMainThreadMVar #-} +workaroundOnMainThreadMVar = unsafePerformIO newEmptyMVar -- Data.Binary orphan instances diff --git a/Game/LambdaHack/Common/ReqFailure.hs b/Game/LambdaHack/Common/ReqFailure.hs --- a/Game/LambdaHack/Common/ReqFailure.hs +++ b/Game/LambdaHack/Common/ReqFailure.hs @@ -23,9 +23,12 @@ -- | Possible causes of failure of request. data ReqFailure = - MoveNothing + MoveUnskilled + | MoveNothing + | MeleeUnskilled | MeleeSelf | MeleeDistant + | DisplaceUnskilled | DisplaceDistant | DisplaceAccess | DisplaceProjectiles @@ -39,6 +42,8 @@ | AlterBlockActor | AlterBlockItem | AlterNothing + | WaitUnskilled + | MoveItemUnskilled | EqpOverfull | EqpStackFull | ApplyUnskilled @@ -63,9 +68,12 @@ impossibleReqFailure :: ReqFailure -> Bool impossibleReqFailure reqFailure = case reqFailure of + MoveUnskilled -> False -- unidentified skill items MoveNothing -> True + MeleeUnskilled -> False -- unidentified skill items MeleeSelf -> True MeleeDistant -> True + DisplaceUnskilled -> False -- unidentified skill items DisplaceDistant -> True DisplaceAccess -> True DisplaceProjectiles -> True @@ -79,12 +87,14 @@ AlterBlockActor -> True -- adjacent actor always visible AlterBlockItem -> True -- adjacent item always visible AlterNothing -> True + WaitUnskilled -> False -- unidentified skill items + MoveItemUnskilled -> False -- unidentified skill items EqpOverfull -> True EqpStackFull -> True ApplyUnskilled -> False -- unidentified skill items ApplyRead -> False -- unidentified skill items ApplyOutOfReach -> True - ApplyCharging -> False -- if aspects unknown, charging unknown + ApplyCharging -> False -- if aspect record unknown, charging unknown ApplyNoEffects -> False -- if effects unknown, can't prevent it ItemNothing -> True ItemNotCalm -> False -- unidentified skill items @@ -100,9 +110,12 @@ showReqFailure :: ReqFailure -> Text showReqFailure reqFailure = case reqFailure of + MoveUnskilled -> "unskilled actors cannot move" MoveNothing -> "wasting time on moving into obstacle" + MeleeUnskilled -> "unskilled actors cannot melee" MeleeSelf -> "trying to melee oneself" MeleeDistant -> "trying to melee a distant foe" + DisplaceUnskilled -> "unskilled actors cannot displace" DisplaceDistant -> "trying to displace a distant actor" DisplaceAccess -> "switching places without access" DisplaceProjectiles -> "trying to displace multiple projectiles" @@ -116,6 +129,8 @@ AlterBlockActor -> "blocked by an actor" AlterBlockItem -> "jammed by an item" AlterNothing -> "wasting time on altering nothing" + WaitUnskilled -> "unskilled actors cannot wait" + MoveItemUnskilled -> "unskilled actors cannot move items" EqpOverfull -> "cannot equip any more items" EqpStackFull -> "cannot equip the whole item stack" ApplyUnskilled -> "unskilled actors cannot apply items" diff --git a/Game/LambdaHack/Common/State.hs b/Game/LambdaHack/Common/State.hs --- a/Game/LambdaHack/Common/State.hs +++ b/Game/LambdaHack/Common/State.hs @@ -65,7 +65,7 @@ , _sgameModeId :: ContentId ModeKind -- ^ current game mode , _sdiscoKind :: DiscoveryKind -- ^ item kind discoveries data , _sdiscoAspect :: DiscoveryAspect -- ^ item aspect data; could be recomputed - , _sactorAspect :: ActorAspect -- ^ actor aspects; is recomputed + , _sactorAspect :: ActorAspect -- ^ actor aspect records; is recomputed } deriving (Show, Eq) @@ -275,7 +275,7 @@ getItemBody :: ItemId -> State -> Item getItemBody iid s = sitemD s EM.! iid --- This is best guess, including mean aspects, so we can take into +-- This is best guess, including mean aspect record, so we can take into -- consideration even the kind the item hides under. aspectRecordFromItem :: ItemId -> Item -> State -> IA.AspectRecord aspectRecordFromItem iid item s = diff --git a/Game/LambdaHack/Content/RuleKind.hs b/Game/LambdaHack/Content/RuleKind.hs --- a/Game/LambdaHack/Content/RuleKind.hs +++ b/Game/LambdaHack/Content/RuleKind.hs @@ -21,7 +21,7 @@ -- | The type of game rule sets and assorted game data. -- --- In principle, it'se possible to have many rule sets +-- In principle, it's possible to have many rule sets -- and switch between them during a game session or even a single game. data RuleKind = RuleKind { rsymbol :: Char -- ^ a symbol @@ -54,12 +54,12 @@ validateSingle :: RuleKind -> [Text] validateSingle RuleKind{rmainMenuArt} = let ts = T.lines rmainMenuArt - tsNot110 = filter ((/= 110) . T.length) ts - in case tsNot110 of - [] -> [ "rmainMenuArt doesn't have 60 lines, but " <> tshow (length ts) - | length ts /= 60] - tNot110 : _ -> - ["rmainMenuArt has a line with length other than 110:" <> tNot110] + tsNot80 = filter ((/= 80) . T.length) ts + in case tsNot80 of + [] -> [ "rmainMenuArt doesn't have 45 lines, but " <> tshow (length ts) + | length ts /= 45] + tNot80 : _ -> + ["rmainMenuArt has a line with length other than 80:" <> tNot80] -- | Since we have only one rule kind, the set of rule kinds is always valid. validateAll :: [RuleKind] -> ContentData RuleKind -> [Text] diff --git a/Game/LambdaHack/Server/BroadcastAtomic.hs b/Game/LambdaHack/Server/BroadcastAtomic.hs --- a/Game/LambdaHack/Server/BroadcastAtomic.hs +++ b/Game/LambdaHack/Server/BroadcastAtomic.hs @@ -53,7 +53,7 @@ return (ps, atomicBroken, executedOnServer) -- | Send an atomic action to all clients that can see it. -handleAndBroadcast :: (MonadServerAtomic m, MonadServerReadRequest m) +handleAndBroadcast :: (MonadServerAtomic m, MonadServerComm m) => PosAtomic -> [UpdAtomic] -> CmdAtomic -> m () handleAndBroadcast ps atomicBroken atomic = do -- This is calculated in the server State before action (simulating @@ -148,7 +148,7 @@ return $ Just $ SfxLoudSummon (bproj b) grp p _ -> return Nothing -sendPer :: (MonadServerAtomic m, MonadServerReadRequest m) +sendPer :: (MonadServerAtomic m, MonadServerComm m) => FactionId -> LevelId -> Perception -> Perception -> Perception -> m () {-# INLINE sendPer #-} diff --git a/Game/LambdaHack/Server/Commandline.hs b/Game/LambdaHack/Server/Commandline.hs --- a/Game/LambdaHack/Server/Commandline.hs +++ b/Game/LambdaHack/Server/Commandline.hs @@ -24,7 +24,7 @@ -- remaining commandline should be passed and parsed by the client to extract -- client and ui options from and singnal an error if anything was left. -import Game.LambdaHack.Client.ClientOptions +import Game.LambdaHack.Client (ClientOptions (..)) import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.ModeKind diff --git a/Game/LambdaHack/Server/CommonM.hs b/Game/LambdaHack/Server/CommonM.hs --- a/Game/LambdaHack/Server/CommonM.hs +++ b/Game/LambdaHack/Server/CommonM.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TupleSections #-} -- | Server operations common to many modules. module Game.LambdaHack.Server.CommonM - ( execFailure, revealItems, moveStores, generalMoveItem + ( revealItems, moveStores, generalMoveItem , deduceQuits, deduceKilled, electLeader, supplantLeader , updatePer, recomputeCachePer, projectFail , addActorFromGroup, registerActor, discoverIfMinorEffects @@ -18,11 +18,8 @@ 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 Game.LambdaHack.Client import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState @@ -51,26 +48,6 @@ import Game.LambdaHack.Server.ServerOptions import Game.LambdaHack.Server.State -execFailure :: MonadServerAtomic 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 - revealItems :: MonadServerAtomic m => Maybe FactionId -> m () revealItems mfid = do COps{coitem} <- getsState scops @@ -79,8 +56,8 @@ let itemKind = okind coitem itemKindId c = CActor aid store unless (IK.isHumanTrinket itemKind) $ do -- a hack - seed <- getsServer $ (EM.! iid) . sitemSeedD - execUpdAtomic $ UpdDiscover c iid itemKindId seed + discoAspect <- getsState sdiscoAspect + execUpdAtomic $ UpdDiscover c iid itemKindId $ discoAspect EM.! iid f aid = do b <- getsState $ getActorBody aid let ourSide = maybe True (== bfid b) mfid @@ -377,23 +354,22 @@ -- We bootstrap the actor by first creating the trunk of the actor's body -- that contains the constant properties. let trunkFreq = [(actorGroup, 1)] - m4 <- rollItem 0 lid trunkFreq - case m4 of + m3 <- rollItem 0 lid trunkFreq + case m3 of Nothing -> return Nothing - Just (itemKnown, itemFullKit, seed, _) -> - Just <$> registerActor False itemKnown itemFullKit seed bfid pos lid time + Just (itemKnown, itemFullKit, _) -> + Just <$> registerActor False itemKnown itemFullKit bfid pos lid time registerActor :: MonadServerAtomic m - => Bool -> ItemKnown -> ItemFullKit -> IA.ItemSeed + => Bool -> ItemKnown -> ItemFullKit -> FactionId -> Point -> LevelId -> Time -> m ActorId -registerActor summoned (kindIx, ar, _) (itemFullRaw, kit) - seed bfid pos lid time = do +registerActor summoned (kindIx, ar, _) (itemFullRaw, kit) bfid pos lid time = do let container = CTrunk bfid lid pos jfid = Just bfid itemKnown = (kindIx, ar, jfid) itemFull = itemFullRaw {itemBase = (itemBase itemFullRaw) {jfid}} - trunkId <- registerItem (itemFull, kit) itemKnown seed container False + trunkId <- registerItem (itemFull, kit) itemKnown container False addNonProjectile summoned trunkId (itemFull, kit) bfid pos lid time addProjectile :: MonadServerAtomic m @@ -488,8 +464,8 @@ let itemKind = okind coitem itemKindId if IK.onlyMinorEffects itemKind then do - seed <- getsServer $ (EM.! iid) . sitemSeedD - execUpdAtomic $ UpdDiscover c iid itemKindId seed + discoAspect <- getsState sdiscoAspect + execUpdAtomic $ UpdDiscover c iid itemKindId $ discoAspect EM.! iid else return () -- discover by use when item's effects get activated later on pickWeaponServer :: MonadServer m => ActorId -> m (Maybe (ItemId, CStore)) diff --git a/Game/LambdaHack/Server/DebugM.hs b/Game/LambdaHack/Server/DebugM.hs --- a/Game/LambdaHack/Server/DebugM.hs +++ b/Game/LambdaHack/Server/DebugM.hs @@ -18,7 +18,7 @@ import qualified Text.Show.Pretty as Show.Pretty import Game.LambdaHack.Atomic -import Game.LambdaHack.Client +import Game.LambdaHack.Client (Response (..)) import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction diff --git a/Game/LambdaHack/Server/EndM.hs b/Game/LambdaHack/Server/EndM.hs --- a/Game/LambdaHack/Server/EndM.hs +++ b/Game/LambdaHack/Server/EndM.hs @@ -14,7 +14,7 @@ import qualified Data.EnumMap.Strict as EM import Game.LambdaHack.Atomic -import Game.LambdaHack.Client +import Game.LambdaHack.Client (sbenchmark) import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction @@ -32,7 +32,7 @@ import Game.LambdaHack.Server.State -- | Continue or exit or restart the game. -endOrLoop :: (MonadServerAtomic m, MonadServerReadRequest m) +endOrLoop :: (MonadServerAtomic m, MonadServerComm m) => m () -> (Maybe (GroupName ModeKind) -> m ()) -> m () endOrLoop loop restart = do @@ -62,7 +62,7 @@ | not $ null campers -> gameExit -- and @loop@ is not called | otherwise -> loop -- continue current game -gameExit :: (MonadServerAtomic m, MonadServerReadRequest m) => m () +gameExit :: (MonadServerAtomic m, MonadServerComm m) => m () gameExit = do -- debugPossiblyPrint "Verifying all perceptions." -- Verify that the possibly not saved caches are equal to future diff --git a/Game/LambdaHack/Server/HandleEffectM.hs b/Game/LambdaHack/Server/HandleEffectM.hs --- a/Game/LambdaHack/Server/HandleEffectM.hs +++ b/Game/LambdaHack/Server/HandleEffectM.hs @@ -34,7 +34,6 @@ import qualified Data.Ord as Ord import Game.LambdaHack.Atomic -import Game.LambdaHack.Client import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import qualified Game.LambdaHack.Common.Dice as Dice @@ -125,6 +124,18 @@ [] -> return () aid : _ -> execUpdAtomic $ UpdLeadFaction (bfid tb) mleader $ Just aid +cutCalm :: MonadServerAtomic m => ActorId -> m () +cutCalm target = do + tb <- getsState $ getActorBody target + ar <- getsState $ getActorAspect target + let upperBound = if hpTooLow tb ar + then 2 -- to trigger domination on next attack, etc. + else xM $ IA.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 + -- 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 :: MonadServerAtomic m @@ -256,8 +267,8 @@ -- Note: @UseId@ suffices for identification, @UseUp@ is not necessary. when (ur >= UseId && not (IK.onlyMinorEffects itemKind)) $ do kindId <- getsState $ getIidKindIdServer iid - seed <- getsServer $ (EM.! iid) . sitemSeedD - execUpdAtomic $ UpdDiscover c iid kindId seed + discoAspect <- getsState sdiscoAspect + execUpdAtomic $ UpdDiscover c iid kindId $ discoAspect EM.! iid return ur -- | The source actor affects the target actor, with a given effect and power. @@ -389,14 +400,14 @@ ++ [zip (repeat True) $ take 8 (drop ((k100 + fuzz) `mod` 8) $ cycle psFuzz)] forM_ ps $ \(centerRaw, tpxy) -> do - let req = ReqProject tpxy veryrandom iid COrgan - center = centerRaw && itemK >= 8 -- if few, keep them regular + let center = centerRaw && itemK >= 8 -- if few, keep them regular mfail <- projectFail target tpxy veryrandom center iid COrgan True case mfail of Nothing -> return () Just ProjectBlockTerrain -> return () Just ProjectBlockActor | not $ bproj tb -> return () - Just failMsg -> execFailure target req failMsg + Just failMsg -> + execSfxAtomic $ SfxMsgFid (bfid tb) $ SfxUnexpected failMsg tryFlying 0 = return () tryFlying k100 = do -- Explosion particles are placed among organs of the victim: @@ -439,18 +450,6 @@ refillHP source target deltaHP return UseUp -cutCalm :: MonadServerAtomic m => ActorId -> m () -cutCalm target = do - tb <- getsState $ getActorBody target - ar <- getsState $ getActorAspect target - let upperBound = if hpTooLow tb ar - then 0 -- to trigger domination, etc. - else xM $ IA.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 :: MonadServerAtomic m @@ -974,9 +973,9 @@ bagBefore <- getsState $ getBodyStoreBag tb store let litemFreq = [(grp, 1)] -- Power depth of new items unaffected by number of spawned actors. - m4 <- rollItem 0 (blid tb) litemFreq - let (itemKnownRaw, (itemFullRaw, kitRaw), seed, _) = - fromMaybe (error $ "" `showFailure` (blid tb, litemFreq, c)) m4 + m3 <- rollItem 0 (blid tb) litemFreq + let (itemKnownRaw, (itemFullRaw, kitRaw), _) = + fromMaybe (error $ "" `showFailure` (blid tb, litemFreq, c)) m3 -- Avoid too many different item identifiers (one for each faction) -- for blasts or common item generating tiles. Temporary organs are -- allowed to be duplicated, because they provide really useful info @@ -1019,7 +1018,7 @@ -- No such items or some items, but void delta, so create items. -- If it's, e.g., a periodic poison, the new items will stack with any -- already existing items. - iid <- registerItem (itemFull, kitNew) itemKnown seed c True + iid <- registerItem (itemFull, kitNew) itemKnown c True -- If created not on the ground, ID it, because it won't be on pickup. when (store /= CGround) $ discoverIfMinorEffects c iid (itemKindId itemFull) @@ -1178,8 +1177,8 @@ identifyIid :: MonadServerAtomic m => ItemId -> Container -> ContentId ItemKind -> m () identifyIid iid c itemKindId = do - seed <- getsServer $ (EM.! iid) . sitemSeedD - execUpdAtomic $ UpdDiscover c iid itemKindId seed + discoAspect <- getsState sdiscoAspect + execUpdAtomic $ UpdDiscover c iid itemKindId $ discoAspect EM.! iid -- ** Detect diff --git a/Game/LambdaHack/Server/HandleRequestM.hs b/Game/LambdaHack/Server/HandleRequestM.hs --- a/Game/LambdaHack/Server/HandleRequestM.hs +++ b/Game/LambdaHack/Server/HandleRequestM.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GADTs #-} -- | Semantics of requests -- . -- A couple of them do not take time, the rest does. @@ -13,9 +12,9 @@ , reqMove, reqDisplace, reqAlterFail, reqGameDropAndExit, reqGameSaveAndExit #ifdef EXPOSE_INTERNAL -- * Internal operations - , setBWait, managePerRequest, handleRequestTimedCases - , affectSmell, reqMelee, reqAlter, reqWait - , reqMoveItems, reqMoveItem, computeRndTimeout, reqProject, reqApply + , execFailure, setBWait, managePerRequest, handleRequestTimedCases + , affectSmell, reqMelee, reqMeleeChecked, reqAlter + , reqWait, reqMoveItems, reqMoveItem, computeRndTimeout, reqProject, reqApply , reqGameRestart, reqGameSave, reqTactic, reqAutomate #endif ) where @@ -25,9 +24,12 @@ 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 Game.LambdaHack.Client +import Game.LambdaHack.Client (ReqAI (..), ReqUI (..), + RequestTimed (..)) import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState @@ -56,11 +58,31 @@ import Game.LambdaHack.Server.ServerOptions import Game.LambdaHack.Server.State +execFailure :: MonadServerAtomic m + => ActorId -> RequestTimed -> 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 + -- | The semantics of server commands. -- AI always takes time and so doesn't loop. handleRequestAI :: MonadServerAtomic m => ReqAI - -> m (Maybe RequestAnyAbility) + -> m (Maybe RequestTimed) handleRequestAI cmd = case cmd of ReqAITimed cmdT -> return $ Just cmdT ReqAINop -> return Nothing @@ -68,7 +90,7 @@ -- | The semantics of server commands. Only the first two cases affect time. handleRequestUI :: MonadServerAtomic m => FactionId -> ActorId -> ReqUI - -> m (Maybe RequestAnyAbility) + -> m (Maybe RequestTimed) handleRequestUI fid aid cmd = case cmd of ReqUITimed cmdT -> return $ Just cmdT ReqUIGameRestart t d -> reqGameRestart aid t d >> return Nothing @@ -83,7 +105,7 @@ -- and unsetting in all other requests, we call this once before -- executing a request. setBWait :: MonadServerAtomic m - => RequestTimed a -> ActorId -> Actor -> m (Maybe Bool) + => RequestTimed -> ActorId -> Actor -> m (Maybe Bool) {-# INLINE setBWait #-} setBWait cmd aid b = do let mwait = case cmd of @@ -95,7 +117,7 @@ return mwait handleRequestTimed :: MonadServerAtomic m - => FactionId -> ActorId -> RequestTimed a -> m Bool + => FactionId -> ActorId -> RequestTimed -> m Bool handleRequestTimed fid aid cmd = do b <- getsState $ getActorBody aid mwait <- setBWait cmd aid b @@ -123,7 +145,7 @@ execUpdAtomic $ UpdRefillHP aid clearMark handleRequestTimedCases :: MonadServerAtomic m - => ActorId -> RequestTimed a -> m () + => ActorId -> RequestTimed -> m () handleRequestTimedCases aid cmd = case cmd of ReqMove target -> reqMove aid target ReqMelee target iid cstore -> reqMelee aid target iid cstore @@ -206,8 +228,11 @@ reqMove :: MonadServerAtomic m => ActorId -> Vector -> m () reqMove source dir = do COps{coTileSpeedup} <- getsState scops + actorSk <- currentSkillsServer source sb <- getsState $ getActorBody source - let lid = blid sb + let abInSkill ab = isJust (btrajectory sb) + || EM.findWithDefault 0 ab actorSk > 0 + lid = blid sb lvl <- getLevel lid let spos = bpos sb -- source position tpos = spos `shift` dir -- target position @@ -250,15 +275,20 @@ -- Below the only weapon (the only item) of projectiles is picked. 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. + Just (wp, cstore) | abInSkill Ability.AbMelee -> + reqMeleeChecked source target wp cstore + _ -> return () -- waiting, even if no @AbWait@ ability + _ -> do + -- Either the position is empty, or all involved actors are proj. + -- Movement requires full access and skill. + if Tile.isWalkable coTileSpeedup $ lvl `at` tpos then + if abInSkill Ability.AbMove then do execUpdAtomic $ UpdMoveActor source spos tpos affectSmell source - | otherwise -> - -- Client foolishly tries to move into blocked, boring tile. - execFailure source (ReqMove dir) MoveNothing + else execFailure source (ReqMove dir) MoveUnskilled + else + -- Client foolishly tries to move into unwalkable tile. + execFailure source (ReqMove dir) MoveNothing -- * ReqMelee @@ -272,6 +302,14 @@ reqMelee :: MonadServerAtomic m => ActorId -> ActorId -> ItemId -> CStore -> m () reqMelee source target iid cstore = do + actorSk <- currentSkillsServer source + if EM.findWithDefault 0 Ability.AbMelee actorSk > 0 then + reqMeleeChecked source target iid cstore + else execFailure source (ReqMelee target iid cstore) MeleeUnskilled + +reqMeleeChecked :: MonadServerAtomic m + => ActorId -> ActorId -> ItemId -> CStore -> m () +reqMeleeChecked source target iid cstore = do sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target let req = ReqMelee target iid cstore @@ -371,7 +409,10 @@ reqDisplace :: MonadServerAtomic m => ActorId -> ActorId -> m () reqDisplace source target = do COps{coTileSpeedup} <- getsState scops + actorSk <- currentSkillsServer source sb <- getsState $ getActorBody source + let abInSkill ab = isJust (btrajectory sb) + || EM.findWithDefault 0 ab actorSk > 0 tb <- getsState $ getActorBody target tfact <- getsState $ (EM.! bfid tb) . sfactionD let tpos = bpos tb @@ -379,7 +420,9 @@ req = ReqDisplace target ar <- getsState $ getActorAspect target dEnemy <- getsState $ dispEnemy source target $ IA.aSkills ar - if | not (checkAdjacent sb tb) -> execFailure source req DisplaceDistant + if | not (abInSkill Ability.AbDisplace) -> + execFailure source req DisplaceUnskilled + | not (checkAdjacent sb tb) -> execFailure source req DisplaceDistant | atWar && not dEnemy -> do -- if not at war, can displace always -- We don't fail with DisplaceImmobile and DisplaceSupported. -- because it's quite common they can't be determined by the attacker, @@ -389,8 +432,9 @@ -- verify here that they don't occur, for simplicity. mweapon <- pickWeaponServer source case mweapon of - Nothing -> reqWait source - Just (wp, cstore) -> reqMelee source target wp cstore + Just (wp, cstore) | abInSkill Ability.AbMelee -> + reqMeleeChecked source target wp cstore + _ -> return () -- waiting, even if no @AbWait@ ability | otherwise -> do let lid = blid sb lvl <- getLevel lid @@ -573,19 +617,25 @@ -- Something is sometimes done in 'setBWait'. reqWait :: MonadServerAtomic m => ActorId -> m () {-# INLINE reqWait #-} -reqWait _ = return () +reqWait source = do + actorSk <- currentSkillsServer source + unless (EM.findWithDefault 0 Ability.AbWait actorSk > 0) $ + execFailure source ReqWait WaitUnskilled -- * ReqMoveItems reqMoveItems :: MonadServerAtomic m => ActorId -> [(ItemId, Int, CStore, CStore)] -> m () -reqMoveItems aid l = do - b <- getsState $ getActorBody aid - ar <- getsState $ getActorAspect 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 ar - mapM_ (reqMoveItem aid calmE) l +reqMoveItems source l = do + actorSk <- currentSkillsServer source + if EM.findWithDefault 0 Ability.AbMoveItem actorSk > 0 then do + b <- getsState $ getActorBody source + ar <- getsState $ getActorAspect source + -- 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 ar + mapM_ (reqMoveItem source calmE) l + else execFailure source (ReqMoveItems l) MoveItemUnskilled reqMoveItem :: MonadServerAtomic m => ActorId -> Bool -> (ItemId, Int, CStore, CStore) -> m () diff --git a/Game/LambdaHack/Server/ItemM.hs b/Game/LambdaHack/Server/ItemM.hs --- a/Game/LambdaHack/Server/ItemM.hs +++ b/Game/LambdaHack/Server/ItemM.hs @@ -23,7 +23,6 @@ import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.ContentData import Game.LambdaHack.Common.Item -import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc @@ -42,8 +41,8 @@ import Game.LambdaHack.Server.ServerOptions import Game.LambdaHack.Server.State -onlyRegisterItem :: MonadServerAtomic m => ItemKnown -> IA.ItemSeed -> m ItemId -onlyRegisterItem itemKnown@(_, aspectRecord, _) seed = do +onlyRegisterItem :: MonadServerAtomic m => ItemKnown -> m ItemId +onlyRegisterItem itemKnown@(_, aspectRecord, _) = do itemRev <- getsServer sitemRev case HM.lookup itemKnown itemRev of Just iid -> return iid @@ -53,17 +52,16 @@ execUpdAtomicSer $ UpdDiscoverServer icounter aspectRecord let !_A = assert executedOnServer () modifyServer $ \ser -> - ser { sitemSeedD = EM.insert icounter seed (sitemSeedD ser) - , sitemRev = HM.insert itemKnown icounter (sitemRev ser) + ser { sitemRev = HM.insert itemKnown icounter (sitemRev ser) , sicounter = succ icounter } return $! icounter registerItem :: MonadServerAtomic m - => ItemFullKit -> ItemKnown -> IA.ItemSeed -> Container -> Bool + => ItemFullKit -> ItemKnown -> Container -> Bool -> m ItemId registerItem (ItemFull{itemBase, itemKindId, itemKind}, kit) - itemKnown seed container verbose = do - iid <- onlyRegisterItem itemKnown seed + itemKnown@(_, aspectRecord, _) container verbose = do + iid <- onlyRegisterItem itemKnown let cmd = if verbose then UpdCreateItem else UpdSpotItem False execUpdAtomic $ cmd iid itemBase kit container let worth = itemPrice (fst kit) itemKind @@ -71,7 +69,7 @@ knowItems <- getsServer $ sknowItems . soptions when knowItems $ case container of CTrunk{} -> return () - _ -> execUpdAtomic $ UpdDiscover container iid itemKindId seed + _ -> execUpdAtomic $ UpdDiscover container iid itemKindId aspectRecord return iid createLevelItem :: MonadServerAtomic m => Point -> LevelId -> m () @@ -93,7 +91,7 @@ rollItem :: MonadServerAtomic m => Int -> LevelId -> Freqs ItemKind - -> m (Maybe (ItemKnown, ItemFullKit, IA.ItemSeed, GroupName ItemKind)) + -> m (Maybe (ItemKnown, ItemFullKit, GroupName ItemKind)) rollItem lvlSpawned lid itemFreq = do cops <- getsState scops flavour <- getsServer sflavour @@ -101,15 +99,15 @@ uniqueSet <- getsServer suniqueSet totalDepth <- getsState stotalDepth Level{ldepth} <- getLevel lid - m4 <- rndToAction $ newItem cops flavour discoRev uniqueSet + m3 <- rndToAction $ newItem cops flavour discoRev uniqueSet itemFreq lvlSpawned lid ldepth totalDepth - case m4 of - Just (_, (ItemFull{itemKindId, itemKind}, _), _, _) -> + case m3 of + Just (_, (ItemFull{itemKindId, itemKind}, _), _) -> when (IK.Unique `elem` IK.ifeature itemKind) $ modifyServer $ \ser -> ser {suniqueSet = ES.insert itemKindId (suniqueSet ser)} _ -> return () - return m4 + return m3 rollAndRegisterItem :: MonadServerAtomic m => LevelId -> Freqs ItemKind -> Container -> Bool @@ -117,12 +115,12 @@ -> m (Maybe (ItemId, (ItemFullKit, GroupName ItemKind))) rollAndRegisterItem lid itemFreq container verbose mk = do -- Power depth of new items unaffected by number of spawned actors. - m4 <- rollItem 0 lid itemFreq - case m4 of + m3 <- rollItem 0 lid itemFreq + case m3 of Nothing -> return Nothing - Just (itemKnown, (itemFull, kit), seed, itemGroup) -> do + Just (itemKnown, (itemFull, kit), itemGroup) -> do let kit2 = (fromMaybe (fst kit) mk, snd kit) - iid <- registerItem (itemFull, kit2) itemKnown seed container verbose + iid <- registerItem (itemFull, kit2) itemKnown container verbose return $ Just (iid, ((itemFull, kit2), itemGroup)) placeItemsInDungeon :: forall m. MonadServerAtomic m diff --git a/Game/LambdaHack/Server/ItemRev.hs b/Game/LambdaHack/Server/ItemRev.hs --- a/Game/LambdaHack/Server/ItemRev.hs +++ b/Game/LambdaHack/Server/ItemRev.hs @@ -4,7 +4,7 @@ module Game.LambdaHack.Server.ItemRev ( ItemKnown, ItemRev, UniqueSet, buildItem, newItem -- * Item discovery types - , DiscoveryKindRev, ItemSeedDict, emptyDiscoveryKindRev, serverDiscos + , DiscoveryKindRev, emptyDiscoveryKindRev, serverDiscos -- * The @FlavourMap@ type , FlavourMap, emptyFlavourMap, dungeonFlavourMap ) where @@ -42,7 +42,7 @@ -- However, the first item generated by the server wins, which in case -- of normal items (not organs), is most of the time the lower absolute -- @jlid@ (shallower depth) item, which makes sense for the client. --- Note 2: @ItemSeed@ instead of @AspectRecord@ is not enough, +-- Note 2: item seed 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 = (ItemIdentity, IA.AspectRecord, Maybe FactionId) @@ -73,7 +73,7 @@ -- | Generate an item based on level. newItem :: COps -> FlavourMap -> DiscoveryKindRev -> UniqueSet -> Freqs ItemKind -> Int -> LevelId -> Dice.AbsDepth -> Dice.AbsDepth - -> Rnd (Maybe (ItemKnown, ItemFullKit, IA.ItemSeed, GroupName ItemKind)) + -> Rnd (Maybe (ItemKnown, ItemFullKit, GroupName ItemKind)) newItem cops@COps{coitem} flavourMap discoRev uniqueSet itemFreq lvlSpawned lid ldepth@(Dice.AbsDepth ldAbs) totalDepth@(Dice.AbsDepth depth) = do @@ -110,21 +110,18 @@ ((itemKindId, itemKind), itemGroup) <- frequency freq -- Number of new items/actors unaffected by number of spawned actors. itemN <- castDice ldepth totalDepth (IK.icount itemKind) - seed <- toEnum <$> random let itemBase = buildItem cops flavourMap discoRev itemKindId itemKind lid itemIdentity = jkind itemBase itemK = max 1 itemN itemTimer = [timeZero | IK.Periodic `elem` IK.ifeature itemKind] -- delay first discharge of single organs itemSuspect = False - itemDisco = ItemDiscoFull {..} -- Bonuses on items/actors unaffected by number of spawned actors. - itemAspect = - IA.seedToAspect seed (IK.iaspects itemKind) ldepth totalDepth + itemAspect <- IA.rollAspectRecord (IK.iaspects itemKind) ldepth totalDepth + let itemDisco = ItemDiscoFull {..} itemFull = ItemFull {..} return $ Just ( (itemIdentity, itemAspect, jfid itemBase) , (itemFull, (itemK, itemTimer)) - , seed , itemGroup ) -- | The reverse map to @DiscoveryKind@, needed for item creation. @@ -132,9 +129,6 @@ -- Morally, it's indexed by @ContentId ItemKind@ and elements are @ItemKindIx@. newtype DiscoveryKindRev = DiscoveryKindRev (U.Vector Word16) deriving (Show, Binary) - --- | The map of item ids to item seeds, needed for item creation. -type ItemSeedDict = EM.EnumMap ItemId IA.ItemSeed emptyDiscoveryKindRev :: DiscoveryKindRev emptyDiscoveryKindRev = DiscoveryKindRev U.empty diff --git a/Game/LambdaHack/Server/LoopM.hs b/Game/LambdaHack/Server/LoopM.hs --- a/Game/LambdaHack/Server/LoopM.hs +++ b/Game/LambdaHack/Server/LoopM.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GADTs #-} -- | The main loop of the server, processing human and computer player -- moves turn by turn. module Game.LambdaHack.Server.LoopM @@ -21,7 +20,7 @@ import qualified Data.Ord as Ord import Game.LambdaHack.Atomic -import Game.LambdaHack.Client +import Game.LambdaHack.Client (ReqUI (..)) import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction @@ -53,7 +52,7 @@ -- communicating with the clients. -- -- The loop is started in server state that is empty, see 'emptyStateServer'. -loopSer :: (MonadServerAtomic m, MonadServerReadRequest m) +loopSer :: (MonadServerAtomic m, MonadServerComm m) => ServerOptions -- ^ player-supplied server options -> (Bool -> FactionId -> ChanServer -> IO ()) @@ -129,7 +128,7 @@ `swith` factionD) () return $! arenas -handleFidUpd :: (MonadServerAtomic m, MonadServerReadRequest m) +handleFidUpd :: (MonadServerAtomic m, MonadServerComm m) => (FactionId -> m ()) -> FactionId -> Faction -> m () {-# INLINE handleFidUpd #-} handleFidUpd updatePerFid fid fact = do @@ -159,7 +158,7 @@ -- | Handle a clip (the smallest fraction of a game turn for which a frame may -- potentially be generated). Run the leader and other actors moves. -- Eventually advance the time and repeat. -loopUpd :: forall m. (MonadServerAtomic m, MonadServerReadRequest m) +loopUpd :: forall m. (MonadServerAtomic m, MonadServerComm m) => m () -> m () loopUpd updConn = do let updatePerFid :: FactionId -> m () @@ -436,7 +435,7 @@ $ execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing _ -> error $ "Nothing trajectory" `showFailure` (aid, b) -handleActors :: (MonadServerAtomic m, MonadServerReadRequest m) +handleActors :: (MonadServerAtomic m, MonadServerComm m) => LevelId -> FactionId -> m Bool handleActors lid fid = do localTime <- getsState $ getLocalTime lid @@ -460,7 +459,7 @@ Just aid | aid `elem` l -> aid : delete aid l _ -> l -hActors :: forall m. (MonadServerAtomic m, MonadServerReadRequest m) +hActors :: forall m. (MonadServerAtomic m, MonadServerComm m) => [ActorId] -> m Bool hActors [] = return False hActors as@(aid : rest) = do @@ -506,7 +505,7 @@ mtimed <- handleRequestUI side aidNew cmd return (aidNew, mtimed) case mtimed of - Just (RequestAnyAbility timed) -> do + Just timed -> do nonWaitMove <- handleRequestTimed side aidNew timed -- Even if the actor got a free turn of time via a scroll, -- he will not act again this clip, only next clip. diff --git a/Game/LambdaHack/Server/MonadServer.hs b/Game/LambdaHack/Server/MonadServer.hs --- a/Game/LambdaHack/Server/MonadServer.hs +++ b/Game/LambdaHack/Server/MonadServer.hs @@ -33,7 +33,7 @@ import qualified System.Random as R import Game.LambdaHack.Atomic -import Game.LambdaHack.Client +import Game.LambdaHack.Client (sbenchmark) import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.File diff --git a/Game/LambdaHack/Server/PeriodicM.hs b/Game/LambdaHack/Server/PeriodicM.hs --- a/Game/LambdaHack/Server/PeriodicM.hs +++ b/Game/LambdaHack/Server/PeriodicM.hs @@ -83,10 +83,10 @@ lvl <- getLevel lid factionD <- getsState sfactionD lvlSpawned <- getsServer $ fromMaybe 0 . EM.lookup lid . snumSpawned - m4 <- rollItem lvlSpawned lid actorFreq - case m4 of + m3 <- rollItem lvlSpawned lid actorFreq + case m3 of Nothing -> return Nothing - Just (itemKnownRaw, (itemFullRaw, kit), seed, _) -> do + Just (itemKnownRaw, (itemFullRaw, kit), _) -> do let freqNames = map fst $ IK.ifreq $ itemKind itemFullRaw f fact = fgroups (gplayer fact) factGroups = concatMap f $ EM.elems factionD @@ -110,7 +110,7 @@ rollPos <- getsState $ rollSpawnPos cops allPers mobile lid lvl fid rndToAction rollPos Just <$> registerActor summoned itemKnownRaw (itemFullRaw, kit) - seed fid pos lid time + fid pos lid time rollSpawnPos :: COps -> ES.EnumSet Point -> Bool -> LevelId -> Level -> FactionId -> State diff --git a/Game/LambdaHack/Server/ProtocolM.hs b/Game/LambdaHack/Server/ProtocolM.hs --- a/Game/LambdaHack/Server/ProtocolM.hs +++ b/Game/LambdaHack/Server/ProtocolM.hs @@ -3,7 +3,7 @@ ( -- * The communication channels CliSerQueue, ConnServerDict, ChanServer(..) -- * The server-client communication monad - , MonadServerReadRequest + , MonadServerComm ( getsDict -- exposed only to be implemented, not used , modifyDict -- exposed only to be implemented, not used , liftIO -- exposed only to be implemented, not used @@ -31,7 +31,8 @@ import System.IO.Unsafe (unsafePerformIO) import Game.LambdaHack.Atomic -import Game.LambdaHack.Client +import Game.LambdaHack.Client (RequestAI, RequestUI, Response (..), + sbenchmark) import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.File @@ -48,17 +49,17 @@ import Game.LambdaHack.Server.ServerOptions import Game.LambdaHack.Server.State -writeQueue :: MonadServerReadRequest m +writeQueue :: MonadServerComm m => Response -> CliSerQueue Response -> m () {-# INLINE writeQueue #-} writeQueue cmd responseS = liftIO $ putMVar responseS cmd -readQueueAI :: MonadServerReadRequest m +readQueueAI :: MonadServerComm m => CliSerQueue RequestAI -> m RequestAI {-# INLINE readQueueAI #-} readQueueAI requestS = liftIO $ takeMVar requestS -readQueueUI :: MonadServerReadRequest m +readQueueUI :: MonadServerComm m => CliSerQueue RequestUI -> m RequestUI {-# INLINE readQueueUI #-} readQueueUI requestS = liftIO $ takeMVar requestS @@ -79,20 +80,20 @@ } -- | The server monad with the ability to communicate with clients. -class MonadServer m => MonadServerReadRequest m where +class MonadServer m => MonadServerComm m where getsDict :: (ConnServerDict -> a) -> m a modifyDict :: (ConnServerDict -> ConnServerDict) -> m () liftIO :: IO a -> m a -getDict :: MonadServerReadRequest m => m ConnServerDict +getDict :: MonadServerComm m => m ConnServerDict getDict = getsDict id -putDict :: MonadServerReadRequest m => ConnServerDict -> m () +putDict :: MonadServerComm m => ConnServerDict -> m () putDict s = modifyDict (const s) -- | If the @AtomicFail@ conditions hold, send a command to client, -- otherwise do nothing. -sendUpdate :: (MonadServerAtomic m, MonadServerReadRequest m) +sendUpdate :: (MonadServerAtomic m, MonadServerComm m) => FactionId -> UpdAtomic -> m () sendUpdate !fid !cmd = do succeeded <- execUpdAtomicFidCatch fid cmd @@ -100,13 +101,13 @@ -- | Send a command to client, crashing if the @AtomicFail@ conditions -- don't hold when executed on the client's state. -sendUpdateCheck :: (MonadServerAtomic m, MonadServerReadRequest m) +sendUpdateCheck :: (MonadServerAtomic m, MonadServerComm m) => FactionId -> UpdAtomic -> m () sendUpdateCheck !fid !cmd = do execUpdAtomicFid fid cmd sendUpd fid cmd -sendUpd :: MonadServerReadRequest m => FactionId -> UpdAtomic -> m () +sendUpd :: MonadServerComm m => FactionId -> UpdAtomic -> m () sendUpd !fid !cmd = do chan <- getsDict (EM.! fid) s <- getsServer $ (EM.! fid) . sclientStates @@ -115,7 +116,7 @@ when debug $ debugResponse fid resp writeQueue resp $ responseS chan -sendUpdNoState :: MonadServerReadRequest m => FactionId -> UpdAtomic -> m () +sendUpdNoState :: MonadServerComm m => FactionId -> UpdAtomic -> m () sendUpdNoState !fid !cmd = do chan <- getsDict (EM.! fid) let resp = RespUpdAtomicNoState cmd @@ -123,7 +124,7 @@ when debug $ debugResponse fid resp writeQueue resp $ responseS chan -sendSfx :: MonadServerReadRequest m => FactionId -> SfxAtomic -> m () +sendSfx :: MonadServerComm m => FactionId -> SfxAtomic -> m () sendSfx !fid !sfx = do let resp = RespSfxAtomic sfx debug <- getsServer $ sniff . soptions @@ -133,7 +134,7 @@ ChanServer{requestUIS=Just{}} -> writeQueue resp $ responseS chan _ -> return () -sendQueryAI :: MonadServerReadRequest m => FactionId -> ActorId -> m RequestAI +sendQueryAI :: MonadServerComm m => FactionId -> ActorId -> m RequestAI sendQueryAI fid aid = do let respAI = RespQueryAI aid debug <- getsServer $ sniff . soptions @@ -145,7 +146,7 @@ when debug $ debugRequestAI aid return req -sendQueryUI :: (MonadServerAtomic m, MonadServerReadRequest m) +sendQueryUI :: (MonadServerAtomic m, MonadServerComm m) => FactionId -> ActorId -> m RequestUI sendQueryUI fid _aid = do let respUI = RespQueryUI @@ -158,7 +159,7 @@ when debug $ debugRequestUI _aid return req -killAllClients :: (MonadServerAtomic m, MonadServerReadRequest m) => m () +killAllClients :: (MonadServerAtomic m, MonadServerComm m) => m () killAllClients = do d <- getDict let sendKill fid _ = sendUpdNoState fid $ UpdKillExit fid @@ -174,7 +175,7 @@ -- | 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 :: (MonadServerAtomic m, MonadServerReadRequest m) +updateConn :: (MonadServerAtomic m, MonadServerComm m) => (Bool -> FactionId -> ChanServer -> IO ()) -> m () updateConn executorClient = do @@ -211,7 +212,7 @@ forkUI fid conn liftIO $ mapWithKeyM_ forkClient toSpawn -tryRestore :: MonadServerReadRequest m => m (Maybe (State, StateServer)) +tryRestore :: MonadServerComm m => m (Maybe (State, StateServer)) tryRestore = do cops <- getsState scops soptions <- getsServer soptions diff --git a/Game/LambdaHack/Server/ServerOptions.hs b/Game/LambdaHack/Server/ServerOptions.hs --- a/Game/LambdaHack/Server/ServerOptions.hs +++ b/Game/LambdaHack/Server/ServerOptions.hs @@ -10,7 +10,7 @@ import Data.Binary import qualified System.Random as R -import Game.LambdaHack.Client +import Game.LambdaHack.Client (ClientOptions (..), defClientOptions) import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.ModeKind diff --git a/Game/LambdaHack/Server/StartM.hs b/Game/LambdaHack/Server/StartM.hs --- a/Game/LambdaHack/Server/StartM.hs +++ b/Game/LambdaHack/Server/StartM.hs @@ -186,8 +186,9 @@ rnd :: Rnd (FactionDict, FlavourMap, DiscoveryKind, DiscoveryKindRev, DungeonGen.FreshDungeon, ContentId ModeKind) rnd = do - modeKindId <- fromMaybe (error $ "" `showFailure` gameMode) - <$> opick comode gameMode (const True) + modeKindId <- + fromMaybe (error $ "Unknown game mode:" `showFailure` gameMode) + <$> opick comode gameMode (const True) let mode = okind comode modeKindId automatePS ps = ps {rosterList = map (first $ automatePlayer True) $ rosterList ps} diff --git a/Game/LambdaHack/Server/State.hs b/Game/LambdaHack/Server/State.hs --- a/Game/LambdaHack/Server/State.hs +++ b/Game/LambdaHack/Server/State.hs @@ -36,7 +36,6 @@ , sdiscoKindRev :: DiscoveryKindRev -- ^ reverse map, used for item creation , suniqueSet :: UniqueSet -- ^ already generated unique items - , sitemSeedD :: ItemSeedDict -- ^ map from item ids to item seeds , sitemRev :: ItemRev -- ^ reverse id map, used for item creation , sflavour :: FlavourMap -- ^ association of flavour to items , sacounter :: ActorId -- ^ stores next actor index @@ -76,7 +75,6 @@ , sactorStasis = ES.empty , sdiscoKindRev = emptyDiscoveryKindRev , suniqueSet = ES.empty - , sitemSeedD = EM.empty , sitemRev = HM.empty , sflavour = emptyFlavourMap , sacounter = toEnum 0 @@ -118,7 +116,6 @@ put sactorStasis put sdiscoKindRev put suniqueSet - put sitemSeedD put sitemRev put sflavour put sacounter @@ -133,7 +130,6 @@ sactorStasis <- get sdiscoKindRev <- get suniqueSet <- get - sitemSeedD <- get sitemRev <- get sflavour <- get sacounter <- get diff --git a/GameDefinition/Content/CaveKind.hs b/GameDefinition/Content/CaveKind.hs --- a/GameDefinition/Content/CaveKind.hs +++ b/GameDefinition/Content/CaveKind.hs @@ -121,8 +121,8 @@ { csymbol = 'E' , cname = "Tall cavern" , cfreq = [("caveEmpty", 1)] - , cgrid = DiceXY 1 1 - , cminPlaceSize = DiceXY 12 12 + , cgrid = DiceXY 2 2 + , cminPlaceSize = DiceXY 12 9 , cmaxPlaceSize = DiceXY 48 32 -- favour large rooms , cdarkChance = 1 `d` 100 + 1 `dL` 100 , cnightChance = 0 -- always day diff --git a/GameDefinition/Content/ItemKind.hs b/GameDefinition/Content/ItemKind.hs --- a/GameDefinition/Content/ItemKind.hs +++ b/GameDefinition/Content/ItemKind.hs @@ -233,7 +233,8 @@ light1 = ItemKind { isymbol = symbolLight , iname = "wooden torch" - , ifreq = [("common item", 100), ("light source", 100), ("wooden torch", 1)] + , ifreq = [ ("common item", 100), ("light source", 100) + , ("wooden torch", 1) ] , iflavour = zipPlain [Brown] , icount = 1 `dL` 4 , irarity = [(1, 15)] @@ -245,7 +246,7 @@ , ieffects = [Burn 1] , ifeature = [Lobable, Equipable, EqpSlot EqpSlotLightSource] -- not Fragile; reusable flare - , idesc = "A smoking, heavy wooden torch, burning in an unsteady glow." + , idesc = "A heavy smoking wooden torch, improvised using a cloth soaked in tar, burning in an unsteady glow." , ikit = [] } light2 = ItemKind diff --git a/GameDefinition/Content/RuleKind.hs b/GameDefinition/Content/RuleKind.hs --- a/GameDefinition/Content/RuleKind.hs +++ b/GameDefinition/Content/RuleKind.hs @@ -44,17 +44,10 @@ -- The keybindings overwrite places marked with left curly brace signs. -- This sign is forbidden anywhere else in the picture. -- The picture and the whole main menu is displayed dull white on black. - -- - -- The picture should be exactly 60 rows by 110 columns, - -- but only the middle rectangle of 24 rows by 80 columns is partially - -- overwritten with UI information and the curly brace signs are allowed - -- only there. So, the rectangle is 15 characters distant from the left - -- and 18 from top. For screen sizes larger than 60 by 100, - -- the picture is centered and padded with spaces, so it makes sense - -- for some or all of the picture borders to be spaces, as well. - -- If the screen is smaller than 60 by 100, borders of the picture - -- are cut off. Minimal screes size is 24 by 80 and the picture - -- should look well at this size, as well. + -- The glyphs, or at least the character cells, are perfect squares. + -- The picture should be exactly 45 rows by 80 columns. + -- For larger screen sizes, the picture is centered and padded with spaces, + -- so it makes sense for some or all of the picture borders to be spaces. , rmainMenuArt = $(do let path = "GameDefinition/MainMenu.ascii" qAddDependentFile path diff --git a/GameDefinition/Content/TileKind.hs b/GameDefinition/Content/TileKind.hs --- a/GameDefinition/Content/TileKind.hs +++ b/GameDefinition/Content/TileKind.hs @@ -117,7 +117,6 @@ , talter = 2 , tfeature = [ RevealAs "trapped vertical door Lit" , ObscureAs "obscured vertical wall Lit" - ] } wallObscured = TileKind @@ -129,7 +128,6 @@ , talter = 5 , tfeature = [ Embed "scratch on wall" , HideAs "suspect vertical wall Lit" - ] } wallH = TileKind @@ -139,9 +137,7 @@ , tcolor = BrWhite , tcolor2 = defFG , talter = 100 - , tfeature = [ BuildAs "suspect horizontal wall Lit" - - ] + , tfeature = [BuildAs "suspect horizontal wall Lit"] } wallSuspectH = TileKind -- only on client { tsymbol = '-' @@ -152,7 +148,6 @@ , talter = 2 , tfeature = [ RevealAs "trapped horizontal door Lit" , ObscureAs "obscured horizontal wall Lit" - ] } wallObscuredDefacedH = TileKind @@ -164,7 +159,6 @@ , talter = 5 , tfeature = [ Embed "obscene pictogram" , HideAs "suspect horizontal wall Lit" - ] } wallObscuredFrescoedH = TileKind @@ -176,7 +170,6 @@ , talter = 5 , tfeature = [ Embed "subtle fresco" , HideAs "suspect horizontal wall Lit" - ] -- a bit beneficial, but AI would loop if allowed to trigger -- so no @ConsideredByAI@ } @@ -222,7 +215,6 @@ , talter = 5 , tfeature = [ ConsideredByAI -- changes after use, so safe for AI , RevealAs "signboard" -- to display as hidden - ] } signboardRead = TileKind @@ -299,7 +291,6 @@ , tfeature = [ Embed "doorway trap" , OpenTo "open vertical door Lit" , HideAs "suspect vertical wall Lit" - ] } doorClosed = TileKind @@ -321,7 +312,6 @@ , tfeature = [ Embed "doorway trap" , OpenTo "open horizontal door Lit" , HideAs "suspect horizontal wall Lit" - ] } doorClosedH = TileKind diff --git a/GameDefinition/Implementation/MonadClientImplementation.hs b/GameDefinition/Implementation/MonadClientImplementation.hs --- a/GameDefinition/Implementation/MonadClientImplementation.hs +++ b/GameDefinition/Implementation/MonadClientImplementation.hs @@ -19,7 +19,6 @@ import Game.LambdaHack.Atomic (MonadStateWrite (..), putState) import Game.LambdaHack.Client -import Game.LambdaHack.Client.ClientOptions import Game.LambdaHack.Client.HandleAtomicM import Game.LambdaHack.Client.HandleResponseM import Game.LambdaHack.Client.LoopM diff --git a/GameDefinition/Implementation/MonadServerImplementation.hs b/GameDefinition/Implementation/MonadServerImplementation.hs --- a/GameDefinition/Implementation/MonadServerImplementation.hs +++ b/GameDefinition/Implementation/MonadServerImplementation.hs @@ -77,7 +77,7 @@ chanSaveServer = SerImplementation $ gets serToSave liftIO = SerImplementation . IO.liftIO -instance MonadServerReadRequest SerImplementation where +instance MonadServerComm SerImplementation where {-# INLINE getsDict #-} getsDict f = SerImplementation $ gets $ f . serDict {-# INLINE modifyDict #-} diff --git a/GameDefinition/Main.hs b/GameDefinition/Main.hs --- a/GameDefinition/Main.hs +++ b/GameDefinition/Main.hs @@ -8,6 +8,7 @@ import Game.LambdaHack.Common.Prelude +import Control.Concurrent import Control.Concurrent.Async import qualified Control.Exception as Ex import qualified Options.Applicative as OA @@ -19,9 +20,9 @@ import qualified System.IO as SIO import Game.LambdaHack.Common.File (tryCreateDir) -import Game.LambdaHack.Common.Misc #endif +import Game.LambdaHack.Common.Misc import Game.LambdaHack.Server (serverOptionsPI) import Implementation.TieKnot @@ -30,9 +31,14 @@ -- run the game and handle exit. main :: IO () main = do + -- This may be broken with JS and also bloats the outcome file, so disabled. #ifndef USE_JSFILE - -- For the case when the game is started not on a console. - -- This is broken with JS and also bloats the outcome file. + -- Special case hack, when the game is started not on a console. + -- Without this, any attempt to output on stdout crashes a Windows exe + -- (at least on Windows Vista) launched from the desktop or start menu. + -- This is very crude and results in the inability to, e.g., process + -- the output of @--help@ through a unix pipe. However, this should be + -- effective on all Windows version, without the need to test all. isTerminal <- SIO.hIsTerminalDevice SIO.stdout unless isTerminal $ do dataDir <- appDataDir @@ -41,12 +47,23 @@ fstderr <- SIO.openFile (dataDir "stderr.txt") SIO.WriteMode GHC.IO.Handle.hDuplicateTo fstdout SIO.stdout GHC.IO.Handle.hDuplicateTo fstderr SIO.stderr + let fillWorkaround = + -- Set up void workaround if nothing specific required. + void $ tryPutMVar workaroundOnMainThreadMVar $ return () #endif -- Fail here, not inside server code, so that savefiles are not removed, -- because they are not the source of the failure. !serverOptions <- OA.execParser serverOptionsPI -- Avoid the bound thread that would slow down the communication. a <- async $ tieKnot serverOptions +#ifndef USE_JSFILE + `Ex.finally` fillWorkaround + -- Run a (possibly void) workaround. It's needed for architectures/frontends + -- that need to perform some actions on the main thread + -- (not just any bound thread), e.g., newer OS X drawing with SDL2. + workaround <- takeMVar workaroundOnMainThreadMVar + workaround +#endif resOrEx <- waitCatch a let unwrapEx e = #if MIN_VERSION_async(2,2,1) diff --git a/GameDefinition/MainMenu.ascii b/GameDefinition/MainMenu.ascii --- a/GameDefinition/MainMenu.ascii +++ b/GameDefinition/MainMenu.ascii @@ -1,60 +1,45 @@ - - - - - - - - - - - - - - - - - - - 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). - - - - - - - - - - - - - - - - - - + + + + + + + + + + +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). + + + + + + + + + + + diff --git a/LambdaHack.cabal b/LambdaHack.cabal --- a/LambdaHack.cabal +++ b/LambdaHack.cabal @@ -5,13 +5,13 @@ -- PVP summary:+-+------- breaking API changes -- | | +----- minor or non-breaking API additions -- | | | +--- code changes with no API change -version: 0.8.1.2 +version: 0.8.3.0 synopsis: A game engine library for tactical squad ASCII roguelike dungeon crawlers description: LambdaHack is a Haskell game engine library for ASCII roguelike games of arbitrary theme, size and complexity, with optional tactical squad combat. It's packaged together with a sample dungeon crawler in fantasy setting that can be tried out - in the browser: + in the browser at . (It runs fastest on Chrome. Keyboard commands and savefiles are supported only on recent enough versions of browsers. Mouse should work everywhere.) @@ -93,7 +93,7 @@ manual: True flag jsaddle - description: switch to the JSaddle frontend + description: switch to the JSaddle frontend (may be bit-rotted) default: False manual: True diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -82,7 +82,7 @@ dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --newGame 3 --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 7000 --automateAll --keepAutomated --gameMode battle --setDungeonRng 7 --setMainRng 7 benchFrontendBattle: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --newGame 3 --noAnim --maxFps 100000 --benchmark --stopAfterFrames 1500 --automateAll --keepAutomated --gameMode battle --setDungeonRng 7 --setMainRng 7 + dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --newGame 3 --noAnim --maxFps 100000 --benchmark --stopAfterFrames 2000 --automateAll --keepAutomated --gameMode battle --setDungeonRng 7 --setMainRng 7 benchCrawl: dist/build/LambdaHack/LambdaHack --dbgMsgSer --logPriority 4 --newGame 1 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 7000 --automateAll --keepAutomated --gameMode crawl --setDungeonRng 0 --setMainRng 0 @@ -217,11 +217,18 @@ cp COPYLEFT LambdaHackTheGame cp CREDITS LambdaHackTheGame -build-binary: build-binary-common +build-binary-ubuntu: build-binary-common cp LambdaHackTheGameInstall/bin/LambdaHack LambdaHackTheGame dist/build/LambdaHack/LambdaHack --version > /dev/null; \ LH_VERSION=$$(cat ~/.LambdaHack/stdout.txt); \ tar -czf LambdaHack_$${LH_VERSION}_ubuntu-16.04-amd64.tar.gz LambdaHackTheGame + +build-binary-macosx: build-binary-common + cp LambdaHackTheGameInstall/bin/LambdaHack LambdaHackTheGame + dist/build/LambdaHack/LambdaHack --version > /dev/null; \ + LH_VERSION=$$(cat ~/.LambdaHack/stdout.txt); \ + OS_VERSION=$$(sw_vers -productVersion); \ + tar -czf LambdaHack_$${LH_VERSION}_macosx-$${OS_VERSION}-amd64.tar.gz LambdaHackTheGame new-build-dev: cabal new-build --datadir=. --disable-optimization -j1 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ games of arbitrary theme, size and complexity, with optional tactical squad combat. It's packaged together with a sample dungeon crawler in fantasy setting that can be tried out -in the browser: http://lambdahack.github.io +in the browser at http://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.) @@ -82,16 +82,19 @@ you may prefer to use a native binary for your architecture, if it exists. Pre-compiled game binaries are available through -the release page[11] (and continuously from AppVeyor[18]). -Note that Windows binaries no longer work on Windows XP, since Cygwin -and MSYS2 dropped support for XP. To use a pre-compiled binary archive, -unpack it and run the executable in the unpacked directory -or use program shortcuts from the installer, if available. +the release page[11] (and, for Windows, continuously from AppVeyor[18]). +To use a pre-compiled binary archive, unpack it and run the executable +in the unpacked directory or use program shortcuts from the installer, +if available. On Linux, make sure you have the SDL2 libraries installed on your system -(e.g., libsdl2-2.0-0, libsdl2-ttf-2.0-0 on Ubuntu; also libdw1). -For Windows, the SDL2 and all other needed libraries are already contained -in the game's binary archive. +(e.g., libsdl2-2.0-0, libsdl2-ttf-2.0-0 on Ubuntu). +On Mac OS X, you need SDL2 installed, e.g., +from [libsdlorg](https://www.libsdl.org/download-2.0.php). +For Windows, the SDL2 and all other needed libraries are already +contained in the game's binary archive. +Note that Windows binaries no longer work on Windows XP, since Cygwin +and MSYS2 dropped support for XP. Screen and keyboard configuration @@ -155,7 +158,7 @@ cabal update cabal install LambdaHack -For a newer snapshot, download the source code from github[5] +For a newer snapshot, clone the source code from github[5] and run Cabal from the main directory cabal install @@ -247,7 +250,7 @@ [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 +[11]: https://github.com/LambdaHack/LambdaHack/releases [15]: https://github.com/ghcjs/ghcjs [16]: https://www.npmjs.com/package/google-closure-compiler [18]: https://ci.appveyor.com/project/Mikolaj/lambdahack/build/artifacts