diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,26 @@ +## [v0.6.2.0, aka 'Zoom out'](https://github.com/LambdaHack/LambdaHack/compare/v0.6.1.0...v0.6.2.0) + +- make fireworks slower and so easier to spot +- make rattlesnake deeper but more common +- announce no effect of activation +- describe original and current faction of an actor +- highlight dominated actors +- mark organs with comma instead of percent and gems with dollar +- make the healing cave dangerous to prevent camping +- slightly balance various content +- by default move item the same as last time +- often spawn between heroes and stairs going deeper +- fix totalUsefulness computation for negative effects +- fix abandoning distant enemy target despite no alternatives +- fix slow pushing of actors +- fix a crash when many actors run towards stairs +- hotfix: Pass zoom keys through to the browser +- help players find the info about changing the font size +- depend on GHC >= 8.0 and new vector +- specialize client code already in SampleMonadClient.hs +- enable StrictData in all modules +- replace 'failure' with 'error' that now shows call stack + ## [v0.6.1.0, aka 'Breaking one rule at a time'](https://github.com/LambdaHack/LambdaHack/compare/v0.6.0.0...v0.6.1.0) - fix redrawing after window minimized and restored 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 @@ -46,8 +46,8 @@ -- | Abstract syntax of atomic commands, that is, atomic game state -- transformations. data CmdAtomic = - UpdAtomic !UpdAtomic -- ^ atomic updates - | SfxAtomic !SfxAtomic -- ^ atomic special effects + UpdAtomic UpdAtomic -- ^ atomic updates + | SfxAtomic SfxAtomic -- ^ atomic special effects deriving (Show, Eq, Generic) instance Binary CmdAtomic @@ -58,58 +58,58 @@ -- that help clients determine whether and how to communicate them to players. data UpdAtomic = -- Create/destroy actors and items. - UpdCreateActor !ActorId !Actor ![(ItemId, Item)] - | UpdDestroyActor !ActorId !Actor ![(ItemId, Item)] - | UpdCreateItem !ItemId !Item !ItemQuant !Container - | UpdDestroyItem !ItemId !Item !ItemQuant !Container - | UpdSpotActor !ActorId !Actor ![(ItemId, Item)] - | UpdLoseActor !ActorId !Actor ![(ItemId, Item)] - | UpdSpotItem !Bool !ItemId !Item !ItemQuant !Container - | UpdLoseItem !Bool !ItemId !Item !ItemQuant !Container + UpdCreateActor ActorId Actor [(ItemId, Item)] + | UpdDestroyActor ActorId Actor [(ItemId, Item)] + | UpdCreateItem ItemId Item ItemQuant Container + | UpdDestroyItem ItemId Item ItemQuant Container + | UpdSpotActor ActorId Actor [(ItemId, Item)] + | UpdLoseActor ActorId Actor [(ItemId, Item)] + | UpdSpotItem Bool ItemId Item ItemQuant Container + | UpdLoseItem Bool ItemId Item ItemQuant Container -- Move actors and items. - | UpdMoveActor !ActorId !Point !Point - | UpdWaitActor !ActorId !Bool - | UpdDisplaceActor !ActorId !ActorId - | UpdMoveItem !ItemId !Int !ActorId !CStore !CStore + | UpdMoveActor ActorId Point Point + | UpdWaitActor ActorId Bool + | UpdDisplaceActor ActorId ActorId + | UpdMoveItem ItemId Int ActorId CStore CStore -- Change actor attributes. - | UpdRefillHP !ActorId !Int64 - | UpdRefillCalm !ActorId !Int64 - | UpdTrajectory !ActorId !(Maybe ([Vector], Speed)) !(Maybe ([Vector], Speed)) + | UpdRefillHP ActorId Int64 + | UpdRefillCalm ActorId Int64 + | UpdTrajectory ActorId (Maybe ([Vector], Speed)) (Maybe ([Vector], Speed)) -- Change faction attributes. - | UpdQuitFaction !FactionId !(Maybe Status) !(Maybe Status) - | UpdLeadFaction !FactionId !(Maybe ActorId) !(Maybe ActorId) - | UpdDiplFaction !FactionId !FactionId !Diplomacy !Diplomacy - | UpdTacticFaction !FactionId !Tactic !Tactic - | UpdAutoFaction !FactionId !Bool - | UpdRecordKill !ActorId !(Kind.Id ItemKind) !Int + | UpdQuitFaction FactionId (Maybe Status) (Maybe Status) + | UpdLeadFaction FactionId (Maybe ActorId) (Maybe ActorId) + | UpdDiplFaction FactionId FactionId Diplomacy Diplomacy + | UpdTacticFaction FactionId Tactic Tactic + | UpdAutoFaction FactionId Bool + | UpdRecordKill ActorId (Kind.Id ItemKind) Int -- Alter map. - | UpdAlterTile !LevelId !Point !(Kind.Id TileKind) !(Kind.Id TileKind) - | UpdAlterExplorable !LevelId !Int - | UpdSearchTile !ActorId !Point !(Kind.Id TileKind) - | UpdHideTile !ActorId !Point !(Kind.Id TileKind) - | UpdSpotTile !LevelId ![(Point, Kind.Id TileKind)] - | UpdLoseTile !LevelId ![(Point, Kind.Id TileKind)] - | UpdAlterSmell !LevelId !Point !Time !Time - | UpdSpotSmell !LevelId ![(Point, Time)] - | UpdLoseSmell !LevelId ![(Point, Time)] + | UpdAlterTile LevelId Point (Kind.Id TileKind) (Kind.Id TileKind) + | UpdAlterExplorable LevelId Int + | UpdSearchTile ActorId Point (Kind.Id TileKind) + | UpdHideTile ActorId Point (Kind.Id TileKind) + | UpdSpotTile LevelId [(Point, Kind.Id TileKind)] + | UpdLoseTile LevelId [(Point, Kind.Id TileKind)] + | UpdAlterSmell LevelId Point Time Time + | UpdSpotSmell LevelId [(Point, Time)] + | UpdLoseSmell LevelId [(Point, Time)] -- Assorted. - | UpdTimeItem !ItemId !Container !ItemTimer !ItemTimer - | UpdAgeGame ![LevelId] - | UpdUnAgeGame ![LevelId] - | UpdDiscover !Container !ItemId !(Kind.Id ItemKind) !ItemSeed - | UpdCover !Container !ItemId !(Kind.Id ItemKind) !ItemSeed - | UpdDiscoverKind !Container !ItemId !(Kind.Id ItemKind) - | UpdCoverKind !Container !ItemId !(Kind.Id ItemKind) - | UpdDiscoverSeed !Container !ItemId !ItemSeed - | UpdCoverSeed !Container !ItemId !ItemSeed - | UpdPerception !LevelId !Perception !Perception - | UpdRestart !FactionId !DiscoveryKind !PerLid !State !Challenge !DebugModeCli - | UpdRestartServer !State - | UpdResume !FactionId !PerLid - | UpdResumeServer !State - | UpdKillExit !FactionId + | UpdTimeItem ItemId Container ItemTimer ItemTimer + | UpdAgeGame [LevelId] + | UpdUnAgeGame [LevelId] + | UpdDiscover Container ItemId (Kind.Id ItemKind) ItemSeed + | UpdCover Container ItemId (Kind.Id ItemKind) ItemSeed + | UpdDiscoverKind Container ItemId (Kind.Id ItemKind) + | UpdCoverKind Container ItemId (Kind.Id ItemKind) + | UpdDiscoverSeed Container ItemId ItemSeed + | UpdCoverSeed Container ItemId ItemSeed + | UpdPerception LevelId Perception Perception + | UpdRestart FactionId DiscoveryKind PerLid State Challenge DebugModeCli + | UpdRestartServer State + | UpdResume FactionId PerLid + | UpdResumeServer State + | UpdKillExit FactionId | UpdWriteSave - | UpdMsgAll !Text + | UpdMsgAll Text deriving (Show, Eq, Generic) instance Binary UpdAtomic @@ -117,41 +117,42 @@ -- | Abstract syntax of atomic special effects, that is, atomic commands -- that only display special effects and don't change the state. data SfxAtomic = - SfxStrike !ActorId !ActorId !ItemId !CStore - | SfxRecoil !ActorId !ActorId !ItemId !CStore - | SfxSteal !ActorId !ActorId !ItemId !CStore - | SfxRelease !ActorId !ActorId !ItemId !CStore - | SfxProject !ActorId !ItemId !CStore - | SfxReceive !ActorId !ItemId !CStore - | SfxApply !ActorId !ItemId !CStore - | SfxCheck !ActorId !ItemId !CStore - | SfxTrigger !ActorId !Point - | SfxShun !ActorId !Point - | SfxEffect !FactionId !ActorId !IK.Effect !Int64 - | SfxMsgFid !FactionId !SfxMsg + SfxStrike ActorId ActorId ItemId CStore + | SfxRecoil ActorId ActorId ItemId CStore + | SfxSteal ActorId ActorId ItemId CStore + | SfxRelease ActorId ActorId ItemId CStore + | SfxProject ActorId ItemId CStore + | SfxReceive ActorId ItemId CStore + | SfxApply ActorId ItemId CStore + | SfxCheck ActorId ItemId CStore + | SfxTrigger ActorId Point + | SfxShun ActorId Point + | SfxEffect FactionId ActorId IK.Effect Int64 + | SfxMsgFid FactionId SfxMsg deriving (Show, Eq, Generic) instance Binary SfxAtomic data SfxMsg = - SfxUnexpected !ReqFailure - | SfxLoudUpd !Bool !UpdAtomic - | SfxLoudStrike !Bool !(Kind.Id ItemKind) !Int - | SfxLoudSummon !Bool !(GroupName ItemKind) !Dice.Dice + SfxUnexpected ReqFailure + | SfxLoudUpd Bool UpdAtomic + | SfxLoudStrike Bool (Kind.Id ItemKind) Int + | SfxLoudSummon Bool (GroupName ItemKind) Dice.Dice | SfxFizzles + | SfxNothingHappens | SfxVoidDetection - | SfxSummonLackCalm !ActorId + | SfxSummonLackCalm ActorId | SfxLevelNoMore | SfxLevelPushed - | SfxBracedImmune !ActorId + | SfxBracedImmune ActorId | SfxEscapeImpossible | SfxTransImpossible - | SfxIdentifyNothing !CStore - | SfxPurposeNothing !CStore - | SfxPurposeTooFew !Int !Int + | SfxIdentifyNothing CStore + | SfxPurposeNothing CStore + | SfxPurposeTooFew Int Int | SfxPurposeUnique | SfxColdFish - | SfxTimerExtended !ActorId !ItemId !CStore + | SfxTimerExtended ActorId ItemId CStore deriving (Show, Eq, Generic) instance Binary SfxMsg 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 @@ -105,15 +105,15 @@ updCreateActor aid body ais = do -- Add actor to @sactorD@. let f Nothing = Just body - f (Just b) = assert `failure` "actor already added" - `twith` (aid, body, b) + f (Just b) = error $ "actor already added" + `showFailure` (aid, body, b) modifyState $ updateActorD $ EM.alter f aid -- Add actor to @sprio@. let g Nothing = Just [aid] g (Just l) = #ifdef WITH_EXPENSIVE_ASSERTIONS assert (aid `notElem` l `blame` "actor already added" - `twith` (aid, body, l)) + `swith` (aid, body, l)) #endif (Just $ aid : l) updateLevel (blid body) $ updateActorMap (EM.alter g (bpos body)) @@ -124,7 +124,7 @@ let h item1 item2 = assert (itemsMatch item1 item2 `blame` "inconsistent created actor items" - `twith` (aid, body, iid, item1, item2)) + `swith` (aid, body, iid, item1, item2)) item2 -- keep the first found level modifyState $ updateItemD $ EM.insertWith h iid item @@ -146,18 +146,18 @@ -- Assert that actor's items belong to @sitemD@. Do not remove those -- that do not appear anywhere else, for simplicity and speed. let !_A = assert (allB match ais `blame` "destroyed actor items not found" - `twith` (aid, body, ais, itemD)) () + `swith` (aid, body, ais, itemD)) () -- Remove actor from @sactorD@. - let f Nothing = assert `failure` "actor already removed" `twith` (aid, body) + let f Nothing = error $ "actor already removed" `showFailure` (aid, body) f (Just b) = assert (b == body `blame` "inconsistent destroyed actor body" - `twith` (aid, body, b)) Nothing + `swith` (aid, body, b)) Nothing modifyState $ updateActorD $ EM.alter f aid -- Remove actor from @lactor@. - let g Nothing = assert `failure` "actor already removed" `twith` (aid, body) + let g Nothing = error $ "actor already removed" `showFailure` (aid, body) g (Just l) = #ifdef WITH_EXPENSIVE_ASSERTIONS assert (aid `elem` l `blame` "actor already removed" - `twith` (aid, body, l)) + `swith` (aid, body, l)) #endif (let l2 = delete aid l in if null l2 then Nothing else Just l2) @@ -189,7 +189,7 @@ Nothing -> False Just item0 -> itemsMatch item0 item) `blame` "item already removed" - `twith` (iid, item, itemD)) () + `swith` (iid, item, itemD)) () deleteItemContainer iid kit c updMoveActor :: MonadStateWrite m => ActorId -> Point -> Point -> m () @@ -197,7 +197,7 @@ body <- getsState $ getActorBody aid let !_A = assert (fromP == bpos body `blame` "unexpected moved actor position" - `twith` (aid, fromP, toP, bpos body, body)) () + `swith` (aid, fromP, toP, bpos body, body)) () newBody = body {bpos = toP, boldpos = Just fromP} updateActor aid $ const newBody moveActorMap aid body newBody @@ -207,7 +207,7 @@ b <- getsState $ getActorBody aid let !_A = assert (toWait /= bwait b `blame` "unexpected waited actor time" - `twith` (aid, toWait, bwait b, b)) () + `swith` (aid, toWait, bwait b, b)) () updateActor aid $ \body -> body {bwait = toWait} updDisplaceActor :: MonadStateWrite m => ActorId -> ActorId -> m () @@ -230,7 +230,7 @@ b <- getsState $ getActorBody aid bag <- getsState $ getBodyStoreBag b c1 case iid `EM.lookup` bag of - Nothing -> assert `failure` (iid, k, aid, c1, c2) + Nothing -> error $ "" `showFailure` (iid, k, aid, c1, c2) Just (_, it) -> do deleteItemActor iid (k, take k it) aid c1 insertItemActor iid (k, take k it) aid c2 @@ -276,7 +276,7 @@ body <- getsState $ getActorBody aid let !_A = assert (fromT == btrajectory body `blame` "unexpected actor trajectory" - `twith` (aid, fromT, toT, body)) () + `swith` (aid, fromT, toT, body)) () updateActor aid $ \b -> b {btrajectory = toT} updQuitFaction :: MonadStateWrite m @@ -286,7 +286,7 @@ fact <- getsState $ (EM.! fid) . sfactionD let !_A = assert (fromSt == gquit fact `blame` "unexpected actor quit status" - `twith` (fid, fromSt, toSt, fact)) () + `swith` (fid, fromSt, toSt, fact)) () let adj fa = fa {gquit = toSt} updateFaction fid adj @@ -305,7 +305,7 @@ `blame` (fid, source, target, mtb, fact)) () let !_A = assert (source == _gleader fact `blame` "unexpected actor leader" - `twith` (fid, source, target, mtb, fact)) () + `swith` (fid, source, target, mtb, fact)) () let adj fa = fa {_gleader = target} updateFaction fid adj @@ -318,7 +318,7 @@ let !_A = assert (fromDipl == EM.findWithDefault Unknown fid2 (gdipl fact1) && fromDipl == EM.findWithDefault Unknown fid1 (gdipl fact2) `blame` "unexpected actor diplomacy status" - `twith` (fid1, fid2, fromDipl, toDipl, fact1, fact2)) () + `swith` (fid1, fid2, fromDipl, toDipl, fact1, fact2)) () let adj fid fact = fact {gdipl = EM.insert fid toDipl (gdipl fact)} updateFaction fid1 (adj fid2) updateFaction fid2 (adj fid1) @@ -375,7 +375,7 @@ let adj ts = assert (ts PointArray.! p == fromTile || ts PointArray.! p == Tile.hideAs cotile fromTile `blame` "unexpected altered tile kind" - `twith` (lid, p, fromTile, toTile, ts PointArray.! p)) + `swith` (lid, p, fromTile, toTile, ts PointArray.! p)) $ ts PointArray.// [(p, toTile)] updateLevel lid $ updateTile adj case ( Tile.isExplorable coTileSpeedup fromTile @@ -431,25 +431,25 @@ let fromSm = if fromSm' == timeZero then Nothing else Just fromSm' toSm = if toSm' == timeZero then Nothing else Just toSm' alt sm = assert (sm == fromSm `blame` "unexpected tile smell" - `twith` (lid, p, fromSm, toSm, sm)) toSm + `swith` (lid, p, fromSm, toSm, sm)) toSm updateLevel lid $ updateSmell $ EM.alter alt p updSpotSmell :: MonadStateWrite m => LevelId -> [(Point, Time)] -> m () updSpotSmell lid sms = assert (not $ null sms) $ do let alt sm Nothing = Just sm - alt sm (Just oldSm) = assert `failure` "smell already added" - `twith` (lid, sms, sm, oldSm) + alt sm (Just oldSm) = error $ "smell already added" + `showFailure` (lid, sms, sm, oldSm) f (p, sm) = EM.alter (alt sm) p upd m = foldr f m sms updateLevel lid $ updateSmell upd updLoseSmell :: MonadStateWrite m => LevelId -> [(Point, Time)] -> m () updLoseSmell lid sms = assert (not $ null sms) $ do - let alt sm Nothing = assert `failure` "smell already removed" - `twith` (lid, sms, sm) + let alt sm Nothing = error $ "smell already removed" + `showFailure` (lid, sms, sm) alt sm (Just oldSm) = assert (sm == oldSm `blame` "unexpected lost smell" - `twith` (lid, sms, sm, oldSm)) Nothing + `swith` (lid, sms, sm, oldSm)) Nothing f (p, sm) = EM.alter (alt sm) p upd m = foldr f m sms updateLevel lid $ updateSmell upd @@ -464,7 +464,7 @@ let !_A = assert (fromIt == it `blame` (k, it, iid, c, fromIt, toIt)) () deleteItemContainer iid (k, fromIt) c insertItemContainer iid (k, toIt) c - Nothing -> assert `failure` (bag, iid, c, fromIt, toIt) + Nothing -> error $ "" `showFailure` (bag, iid, c, fromIt, toIt) -- | Age the game. updAgeGame :: MonadStateWrite m => [LevelId] -> m () diff --git a/Game/LambdaHack/Atomic/MonadStateWrite.hs b/Game/LambdaHack/Atomic/MonadStateWrite.hs --- a/Game/LambdaHack/Atomic/MonadStateWrite.hs +++ b/Game/LambdaHack/Atomic/MonadStateWrite.hs @@ -43,12 +43,12 @@ moveActorMap :: MonadStateWrite m => ActorId -> Actor -> Actor -> m () moveActorMap aid body newBody = do - let rmActor Nothing = assert `failure` "actor already removed" - `twith` (aid, body) + let rmActor Nothing = error $ "actor already removed" + `showFailure` (aid, body) rmActor (Just l) = #ifdef WITH_EXPENSIVE_ASSERTIONS assert (aid `elem` l `blame` "actor already removed" - `twith` (aid, body, l)) + `swith` (aid, body, l)) #endif (let l2 = delete aid l in if null l2 then Nothing else Just l2) @@ -56,7 +56,7 @@ addActor (Just l) = #ifdef WITH_EXPENSIVE_ASSERTIONS assert (aid `notElem` l `blame` "actor already added" - `twith` (aid, body, l)) + `swith` (aid, body, l)) #endif (Just $ aid : l) updActor = EM.alter addActor (bpos newBody) @@ -82,13 +82,13 @@ -- perhaps it's applied automatically due to INLINABLE. updateActor :: MonadStateWrite m => ActorId -> (Actor -> Actor) -> m () updateActor aid f = do - let alt Nothing = assert `failure` "no body to update" `twith` aid + let alt Nothing = error $ "no body to update" `showFailure` aid alt (Just b) = Just $ f b modifyState $ updateActorD $ EM.alter alt aid updateFaction :: MonadStateWrite m => FactionId -> (Faction -> Faction) -> m () updateFaction fid f = do - let alt Nothing = assert `failure` "no faction to update" `twith` fid + let alt Nothing = error $ "no faction to update" `showFailure` fid alt (Just fact) = Just $ f fact modifyState $ updateFactionD $ EM.alter alt fid @@ -168,7 +168,7 @@ CFloor lid pos -> deleteItemFloor iid kit lid pos CEmbed lid pos -> deleteItemEmbed iid kit lid pos CActor aid store -> deleteItemActor iid kit aid store - CTrunk{} -> assert `failure` c + CTrunk{} -> error $ "" `showFailure` c deleteItemFloor :: MonadStateWrite m => ItemId -> ItemQuant -> LevelId -> Point -> m () @@ -176,8 +176,8 @@ let rmFromFloor (Just bag) = let nbag = rmFromBag kit iid bag in if EM.null nbag then Nothing else Just nbag - rmFromFloor Nothing = assert `failure` "item already removed" - `twith` (iid, kit, lid, pos) + rmFromFloor Nothing = error $ "item already removed" + `showFailure` (iid, kit, lid, pos) in updateLevel lid $ updateFloor $ EM.alter rmFromFloor pos deleteItemEmbed :: MonadStateWrite m @@ -186,8 +186,8 @@ let rmFromFloor (Just bag) = let nbag = rmFromBag kit iid bag in if EM.null nbag then Nothing else Just nbag - rmFromFloor Nothing = assert `failure` "item already removed" - `twith` (iid, kit, lid, pos) + rmFromFloor Nothing = error $ "item already removed" + `showFailure` (iid, kit, lid, pos) in updateLevel lid $ updateEmbed $ EM.alter rmFromFloor pos deleteItemActor :: MonadStateWrite m @@ -229,11 +229,11 @@ -- so that @DestroyItem kit (CreateItem kit x) == x@. rmFromBag :: ItemQuant -> ItemId -> ItemBag -> ItemBag rmFromBag kit@(k, rmIt) iid bag = - let rfb Nothing = assert `failure` "rm from empty slot" `twith` (k, iid, bag) + let rfb Nothing = error $ "rm from empty slot" `showFailure` (k, iid, bag) rfb (Just (n, it)) = case compare n k of - LT -> assert `failure` "rm more than there is" - `twith` (n, kit, iid, bag) + LT -> error $ "rm more than there is" + `showFailure` (n, kit, iid, bag) EQ -> assert (rmIt == it `blame` (rmIt, it, n, kit, iid, bag)) Nothing GT -> assert (rmIt == take k it `blame` (rmIt, take k it, n, kit, iid, bag)) 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 @@ -31,12 +31,12 @@ -- based on the position of the command, etc. Note that the server -- sees and smells all positions. data PosAtomic = - PosSight !LevelId ![Point] -- ^ whomever sees all the positions, notices - | PosFidAndSight ![FactionId] !LevelId ![Point] + PosSight LevelId [Point] -- ^ whomever sees all the positions, notices + | PosFidAndSight [FactionId] LevelId [Point] -- ^ observers and the faction notice - | PosSmell !LevelId ![Point] -- ^ whomever smells all the positions, notices - | PosFid !FactionId -- ^ only the faction notices - | PosFidAndSer !(Maybe LevelId) !FactionId -- ^ faction and server notices + | PosSmell LevelId [Point] -- ^ whomever smells all the positions, notices + | PosFid FactionId -- ^ only the faction notices + | PosFidAndSer (Maybe LevelId) FactionId -- ^ faction and server notices | PosSer -- ^ only the server notices | PosAll -- ^ everybody notices | PosNone -- ^ never broadcasted, but sent manually @@ -80,8 +80,9 @@ else PosFidAndSight [bfid b] (blid b) [fromP, toP] UpdWaitActor aid _ -> singleAid aid UpdDisplaceActor source target -> doubleAid source target - UpdMoveItem _ _ _ _ CSha -> assert `failure` cmd -- shared stash is private - UpdMoveItem _ _ _ CSha _ -> assert `failure` cmd + UpdMoveItem _ _ _ _ CSha -> + error $ "" `showFailure` cmd -- shared stash is private + UpdMoveItem _ _ _ CSha _ -> error $ "" `showFailure` cmd UpdMoveItem _ _ aid _ _ -> singleAid aid UpdRefillHP aid _ -> singleAid aid UpdRefillCalm aid _ -> singleAid aid @@ -234,14 +235,14 @@ PosFidAndSer _ fid2 -> fid == fid2 PosSer -> False PosAll -> True - PosNone -> assert `failure` "no position possible" `twith` fid + PosNone -> error $ "no position possible" `showFailure` fid -- Not needed ATM, but may be a coincidence. seenAtomicSer :: PosAtomic -> Bool seenAtomicSer posAtomic = case posAtomic of PosFid _ -> False - PosNone -> assert `failure` "no position possible" `twith` posAtomic + PosNone -> error $ "no position possible" `showFailure` posAtomic _ -> True -- | Generate the atomic updates that jointly perform a given item move. @@ -262,7 +263,7 @@ containerMoveItem verbose iid k c1 c2 = do bag <- getsState $ getContainerBag c1 case iid `EM.lookup` bag of - Nothing -> assert `failure` (iid, k, c1, c2) + Nothing -> error $ "" `showFailure` (iid, k, c1, c2) Just (_, it) -> do item <- getsState $ getItemBody iid return [ UpdLoseItem verbose iid item (k, take k it) c1 diff --git a/Game/LambdaHack/Client.hs b/Game/LambdaHack/Client.hs --- a/Game/LambdaHack/Client.hs +++ b/Game/LambdaHack/Client.hs @@ -3,10 +3,14 @@ -- See -- . module Game.LambdaHack.Client - ( -- * Re-exported from "Game.LambdaHack.Client.LoopClient" + ( -- * Re-exported from "Game.LambdaHack.Client.LoopM" loopCli + -- * Re-exported from "Game.LambdaHack.Client.UI" + , KeyKind, SessionUI, emptySessionUI + , Config, applyConfigToDebug, configCmdline, mkConfig ) where import Prelude () import Game.LambdaHack.Client.LoopM +import Game.LambdaHack.Client.UI 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 @@ -83,15 +83,15 @@ body <- getsState $ getActorBody aid let !_A = assert (bfid body == side `blame` "AI tries to move enemy actor" - `twith` (aid, bfid body, side)) () + `swith` (aid, bfid body, side)) () let !_A = assert (isNothing (btrajectory body) `blame` "AI gets to manually move its projectiles" - `twith` (aid, bfid body, side)) () + `swith` (aid, bfid body, side)) () stratAction <- actionStrategy aid retry let bestAction = bestVariant stratAction !_A = assert (not (nullFreq bestAction) -- equiv to nullStrategy `blame` "no AI action for actor" - `twith` (stratAction, aid, body)) () + `swith` (stratAction, aid, body)) () -- Run the AI: chose an action from those given by the AI strategy. rndToAction $ frequency bestAction diff --git a/Game/LambdaHack/Client/AI/ConditionM.hs b/Game/LambdaHack/Client/AI/ConditionM.hs --- a/Game/LambdaHack/Client/AI/ConditionM.hs +++ b/Game/LambdaHack/Client/AI/ConditionM.hs @@ -160,7 +160,7 @@ condShineWouldBetray <- condShineWouldBetrayM aid condAimEnemyPresent <- condAimEnemyPresentM aid actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect) + let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) calmE = calmEnough b ar condNotCalmEnough = not calmE heavilyDistressed = -- Actor hit by a projectile or similarly distressed. 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 @@ -65,7 +65,7 @@ actionStrategy aid retry = do body <- getsState $ getActorBody aid scondInMelee <- getsClient scondInMelee - let condInMelee = fromMaybe (assert `failure` condInMelee) + let condInMelee = fromMaybe (error $ "" `showFailure` condInMelee) (scondInMelee EM.! blid body) condAimEnemyPresent <- condAimEnemyPresentM aid condAimEnemyRemembered <- condAimEnemyRememberedM aid @@ -87,7 +87,7 @@ condTgtNonmoving <- condTgtNonmovingM aid explored <- getsClient sexplored actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect) + let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) lidExplored = ES.member (blid body) explored panicFleeL = fleeL ++ badVic condHpTooLow = hpTooLow body ar @@ -307,7 +307,7 @@ -- and the server will ignore and warn (and content may avoid that, -- e.g., making all rings identified) actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect) + let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) calmE = calmEnough b ar isWeapon (_, _, _, itemFull) = isMelee $ itemBase itemFull filterWeapon | onlyWeapon = filter isWeapon @@ -339,7 +339,7 @@ equipItems aid = do body <- getsState $ getActorBody aid actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect) + let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) calmE = calmEnough body ar eqpAssocs <- fullAssocsClient aid [CEqp] invAssocs <- fullAssocsClient aid [CInv] @@ -402,7 +402,7 @@ yieldUnneeded aid = do body <- getsState $ getActorBody aid actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect) + let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) calmE = calmEnough body ar eqpAssocs <- fullAssocsClient aid [CEqp] condShineWouldBetray <- condShineWouldBetrayM aid @@ -440,7 +440,7 @@ unEquipItems aid = do body <- getsState $ getActorBody aid actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect) + let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) calmE = calmEnough body ar eqpAssocs <- fullAssocsClient aid [CEqp] invAssocs <- fullAssocsClient aid [CInv] @@ -534,7 +534,7 @@ meleeBlocker aid = do b <- getsState $ getActorBody aid actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect) + let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) fact <- getsState $ (EM.! bfid b) . sfactionD actorSk <- currentSkillsClient aid mtgtMPath <- getsClient $ EM.lookup aid . stargetD @@ -553,7 +553,7 @@ Just aim -> getsState $ posToAssocs aim (blid b) case lBlocker of (aid2, body2) : _ -> do - let ar2 = fromMaybe (assert `failure` aid2) + let ar2 = fromMaybe (error $ "" `showFailure` aid2) (EM.lookup aid2 actorAspect) -- No problem if there are many projectiles at the spot. We just -- attack the first one. @@ -638,7 +638,7 @@ benList <- condProjectListM skill aid localTime <- getsState $ getLocalTime (blid b) let coeff CGround = 2 -- pickup turn saved - coeff COrgan = assert `failure` benList + coeff COrgan = error $ "" `showFailure` benList coeff CEqp = 100000 -- must hinder currently coeff CInv = 1 coeff CSha = 1 @@ -678,7 +678,7 @@ condAimEnemyPresent <- condAimEnemyPresentM aid localTime <- getsState $ getLocalTime (blid b) actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect) + let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) calmE = calmEnough b ar condNotCalmEnough = not calmE heavilyDistressed = -- Actor hit by a projectile or similarly distressed. @@ -725,7 +725,7 @@ then firstAidItem else not $ hpEnough b ar && firstAidItem coeff CGround = 2 -- pickup turn saved - coeff COrgan = assert `failure` benList + coeff COrgan = error $ "" `showFailure` benList coeff CEqp = 1 coeff CInv = 1 coeff CSha = 1 @@ -972,10 +972,10 @@ return $ Just $ RequestAnyAbility $ ReqMove dir -- The potential invisible actor is hit. | alterSkill < Tile.alterMinWalk coTileSpeedup t -> - assert `failure` "AI causes AlterUnwalked" `twith` (source, dir) + error $ "AI causes AlterUnwalked" `showFailure` (source, dir) | EM.member tpos $ lfloor lvl -> -- Only possible if items allowed inside unwalkable tiles. - assert `failure` "AI causes AlterBlockItem" `twith` (source, dir) + 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 diff --git a/Game/LambdaHack/Client/AI/PickActorM.hs b/Game/LambdaHack/Client/AI/PickActorM.hs --- a/Game/LambdaHack/Client/AI/PickActorM.hs +++ b/Game/LambdaHack/Client/AI/PickActorM.hs @@ -36,7 +36,7 @@ pickActorToMove maidToAvoid = do actorAspect <- getsClient sactorAspect mleader <- getsClient _sleader - let oldAid = fromMaybe (assert `failure` maidToAvoid) mleader + let oldAid = fromMaybe (error $ "" `showFailure` maidToAvoid) mleader oldBody <- getsState $ getActorBody oldAid let side = bfid oldBody arena = blid oldBody @@ -59,7 +59,7 @@ -- melee-less trying to flee, first aid, etc.). snd (autoDungeonLevel fact) && isNothing maidToAvoid -> pickOld - [] -> assert `failure` (oldAid, oldBody) + [] -> error $ "" `showFailure` (oldAid, oldBody) [_] -> pickOld -- Keep the leader: he is alone on the level. _ -> do -- At this point we almost forget who the old leader was @@ -93,9 +93,9 @@ -- This should be kept in sync with @actionStrategy@. actorVulnerable ((aid, body), _) = do scondInMelee <- getsClient scondInMelee - let condInMelee = fromMaybe (assert `failure` condInMelee) + let condInMelee = fromMaybe (error $ "" `showFailure` condInMelee) (scondInMelee EM.! blid body) - ar = fromMaybe (assert `failure` aid) + ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) threatDistL <- meleeThreatDistList aid (fleeL, _) <- fleeList aid @@ -270,7 +270,7 @@ useTactics oldAid = do oldBody <- getsState $ getActorBody oldAid scondInMelee <- getsClient scondInMelee - let condInMelee = fromMaybe (assert `failure` condInMelee) + let condInMelee = fromMaybe (error $ "" `showFailure` condInMelee) (scondInMelee EM.! blid oldBody) mleader <- getsClient _sleader let !_A = assert (mleader /= Just oldAid) () diff --git a/Game/LambdaHack/Client/AI/PickTargetM.hs b/Game/LambdaHack/Client/AI/PickTargetM.hs --- a/Game/LambdaHack/Client/AI/PickTargetM.hs +++ b/Game/LambdaHack/Client/AI/PickTargetM.hs @@ -54,10 +54,10 @@ side <- getsClient sside let !_A = assert (bfid body == side `blame` "AI tries to move an enemy actor" - `twith` (aid, body, side)) () + `swith` (aid, body, side)) () let !_A = assert (isNothing (btrajectory body) && not (bproj body) `blame` "AI gets to manually move its projectiles" - `twith` (aid, body, side)) () + `swith` (aid, body, side)) () stratTarget <- targetStrategy aid if nullStrategy stratTarget then do -- Melee in progress and the actor can't contribute @@ -94,11 +94,11 @@ -- set of abilities as the leader, anyway) and set his target accordingly. actorAspect <- getsClient sactorAspect let lalter = salter EM.! blid b - condInMelee = fromMaybe (assert `failure` condInMelee) + condInMelee = fromMaybe (error $ "" `showFailure` condInMelee) (scondInMelee EM.! blid b) stdRuleset = Kind.stdRuleset corule nearby = rnearby stdRuleset - ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect) + ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) actorMaxSk = aSkills ar alterSkill = EM.findWithDefault 0 AbAlter actorMaxSk lvl@Level{lxsize, lysize} <- getLevel $ blid b @@ -135,7 +135,7 @@ _ -> Nothing -- veered off the path AndPath{pathList=[],..}-> Nothing -- path to the goal was partial; let's target again - NoPath -> assert `failure` () + NoPath -> error $ "" `showFailure` tap Nothing -> return Nothing -- no target assigned yet fact <- getsState $ (EM.! bfid b) . sfactionD allFoes <- getsState $ actorRegularAssocs (isAtWar fact) (blid b) @@ -169,7 +169,8 @@ -- + 2 from foe being 2 away from friend before he closed in -- + 1 for as a margin for ambush, given than actors exploring -- can't physically keep adjacent all the time - n | condInMelee = if attacksFriends then 4 else 0 + n | aAggression ar >= 2 = rangedNearby -- boss never waits + | condInMelee = if attacksFriends then 4 else 0 | otherwise = meleeNearby nonmoving = EM.findWithDefault 0 AbMove actorMaxSkE <= 0 return {-keep lazy-} $ @@ -180,7 +181,7 @@ -- targeted, which is fine, since he is weakened by ranged, so should be -- meleed ASAP, even if without friends. targetableRanged body = - not condInMelee + (not condInMelee || aAggression ar >= 2) -- boss fires at will && chessDist (bpos body) (bpos b) < rangedNearby && condCanProject targetableEnemy (aidE, body) = do @@ -320,7 +321,8 @@ updateTgt tap@TgtAndPath{tapPath=AndPath{..},tapTgt} = case tapTgt of TEnemy a permit -> do body <- getsState $ getActorBody a - if | (condInMelee || not focused) -- prefers closer foes + if | (condInMelee -- fight close foes or nobody at all + || not focused && not (null nearbyFoes)) -- prefers closer foes && a `notElem` map fst nearbyFoes -- old one not close enough || blid body /= blid b -- wrong level || actorDying body -- foe already dying diff --git a/Game/LambdaHack/Client/Bfs.hs b/Game/LambdaHack/Client/Bfs.hs --- a/Game/LambdaHack/Client/Bfs.hs +++ b/Game/LambdaHack/Client/Bfs.hs @@ -129,9 +129,9 @@ in bfs (succ minKnownBfs) [PointArray.pindex axsize source] data AndPath = - AndPath { pathList :: ![Point] - , pathGoal :: !Point -- needn't be @last pathList@ - , pathLen :: !Int -- needn't be @length pathList@ + AndPath { pathList :: [Point] + , pathGoal :: Point -- needn't be @last pathList@ + , pathLen :: Int -- needn't be @length pathList@ } | NoPath deriving (Show, Generic) diff --git a/Game/LambdaHack/Client/BfsM.hs b/Game/LambdaHack/Client/BfsM.hs --- a/Game/LambdaHack/Client/BfsM.hs +++ b/Game/LambdaHack/Client/BfsM.hs @@ -85,7 +85,7 @@ Kind.COps{coTileSpeedup} <- getsState scops let (oldBfsArr, oldBfsPath) = case bfsAndPathOld of BfsAndPath{bfsArr, bfsPath} -> (bfsArr, bfsPath) - BfsInvalid -> assert `failure` (bfsAndPathOld, aid, target) + BfsInvalid -> error $ "" `showFailure` (bfsAndPathOld, aid, target) let bfsArr = oldBfsArr if not canMove then return (bfsArr, NoPath) 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 @@ -38,8 +38,8 @@ getPerFid :: MonadClient m => LevelId -> m Perception getPerFid lid = do fper <- getsClient sfper - let assFail = assert `failure` "no perception at given level" - `twith` (lid, fper) + let assFail = error $ "no perception at given level" + `showFailure` (lid, fper) return $! EM.findWithDefault assFail lid fper -- | Calculate the position of an actor's target. @@ -88,7 +88,7 @@ in if | accessU -> - nUnknown | accessFirst -> -10000 | otherwise -> minBound - Nothing -> assert `failure` (body, fpos, epsOld) + Nothing -> error $ "" `showFailure` (body, fpos, epsOld) tryLines curEps (acc, _) | curEps == epsOld + dist = acc tryLines curEps (acc, bestScore) = let curScore = calcScore curEps @@ -106,12 +106,12 @@ actorAspect <- getsClient sactorAspect case EM.lookup aid actorAspect of Just aspectRecord -> return $ aSkills aspectRecord -- keep it lazy - Nothing -> assert `failure` aid + Nothing -> error $ "" `showFailure` aid currentSkillsClient :: MonadClient m => ActorId -> m Ability.Skills currentSkillsClient aid = do actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect) + let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) body <- getsState $ getActorBody aid side <- getsClient sside -- Newest Leader in _sleader, not yet in sfactionD. 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 @@ -86,7 +86,7 @@ , UpdAlterTile (blid b) p fromTile toTile -- reveal tile ] else assert (t == toTile `blame` "LoseTile fails to reset memory" - `twith` (aid, p, fromTile, toTile, b, t, cmd)) + `swith` (aid, p, fromTile, toTile, b, t, cmd)) [cmd] -- Already knows the tile fully, only confirm. UpdHideTile{} -> return [] -- will be fleshed out when Undo completed UpdSpotTile lid ts -> do @@ -275,7 +275,7 @@ || mleader == target -- we changed the leader ourselves `blame` "unexpected leader" - `twith` (cmd, mleader)) () + `swith` (cmd, mleader)) () modifyClient $ \cli -> cli {_sleader = target} UpdAutoFaction{} -> -- @condBFS@ depends on the setting we change here (e.g., smarkSuspect). @@ -379,9 +379,11 @@ createActor :: MonadClient m => ActorId -> Actor -> [(ItemId, Item)] -> m () createActor aid b ais = do - let affect3 tap@TgtAndPath{..} = case tapTgt of - TPoint (TEnemyPos a permit) _ _ | a == aid -> - TgtAndPath (TEnemy a permit) NoPath + side <- getsClient sside + let newPermit = bfid b == side + affect3 tap@TgtAndPath{..} = case tapTgt of + TPoint (TEnemyPos a _) _ _ | a == aid -> + TgtAndPath (TEnemy a newPermit) NoPath _ -> tap modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)} aspectRecord <- aspectRecordFromActorClient b ais @@ -457,7 +459,7 @@ || maybe False (not . ES.null) (interAlready outPer) when unset $ do -} - let adj Nothing = assert `failure` "no perception to alter" `twith` lid + let adj Nothing = error $ "no perception to alter" `showFailure` lid adj (Just per) = Just $ addPer (diffPer per outPer) inPer f = EM.alter adj lid modifyClient $ \cli -> cli {sfper = f (sfper cli)} @@ -475,8 +477,11 @@ kmMean = meanAspect kind benefit = totalUsefulness cops fact (IK.ieffects kind) kmMean item f Nothing = Just KindMean{..} - f Just{} = assert `failure` "already discovered" - `twith` (c, iid, kmKind) + f Just{} = error $ "already discovered" + `showFailure` (c, iid, kmKind) + -- This adds to @sdiscoBenefit@ only @iid@ and not any other items + -- that share the same @jkindIx@, so this is broken if such items + -- are not fully IDed from the start. modifyClient $ \cli -> cli { sdiscoKind = EM.alter f (jkindIx item) (sdiscoKind cli) , sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli) } @@ -491,10 +496,10 @@ coverKind :: MonadClient m => Container -> ItemId -> Kind.Id ItemKind -> m () coverKind c iid ik = do item <- getsState $ getItemBody iid - let f Nothing = assert `failure` "already covered" `twith` (c, iid, ik) + let f Nothing = error $ "already covered" `showFailure` (c, iid, ik) f (Just KindMean{kmKind}) = assert (ik == kmKind `blame` "unexpected covered item kind" - `twith` (ik, kmKind)) Nothing + `swith` (ik, kmKind)) Nothing -- For now, undoing @sdiscoBenefit@ is too much work. modifyClient $ \cli -> cli {sdiscoKind = EM.alter f (jkindIx item) (sdiscoKind cli)} @@ -514,16 +519,19 @@ item <- getsState $ getItemBody iid totalDepth <- getsState stotalDepth case EM.lookup (jkindIx item) discoKind of - Nothing -> assert `failure` "kind not known" - `twith` (c, iid, seed) + Nothing -> error $ "kind not known" + `showFailure` (c, iid, seed) Just KindMean{kmKind} -> do Level{ldepth} <- getLevel $ jlid item let kind = okind kmKind aspects = seedToAspect seed kind ldepth totalDepth benefit = totalUsefulness cops fact (IK.ieffects kind) aspects item f Nothing = Just aspects - f Just{} = assert `failure` "already discovered" - `twith` (c, iid, seed) + f Just{} = error $ "already discovered" + `showFailure` (c, iid, seed) + -- This adds to @sdiscoBenefit@ only @iid@ and not any other items + -- that share the same @jkindIx@, so this is broken if such items + -- are not fully IDed from the start. modifyClient $ \cli -> cli { sdiscoAspect = EM.alter f iid (sdiscoAspect cli) , sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli) } @@ -533,7 +541,7 @@ coverSeed :: MonadClient m => Container -> ItemId -> ItemSeed -> m () coverSeed c iid seed = do - let f Nothing = assert `failure` "already covered" `twith` (c, iid, seed) + let f Nothing = error $ "already covered" `showFailure` (c, iid, seed) f Just{} = Nothing -- checking that old and new agree is too much work -- For now, undoing @sdiscoBenefit@ is too much work. modifyClient $ \cli -> cli {sdiscoAspect = EM.alter f iid (sdiscoAspect cli)} @@ -569,13 +577,12 @@ g bap1 bap2 = bfsArr bap1 == bfsArr bap2 subBfs = EM.isSubmapOfBy g let !_A1 = assert (salter == alter - `blame` ("wrong accumulated salter on" <+> tshow side) - `twith` (salter, alter)) () + `blame` "wrong accumulated salter on side" + `swith` (side, salter, alter)) () !_A2 = assert (sactorAspect == actorAspect - `blame` ("wrong accumulated sactorAspect on" - <+> tshow side) - `twith` (sactorAspect, actorAspect)) () + `blame` "wrong accumulated sactorAspect on side" + `swith` (side, sactorAspect, actorAspect)) () !_A3 = assert (sbfsD `subBfs` bfsD - `blame` ("wrong accumulated sbfsD on" <+> tshow side) - `twith` (sbfsD, bfsD)) () + `blame` "wrong accumulated sbfsD on side" + `swith` (side, sbfsD, bfsD)) () return () diff --git a/Game/LambdaHack/Client/LoopM.hs b/Game/LambdaHack/Client/LoopM.hs --- a/Game/LambdaHack/Client/LoopM.hs +++ b/Game/LambdaHack/Client/LoopM.hs @@ -9,8 +9,6 @@ import Game.LambdaHack.Common.Prelude -import qualified Data.Text as T - import Game.LambdaHack.Atomic import Game.LambdaHack.Client.HandleResponseM import Game.LambdaHack.Client.MonadClient @@ -81,10 +79,10 @@ (True, RespUpdAtomic UpdRestart{}) -> when hasUI $ msgAdd "Ignoring an old savefile and starting a new game." (False, RespUpdAtomic UpdResume{}) -> - assert `failure` - T.unpack ("Savefile of client" <+> tshow side <+> "not usable.") + error $ "Savefile of client " ++ show side ++ " not usable." + `showFailure` () (False, RespUpdAtomic UpdRestart{}) -> return () - _ -> assert `failure` "unexpected command" `twith` (side, restored, cmd1) + _ -> error $ "unexpected command" `showFailure` (side, restored, cmd1) handleResponse cmd1 -- State and client state now valid. debugPossiblyPrint $ "UI client" <+> tshow side <+> "started." diff --git a/Game/LambdaHack/Client/Preferences.hs b/Game/LambdaHack/Client/Preferences.hs --- a/Game/LambdaHack/Client/Preferences.hs +++ b/Game/LambdaHack/Client/Preferences.hs @@ -309,7 +309,8 @@ let scaleChargeBens bens | timeout <= 3 = bens | otherwise = map (\eff -> - min eff (eff * avgItemDelay `divUp` timeout)) bens + if avgItemDelay >= timeout then eff + else eff * avgItemDelay `divUp` timeout) bens (cself, cfoe) = unzip $ map (effectToBenefit cops fact) (stripRecharging effects) in (scaleChargeBens cself, scaleChargeBens cfoe) @@ -344,30 +345,34 @@ -- because they are applied to self. If they are periodic we can't -- effectively apply them, becasue they are never recharged, -- because they activate as soon as recharged. - benApply = (effSelf + effDice -- hits self with dice too, when applying - + if periodic then 0 else sum chargeSelf) - `divUp` if durable then 1 else durabilityMult + benApply = max 0 $ -- because optional; I don't need to apply + (effSelf + effDice -- hits self with dice too, when applying + + if periodic then 0 else sum chargeSelf) + `divUp` if durable then 1 else durabilityMult -- For melee, we add the foe part. - benMelee = (effFoe + effDice -- @AddHurtMelee@ already in @eqpSum@ - + if periodic then 0 else sum chargeFoe) - `divUp` if durable then 1 else durabilityMult + benMelee = min 0 $ + (effFoe + effDice -- @AddHurtMelee@ already in @eqpSum@ + + if periodic then 0 else sum chargeFoe) + `divUp` if durable then 1 else durabilityMult -- The periodic effects, if any, are activated when projectile flies, -- but not when it hits, so they are not added to @benFling@. -- However, if item is not periodic, the recharging effects -- are activated at projectile impact, hence their value is added. - benFling = effFoe + benFlingDice -- nothing in @eqpSum@; normally not worn - + if periodic then 0 else sum chargeFoe + benFling = min 0 $ + effFoe + benFlingDice -- nothing in @eqpSum@; normally not worn + + if periodic then 0 else sum chargeFoe benFlingDice | jdamage item <= 0 = 0 -- speedup - | otherwise = min 0 $ - let hurtMult = 100 + min 99 (max (-99) (aHurtMelee aspects)) - -- assumes no enemy armor and no block - dmg = Dice.meanDice (jdamage item) - rawDeltaHP = fromIntegral hurtMult * xM dmg `divUp` 100 - -- For simplicity, we ignore range bonus/malus and @Lobable@. - IK.ThrowMod{IK.throwVelocity} = strengthToThrow item - speed = speedFromWeight (jweight item) throwVelocity - in fromEnum $ - modifyDamageBySpeed rawDeltaHP speed * 10 `div` oneM - -- 1 damage valued at 10, just as in @damageUsefulness@ + | otherwise = assert (v <= 0) v + where + hurtMult = 100 + min 99 (max (-99) (aHurtMelee aspects)) + -- assumes no enemy armor and no block + dmg = Dice.meanDice (jdamage item) + rawDeltaHP = fromIntegral hurtMult * xM dmg `divUp` 100 + -- For simplicity, we ignore range bonus/malus and @Lobable@. + IK.ThrowMod{IK.throwVelocity} = strengthToThrow item + speed = speedFromWeight (jweight item) throwVelocity + v = fromEnum $ - modifyDamageBySpeed rawDeltaHP speed * 10 `div` oneM + -- 1 damage valued at 10, just as in @damageUsefulness@ -- For equipment benefit, we take into account only the self -- value of the recharging effects, because they applied to self. -- We don't add a bonus @averageTurnValue@ to the value of periodic @@ -393,14 +398,14 @@ ( True -- equip, melee crucial, and only weapons in eqp can be used , if durable then eqpSum - + max 0 (max benApply (- benMelee)) -- apply or melee or not - else max 0 (- benMelee)) -- melee is predominant + + max benApply (- benMelee) -- apply or melee or not + else - benMelee) -- melee is predominant | goesIntoEqp item && eqpSum > 0 = -- weapon or other equippable ( True -- equip; long time bonus usually outweighs fling or apply , eqpSum -- possibly spent turn equipping, so reap the benefits + if durable - then max 0 benApply -- apply or not but don't fling + then benApply -- apply or not but don't fling else 0) -- don't remove from equipment by using up | otherwise = - (False, max 0 (max benApply (- benFling))) -- apply or fling + (False, max benApply (- benFling)) -- apply or fling in Benefit{..} diff --git a/Game/LambdaHack/Client/State.hs b/Game/LambdaHack/Client/State.hs --- a/Game/LambdaHack/Client/State.hs +++ b/Game/LambdaHack/Client/State.hs @@ -44,47 +44,47 @@ -- -- Data invariant: if @_sleader@ is @Nothing@ then so is @srunning@. data StateClient = StateClient - { seps :: !Int -- ^ a parameter of the aiming digital line - , stargetD :: !(EM.EnumMap ActorId TgtAndPath) + { seps :: Int -- ^ a parameter of the aiming digital line + , stargetD :: EM.EnumMap ActorId TgtAndPath -- ^ targets of our actors in the dungeon - , sexplored :: !(ES.EnumSet LevelId) + , sexplored :: ES.EnumSet LevelId -- ^ the set of fully explored levels - , sbfsD :: !(EM.EnumMap ActorId BfsAndPath) + , sbfsD :: EM.EnumMap ActorId BfsAndPath -- ^ pathfinding distances for our actors -- and paths to their targets, if any - , sundo :: ![CmdAtomic] -- ^ atomic commands performed to date - , sdiscoKind :: !DiscoveryKind -- ^ remembered item discoveries - , sdiscoAspect :: !DiscoveryAspect -- ^ remembered aspects of items - , sdiscoBenefit :: !DiscoveryBenefit -- ^ remembered AI benefits of items - , sactorAspect :: !ActorAspect -- ^ best known actor aspect data - , sfper :: !PerLid -- ^ faction perception indexed by levels - , salter :: !AlterLid -- ^ cached alter ability data for positions - , srandom :: !R.StdGen -- ^ current random generator - , _sleader :: !(Maybe ActorId) + , sundo :: [CmdAtomic] -- ^ atomic commands performed to date + , sdiscoKind :: DiscoveryKind -- ^ remembered item discoveries + , sdiscoAspect :: DiscoveryAspect -- ^ remembered aspects of items + , sdiscoBenefit :: DiscoveryBenefit -- ^ remembered AI benefits of items + , sactorAspect :: ActorAspect -- ^ best known actor aspect data + , sfper :: PerLid -- ^ faction perception indexed by levels + , salter :: AlterLid -- ^ cached alter ability data for positions + , srandom :: R.StdGen -- ^ current random generator + , _sleader :: Maybe ActorId -- ^ candidate new leader of the faction; -- Faction._gleader is the old leader - , _sside :: !FactionId -- ^ faction controlled by the client - , squit :: !Bool -- ^ exit the game loop - , scurChal :: !Challenge -- ^ current game challenge setup - , snxtChal :: !Challenge -- ^ next game challenge setup - , snxtScenario :: !Int -- ^ next game scenario number - , smarkSuspect :: !Int -- ^ mark suspect features - , scondInMelee :: !(EM.EnumMap LevelId (Maybe Bool)) - -- ^ condInMelee value, unless invalidated - , svictories :: !(EM.EnumMap (Kind.Id ModeKind) (M.Map Challenge Int)) + , _sside :: FactionId -- ^ faction controlled by the client + , squit :: Bool -- ^ exit the game loop + , scurChal :: Challenge -- ^ current game challenge setup + , snxtChal :: Challenge -- ^ next game challenge setup + , snxtScenario :: Int -- ^ next game scenario number + , smarkSuspect :: Int -- ^ mark suspect features + , scondInMelee :: EM.EnumMap LevelId (Maybe Bool) + -- ^ condInMelee value, unless invalidated + , svictories :: EM.EnumMap (Kind.Id ModeKind) (M.Map Challenge Int) -- ^ won games at particular difficulty levels - , sdebugCli :: !DebugModeCli -- ^ client debugging mode + , sdebugCli :: DebugModeCli -- ^ client debugging mode } deriving Show data BfsAndPath = BfsInvalid - | BfsAndPath { bfsArr :: !(PointArray.Array BfsDistance) - , bfsPath :: !(EM.EnumMap Point AndPath) + | BfsAndPath { bfsArr :: PointArray.Array BfsDistance + , bfsPath :: EM.EnumMap Point AndPath } deriving Show -data TgtAndPath = TgtAndPath {tapTgt :: !Target, tapPath :: !AndPath} +data TgtAndPath = TgtAndPath {tapTgt :: Target, tapPath :: AndPath} deriving (Show, Generic) instance Binary TgtAndPath @@ -142,7 +142,7 @@ let side1 = bfid $ getActorBody leader s side2 = sside cli in assert (side1 == side2 `blame` "enemy actor becomes our leader" - `twith` (side1, side2, leader, s)) + `swith` (side1, side2, leader, s)) $ cli {_sleader = Just leader} sside :: StateClient -> FactionId diff --git a/Game/LambdaHack/Client/UI.hs b/Game/LambdaHack/Client/UI.hs --- a/Game/LambdaHack/Client/UI.hs +++ b/Game/LambdaHack/Client/UI.hs @@ -8,7 +8,8 @@ , putSession, queryUI , displayRespUpdAtomicUI, displayRespSfxAtomicUI -- * Startup - , KeyKind, SessionUI(..), emptySessionUI, Config + , KeyKind, SessionUI(..), emptySessionUI + , Config, applyConfigToDebug, configCmdline, mkConfig , ChanFrontend, chanFrontend, frontendShutdown -- * Operations exposed for LoopClient , ColorMode(..) diff --git a/Game/LambdaHack/Client/UI/ActorUI.hs b/Game/LambdaHack/Client/UI/ActorUI.hs --- a/Game/LambdaHack/Client/UI/ActorUI.hs +++ b/Game/LambdaHack/Client/UI/ActorUI.hs @@ -24,10 +24,10 @@ import Game.LambdaHack.Common.State data ActorUI = ActorUI - { bsymbol :: !Char -- ^ individual map symbol - , bname :: !Text -- ^ individual name - , bpronoun :: !Text -- ^ individual pronoun - , bcolor :: !Color.Color -- ^ individual map color + { bsymbol :: Char -- ^ individual map symbol + , bname :: Text -- ^ individual name + , bpronoun :: Text -- ^ individual pronoun + , bcolor :: Color.Color -- ^ individual map color } deriving (Show, Eq, Generic) @@ -52,7 +52,7 @@ ppContainer CFloor{} = "nearby" ppContainer CEmbed{} = "embedded nearby" ppContainer (CActor _ cstore) = ppCStoreIn cstore -ppContainer c@CTrunk{} = assert `failure` c +ppContainer c@CTrunk{} = error $ "" `showFailure` c ppCStore :: CStore -> (Text, Text) ppCStore CGround = ("on", "the ground") @@ -79,7 +79,7 @@ CEmbed{} -> ["embedded nearby"] CActor aid store -> let owner = ownerFun aid in ppCStoreWownW addPrepositions store owner - CTrunk{} -> assert `failure` c + CTrunk{} -> error $ "" `showFailure` c verbCStore :: CStore -> Text verbCStore CGround = "drop" diff --git a/Game/LambdaHack/Client/UI/Config.hs b/Game/LambdaHack/Client/UI/Config.hs --- a/Game/LambdaHack/Client/UI/Config.hs +++ b/Game/LambdaHack/Client/UI/Config.hs @@ -14,7 +14,6 @@ import qualified Data.Ini.Reader as Ini import qualified Data.Ini.Types as Ini import qualified Data.Map.Strict as M -import qualified Data.Text as T import Game.LambdaHack.Common.ClientOptions import GHC.Generics (Generic) import System.FilePath @@ -31,23 +30,23 @@ -- is a part of a game client. data Config = Config { -- commands - configCommands :: ![(K.KM, CmdTriple)] + configCommands :: [(K.KM, CmdTriple)] -- hero names - , configHeroNames :: ![(Int, (Text, Text))] + , configHeroNames :: [(Int, (Text, Text))] -- ui - , configVi :: !Bool -- ^ the option for Vi keys takes precendence - , configLaptop :: !Bool -- ^ because the laptop keys are the default - , configGtkFontFamily :: !Text - , configSdlFontFile :: !Text - , configSdlTtfSizeAdd :: !Int - , configSdlFonSizeAdd :: !Int - , configFontSize :: !Int - , configColorIsBold :: !Bool - , configHistoryMax :: !Int - , configMaxFps :: !Int - , configNoAnim :: !Bool - , configRunStopMsgs :: !Bool - , configCmdline :: ![String] + , configVi :: Bool -- ^ the option for Vi keys takes precendence + , configLaptop :: Bool -- ^ because the laptop keys are the default + , configGtkFontFamily :: Text + , configSdlFontFile :: Text + , configSdlTtfSizeAdd :: Int + , configSdlFonSizeAdd :: Int + , configFontSize :: Int + , configColorIsBold :: Bool + , configHistoryMax :: Int + , configMaxFps :: Int + , configNoAnim :: Bool + , configRunStopMsgs :: Bool + , configCmdline :: [String] } deriving (Show, Generic) @@ -63,22 +62,22 @@ Just _ -> let (key, def) = read keydef in (K.mkKM key, def :: CmdTriple) - Nothing -> assert `failure` "wrong macro id" `twith` ident + Nothing -> error $ "wrong macro id" `showFailure` ident section = Ini.allItems "extra_commands" cfg in map mkCommand section configHeroNames = let toNumber (ident, nameAndPronoun) = case stripPrefix "HeroName_" ident of Just n -> (read n, read nameAndPronoun) - Nothing -> assert `failure` "wrong hero name id" `twith` ident + Nothing -> error $ "wrong hero name id" `showFailure` ident section = Ini.allItems "hero_names" cfg in map toNumber section getOption :: forall a. Read a => String -> a getOption optionName = let lookupFail :: forall b. String -> b lookupFail err = - assert `failure` ("config file access failed:" <+> T.pack err) - `twith` (optionName, cfg) + error $ "config file access failed" + `showFailure` (err, optionName, cfg) s = fromMaybe (lookupFail "") $ Ini.getOption "ui" optionName cfg in either lookupFail id $ readEither s configVi = getOption "movementViKeys_hjklyubn" @@ -104,7 +103,8 @@ let stdRuleset = Kind.stdRuleset corule cfgUIName = rcfgUIName stdRuleset sUIDefault = rcfgUIDefault stdRuleset - cfgUIDefault = either (assert `failure`) id $ Ini.parse sUIDefault + cfgUIDefault = either (error . ("" `showFailure`)) id + $ Ini.parse sUIDefault dataDir <- appDataDir let userPath = dataDir cfgUIName cfgUser <- if benchmark then return Ini.emptyConfig else do @@ -113,7 +113,7 @@ then return Ini.emptyConfig else do sUser <- readFile userPath - return $! either (assert `failure`) id $ Ini.parse sUser + return $! either (error . ("" `showFailure`)) id $ Ini.parse sUser let cfgUI = M.unionWith M.union cfgUser cfgUIDefault -- user cfg preferred conf = parseConfig cfgUI -- Catch syntax errors in complex expressions ASAP, 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 @@ -98,7 +98,7 @@ void $ updateItemSlot CGround Nothing iid itemVerbMU iid kit (MU.Text $ "appear" <+> ppContainer c) c markDisplayNeeded lid - CTrunk{} -> assert `failure` c + CTrunk{} -> error $ "" `showFailure` c stopPlayBack UpdDestroyItem iid _ kit c -> do itemVerbMU iid kit "disappear" c @@ -199,8 +199,11 @@ mleader <- getsClient _sleader when (Just aid == mleader) $ do actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect) - when (bhp b >= xM (aMaxHP ar) && aMaxHP ar > 0 && n > 0) $ do + let ar = fromMaybe (error $ "" `showFailure` aid) + (EM.lookup aid actorAspect) + -- Regenerating actors never stop gaining HP, so we need to stop + -- reporting it after they reach full HP for the first time. + when (bhp b >= xM (aMaxHP ar) && bhp b - n < xM (aMaxHP ar)) $ do actorVerbMU aid bUI "recover your health fully" stopPlayBack UpdRefillCalm aid calmDelta -> @@ -459,7 +462,7 @@ factionD <- getsState sfactionD -- The item may no longer be in @c@, but it was case iid `EM.lookup` bag of - Nothing -> assert `failure` (aid, verb, iid, cstore) + Nothing -> error $ "" `showFailure` (aid, verb, iid, cstore) Just kit@(k, _) -> do itemToF <- itemToFullClient let lid = blid body @@ -476,14 +479,10 @@ in MU.Phrase [name, stats] Right n -> assert (n <= k `blame` (aid, verb, iid, cstore)) - $ let itemSecret = itemNoDisco (itemBase itemFull, n) - (_, _, secretName, secretAE) = - partItem side factionD cstore localTime itemSecret - name = MU.Phrase [secretName, secretAE] - nameList = if n == 1 - then ["the", name] - else ["the", MU.Text $ tshow n, MU.Ws name] - in MU.Phrase nameList + $ let (_, _, name1, stats) = + partItemShort side factionD cstore localTime itemFull + name = if n == 1 then name1 else MU.CarWs n name1 + in MU.Phrase ["the", name, stats] msg = makeSentence [MU.SubjectVerbSg subject verb, object] msgAdd msg @@ -671,7 +670,8 @@ itemAidVerbMU aid (MU.Text verb) iid (Right k) cstore2 else when (not (bproj b) && bhp b > 0) $ -- don't announce death drops itemAidVerbMU aid (MU.Text verb) iid (Left $ Just k) cstore2 - Nothing -> assert `failure` (iid, k, aid, cstore1, cstore2, itemSlots) + Nothing -> error $ + "" `showFailure` (iid, k, aid, cstore1, cstore2, itemSlots) quitFactionUI :: MonadClientUI m => FactionId -> Maybe Status -> m () quitFactionUI fid toSt = do @@ -724,7 +724,7 @@ then "This time for real." else "Somebody couldn't stand the heat." ) Just Status{stOutcome=Restart, stNewGame=Nothing} -> - assert `failure` (fid, toSt) + error $ "" `showFailure` (fid, toSt) Nothing -> (Nothing, Nothing) -- server wipes out Camping for savefile case startingPart of Nothing -> return () @@ -760,9 +760,9 @@ keys = [K.spaceKM, K.escKM] ++ concatMap (keyOfEKM . fst) allOKX examItem slot = case EM.lookup slot lSlots of - Nothing -> assert `failure` slot + Nothing -> error $ "" `showFailure` slot Just iid -> case EM.lookup iid bag of - Nothing -> assert `failure` iid + Nothing -> error $ "" `showFailure` iid Just kit@(k, _) -> do factionD <- getsState sfactionD let itemFull = itemToF iid kit @@ -788,7 +788,7 @@ case ekm of Left km | km == K.spaceKM -> return True Left km | km == K.escKM -> return False - Left _ -> assert `failure` ekm + Left _ -> error $ "" `showFailure` ekm Right slot -> do go2 <- examItem slot if go2 then viewItems pointer2 else return True @@ -949,10 +949,7 @@ msgAdd $ makeSentence [MU.SubjectVerbSg subject verb, MU.Text fidSourceName, "control"] stopPlayBack - IK.Impress -> actorVerbMU aid bUI $ - if fidSource == bfid b - then "remember forgone allegiance suddenly" - else "be awestruck" + IK.Impress -> actorVerbMU aid bUI $ "be awestruck" IK.Summon grp p -> do let verb = if bproj b then "lure" else "summon" object = if p == 1 @@ -1024,11 +1021,11 @@ IK.ApplyPerfume -> msgAdd "The fragrance quells all scents in the vicinity." IK.OneOf{} -> return () - IK.OnSmash{} -> assert `failure` sfx - IK.Recharging{} -> assert `failure` sfx + IK.OnSmash{} -> error $ "" `showFailure` sfx + IK.Recharging{} -> error $ "" `showFailure` sfx IK.Temporary t -> actorVerbMU aid bUI $ MU.Text t - IK.Unique -> assert `failure` sfx - IK.Periodic -> assert `failure` sfx + IK.Unique -> error $ "" `showFailure` sfx + IK.Periodic -> error $ "" `showFailure` sfx SfxMsgFid _ sfxMsg -> do mleader <- getsClient _sleader case mleader of @@ -1058,7 +1055,7 @@ else "rumble" UpdAlterExplorable _ k -> if k > 0 then "grinding noise" else "fizzing noise" - _ -> assert `failure` cmd + _ -> error $ "" `showFailure` cmd distant = if local then [] else ["distant"] msg = makeSentence [ "you hear" , MU.AW $ MU.Phrase $ distant ++ [sound] ] @@ -1082,6 +1079,7 @@ else MU.Ws $ MU.Text $ tshow grp return $! makeSentence ["you hear", verb, object] SfxFizzles -> return "It flashes and fizzles." + SfxNothingHappens -> return "Nothing happens." SfxVoidDetection -> return "Nothing new detected." SfxSummonLackCalm aid -> do msbUI <- getsSession $ EM.lookup aid . sactorUI @@ -1124,8 +1122,9 @@ (_, _, name, stats) = partItem (bfid b) factionD cstore localTime itemFull storeOwn = ppCStoreWownW True cstore aidPhrase + cond = if jsymbol (itemBase itemFull) == '+' then ["condition"] else [] return $! makeSentence $ - ["the", name, stats] ++ storeOwn ++ ["will now last longer"] + ["the", name, stats] ++ cond ++ storeOwn ++ ["will now last longer"] setLastSlot :: MonadClientUI m => ActorId -> ItemId -> CStore -> m () setLastSlot aid iid cstore = do @@ -1134,7 +1133,7 @@ ItemSlots itemSlots _ <- getsSession sslots case lookup iid $ map swap $ EM.assocs itemSlots of Just slastSlot -> modifySession $ \sess -> sess {slastSlot} - Nothing -> assert `failure` (iid, cstore, aid) + Nothing -> error $ "" `showFailure` (iid, cstore, aid) strike :: MonadClientUI m => Bool -> ActorId -> ActorId -> ItemId -> CStore -> m () @@ -1167,7 +1166,9 @@ if isOrgan then partItemShortWownW side factionD spronoun COrgan localTime else partItemShortAW side factionD cstore localTime - msg | bhp tb <= 0 || hurtMult > 90 = makeSentence $ -- minor armor + msg | bhp tb <= 0 -- incapacitated, so doesn't actively block + || hurtMult > 90 -- at most minor armor + || jdamage (itemBase itemFull) <= 0 = makeSentence $ [MU.SubjectVerbSg spart verb, tpart] ++ if bproj sb then [] 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 @@ -71,7 +71,8 @@ b <- getsState $ getActorBody aid bUI <- getsSession $ getActorUI aid actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect) + let ar = fromMaybe (error $ "" `showFailure` aid) + (EM.lookup aid actorAspect) percentage = 100 * bhp b `div` xM (max 5 $ aMaxHP ar) chs n = "[" <> T.replicate n "*" <> T.replicate (4 - n) "_" <> "]" @@ -172,7 +173,7 @@ let {-# INLINE viewItemBag #-} viewItemBag _ floorBag = case EM.toDescList floorBag of (iid, _) : _ -> viewItem $ getItemBody iid s - [] -> assert `failure` "lfloor not sparse" `twith` () + [] -> error $ "lfloor not sparse" `showFailure` () viewSmell :: Point -> Time -> Color.AttrCharW32 {-# INLINE viewSmell #-} viewSmell p0 sml = @@ -269,24 +270,29 @@ drawFrameActor drawnLevelId = do SessionUI{sselected} <- 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 : _ -> - let Actor{bhp, bproj} = getActorBody aid s + let Actor{bhp, bproj, bfid, btrunk} = getActorBody aid s ActorUI{bsymbol, bcolor} = sactorUI EM.! aid + Item{jfid} = getItemBody btrunk s symbol | bhp > 0 || bproj = bsymbol | otherwise = '%' - bg = case mleader of + dominated = maybe False (/= bfid) jfid + bg = if bproj then Color.HighlightNone else case mleader of Just leader | aid == leader -> Color.HighlightRed - _ -> if aid `ES.notMember` sselected - then Color.HighlightNone - else Color.HighlightBlue + _ -> if | aid `ES.member` sselected -> Color.HighlightBlue + | dominated -> if bfid == side -- dominated by us + then Color.HighlightWhite + else Color.HighlightMagenta + | otherwise -> Color.HighlightNone in Color.attrCharToW32 $ Color.AttrChar Color.Attr{fg=bcolor, bg} symbol - [] -> assert `failure` "lactor not sparse" `twith` () + [] -> error $ "lactor not sparse" `showFailure` () mapVAL :: forall a s. (Point -> a -> Color.AttrCharW32) -> [(Point, a)] -> FrameST s {-# INLINE mapVAL #-} @@ -505,7 +511,7 @@ Just leader -> do actorAspect <- getsClient sactorAspect s <- getState - let ar = fromMaybe (assert `failure` leader) + let ar = fromMaybe (error $ "" `showFailure` leader) (EM.lookup leader actorAspect) showTrunc :: Show a => a -> String showTrunc = (\t -> if length t > 3 then "***" else t) . show diff --git a/Game/LambdaHack/Client/UI/EffectDescription.hs b/Game/LambdaHack/Client/UI/EffectDescription.hs --- a/Game/LambdaHack/Client/UI/EffectDescription.hs +++ b/Game/LambdaHack/Client/UI/EffectDescription.hs @@ -39,10 +39,10 @@ <+> if d > 1 then "burns" else "burn") Explode t -> "of" <+> tshow t <+> "explosion" RefillHP p | p > 0 -> "of healing" <+> wrapInParens (affixBonus p) - RefillHP 0 -> assert `failure` effect + RefillHP 0 -> error $ "" `showFailure` effect RefillHP p -> "of wounding" <+> wrapInParens (affixBonus p) RefillCalm p | p > 0 -> "of soothing" <+> wrapInParens (affixBonus p) - RefillCalm 0 -> assert `failure` effect + RefillCalm 0 -> error $ "" `showFailure` effect RefillCalm p -> "of dismaying" <+> wrapInParens (affixBonus p) Dominate -> "of domination" Impress -> "of impression" @@ -69,7 +69,7 @@ Just p -> makePhrase [MU.CarWs p "move"] in "of speed surge for" <+> moves Teleport dice | dice <= 0 -> - assert `failure` effect + error $ "" `showFailure` effect Teleport dice | dice <= 9 -> "of blinking" <+> wrapInParens (tshow dice) Teleport dice -> "of teleport" <+> wrapInParens (tshow dice) CreateItem COrgan grp tim -> @@ -126,7 +126,7 @@ EqpSlotAbAlter -> "Those unskilled in alteration equip it." EqpSlotAbProject -> "Those unskilled in flinging equip it." EqpSlotAbApply -> "Those unskilled in applying items equip it." - _ -> assert `failure` "should not be used in content" `twith` es + _ -> error $ "should not be used in content" `showFailure` es slotToName :: EqpSlot -> Text slotToName eqpSlot = diff --git a/Game/LambdaHack/Client/UI/Frontend.hs b/Game/LambdaHack/Client/UI/Frontend.hs --- a/Game/LambdaHack/Client/UI/Frontend.hs +++ b/Game/LambdaHack/Client/UI/Frontend.hs @@ -44,12 +44,12 @@ -- | The instructions sent by clients to the raw frontend. data FrontReq :: * -> * where -- | Show a frame. - FrontFrame :: {frontFrame :: !FrameForall} -> FrontReq () + FrontFrame :: {frontFrame :: FrameForall} -> FrontReq () -- | Perform an explicit delay of the given length. - FrontDelay :: !Int -> FrontReq () + FrontDelay :: Int -> FrontReq () -- | Flush frames, display a frame and ask for a keypress. - FrontKey :: { frontKeyKeys :: ![K.KM] - , frontKeyFrame :: !FrameForall } -> FrontReq KMP + FrontKey :: { frontKeyKeys :: [K.KM] + , frontKeyFrame :: FrameForall } -> FrontReq KMP -- | Inspect the fkeyPressed MVar. FrontPressed :: FrontReq Bool -- | discard a key in the queue, if any. @@ -66,9 +66,9 @@ newtype ChanFrontend = ChanFrontend (forall a. FrontReq a -> IO a) data FSession = FSession - { fautoYesRef :: !(IORef Bool) - , fasyncTimeout :: !(Async ()) - , fdelay :: !(MVar Int) + { fautoYesRef :: IORef Bool + , fasyncTimeout :: Async () + , fdelay :: MVar Int } -- | Display a prompt, wait for any of the specified keys (for any key, 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 @@ -17,14 +17,14 @@ import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Common.Point -data KMP = KMP { kmpKeyMod :: !K.KM - , kmpPointer :: !Point } +data KMP = KMP { kmpKeyMod :: K.KM + , kmpPointer :: Point } data RawFrontend = RawFrontend - { fdisplay :: !(SingleFrame -> IO ()) - , fshutdown :: !(IO ()) - , fshowNow :: !(MVar ()) - , fchanKey :: !(STM.TQueue KMP) + { fdisplay :: SingleFrame -> IO () + , fshutdown :: IO () + , fshowNow :: MVar () + , fchanKey :: STM.TQueue KMP } startupBound :: (MVar RawFrontend -> IO ()) -> IO RawFrontend diff --git a/Game/LambdaHack/Client/UI/Frontend/Curses.hs b/Game/LambdaHack/Client/UI/Frontend/Curses.hs --- a/Game/LambdaHack/Client/UI/Frontend/Curses.hs +++ b/Game/LambdaHack/Client/UI/Frontend/Curses.hs @@ -26,8 +26,8 @@ -- | Session data maintained by the frontend. data FrontendSession = FrontendSession - { swin :: !C.Window -- ^ the window to draw to - , sstyles :: !(M.Map (Color.Color, Color.Color) C.CursesStyle) + { swin :: C.Window -- ^ the window to draw to + , sstyles :: M.Map (Color.Color, Color.Color) C.CursesStyle -- ^ map from fore/back colour pairs to defined curses styles } @@ -46,7 +46,7 @@ , bg <- [Color.Black, Color.Blue, Color.White, Color.BrBlack] ] nr <- C.colorPairs when (nr < length s) $ - C.end >> (assert `failure` "terminal has too few color pairs" `twith` nr) + C.end >> (error $ "terminal has too few color pairs" `showFailure` nr) let (ks, vs) = unzip s ws <- C.convertStyles vs let swin = C.stdScr @@ -103,7 +103,8 @@ Color.HighlightGrey -> if fg /= Color.BrBlack then (fg, Color.BrBlack) - else (fg, Color.defFG) ] + else (fg, Color.defFG) + _ -> (fg, Color.Black) ] C.refresh keyTranslate :: C.Key -> K.KM diff --git a/Game/LambdaHack/Client/UI/Frontend/Dom.hs b/Game/LambdaHack/Client/UI/Frontend/Dom.hs --- a/Game/LambdaHack/Client/UI/Frontend/Dom.hs +++ b/Game/LambdaHack/Client/UI/Frontend/Dom.hs @@ -53,9 +53,9 @@ -- | Session data maintained by the frontend. data FrontendSession = FrontendSession - { scurrentWindow :: !Window - , scharCells :: !(V.Vector (HTMLTableCellElement, CSSStyleDeclaration)) - , spreviousFrame :: !(IORef SingleFrame) + { scurrentWindow :: Window + , scharCells :: V.Vector (HTMLTableCellElement, CSSStyleDeclaration) + , spreviousFrame :: IORef SingleFrame } extraBlankMargin :: Int @@ -140,8 +140,10 @@ -- putStrLn $ "modifier: " ++ show modifier when (key == K.Esc) $ IO.liftIO $ resetChanKey (fchanKey rf) IO.liftIO $ saveKMP rf modifierNoShift key originPoint - -- Pass through C-+ and others, disable special behaviour on Tab. - when (modifier `elem` [K.NoModifier, K.Shift, K.Control]) $ do + -- Pass through C-+ and others, but disable special behaviour on Tab, etc. + let browserKeys = "+-0tTnNdxcv" + unless (modifier == K.Alt + || modifier == K.Control && key `elem` map K.Char browserKeys) $ do preventDefault stopPropagation -- Handle mouseclicks, per-cell. @@ -265,6 +267,10 @@ setProp style "border-color" $ Color.colorToRGB Color.BrYellow Color.HighlightGrey -> setProp style "border-color" $ Color.colorToRGB Color.BrBlack + Color.HighlightWhite -> + setProp style "border-color" $ Color.colorToRGB Color.White + Color.HighlightMagenta -> + setProp style "border-color" $ Color.colorToRGB Color.Magenta !prevFrame <- readIORef spreviousFrame writeIORef spreviousFrame curFrame -- This continues asynchronously, if can't otherwise. diff --git a/Game/LambdaHack/Client/UI/Frontend/Gtk.hs b/Game/LambdaHack/Client/UI/Frontend/Gtk.hs --- a/Game/LambdaHack/Client/UI/Frontend/Gtk.hs +++ b/Game/LambdaHack/Client/UI/Frontend/Gtk.hs @@ -1,6 +1,4 @@ -#if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -Wno-unused-do-bind #-} -#endif -- | Text frontend based on Gtk. module Game.LambdaHack.Client.UI.Frontend.Gtk ( startup, frontendName @@ -33,8 +31,8 @@ -- | Session data maintained by the frontend. data FrontendSession = FrontendSession - { sview :: !TextView -- ^ the widget to draw to - , stags :: !(IM.IntMap TextTag) -- ^ text color tags for fg/bg + { sview :: TextView -- ^ the widget to draw to + , stags :: IM.IntMap TextTag -- ^ text color tags for fg/bg } -- | The name of the frontend. @@ -70,6 +68,8 @@ if fg /= Color.BrBlack then (fg, Color.BrBlack) else (fg, Color.defFG) + Color.Attr{fg} -> + (fg, Color.Black) ttt <- textTagTableNew stags <- IM.fromDistinctAscList <$> mapM (\ak -> do 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 @@ -42,14 +42,14 @@ -- | Session data maintained by the frontend. data FrontendSession = FrontendSession - { swindow :: !SDL.Window - , srenderer :: !SDL.Renderer - , sfont :: !TTF.Font - , satlas :: !(IORef FontAtlas) - , stexture :: !(IORef SDL.Texture) - , spreviousFrame :: !(IORef SingleFrame) - , sforcedShutdown :: !(IORef Bool) - , sdisplayPermitted :: !(MVar Bool) + { swindow :: SDL.Window + , srenderer :: SDL.Renderer + , sfont :: TTF.Font + , satlas :: IORef FontAtlas + , stexture :: IORef SDL.Texture + , spreviousFrame :: IORef SingleFrame + , sforcedShutdown :: IORef Bool + , sdisplayPermitted :: MVar Bool } -- | The name of the frontend. @@ -73,7 +73,7 @@ | otherwise = fontFileName fontFileExists <- doesFileExist fontFile unless fontFileExists $ - assert `failure` "Font file does not exist: " ++ fontFile + fail $ "Font file does not exist: " ++ fontFile let fontSize = fromJust sfontSize TTF.initialize sfont <- TTF.load fontFile fontSize @@ -248,6 +248,8 @@ Color.HighlightBlue -> normalizeAc Color.Blue Color.HighlightYellow -> normalizeAc Color.BrYellow Color.HighlightGrey -> normalizeAc Color.BrBlack + Color.HighlightWhite -> normalizeAc Color.White + Color.HighlightMagenta -> normalizeAc Color.BrMagenta -- https://www.libsdl.org/projects/SDL_ttf/docs/SDL_ttf_42.html#SEC42 textTexture <- case EM.lookup ac atlas of Nothing -> do diff --git a/Game/LambdaHack/Client/UI/Frontend/Vty.hs b/Game/LambdaHack/Client/UI/Frontend/Vty.hs --- a/Game/LambdaHack/Client/UI/Frontend/Vty.hs +++ b/Game/LambdaHack/Client/UI/Frontend/Vty.hs @@ -124,6 +124,7 @@ if fg /= Color.BrBlack then (fg, Color.BrBlack) else (fg, Color.defFG) + _ -> (fg, Color.Black) in hack fg1 $ hack bg1 $ defAttr { attrForeColor = SetTo (aToc fg1) , attrBackColor = SetTo (aToc bg1) } diff --git a/Game/LambdaHack/Client/UI/HandleHelperM.hs b/Game/LambdaHack/Client/UI/HandleHelperM.hs --- a/Game/LambdaHack/Client/UI/HandleHelperM.hs +++ b/Game/LambdaHack/Client/UI/HandleHelperM.hs @@ -141,7 +141,7 @@ (np, b, _) : _ -> do success <- pickLeader verbose np let !_A = assert (success `blame` "same leader" - `twith` (leader, np, b)) () + `swith` (leader, np, b)) () return Nothing -- | Switches current member to the previous in the whole dungeon, wrapping. @@ -158,7 +158,7 @@ (np, b, _) : _ -> do success <- pickLeader verbose np let !_A = assert (success `blame` "same leader" - `twith` (leader, np, b)) () + `swith` (leader, np, b)) () return Nothing partyAfterLeader :: MonadClientUI m => ActorId -> m [(ActorId, Actor, ActorUI)] @@ -186,7 +186,7 @@ bodyUI <- getsSession $ getActorUI aid let !_A = assert (not (bproj body) `blame` "projectile chosen as the leader" - `twith` (aid, body)) () + `swith` (aid, body)) () -- Even if it's already the leader, give his proper name, not 'you'. let subject = partActor bodyUI when verbose $ msgAdd $ makeSentence [subject, "picked as a leader"] @@ -273,7 +273,7 @@ statsOverlay aid = do b <- getsState $ getActorBody aid actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` aid) (EM.lookup aid actorAspect) + let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) prSlot :: (Y, SlotChar) -> IK.EqpSlot -> (Text, KYX) prSlot (y, c) eqpSlot = let statName = slotToName eqpSlot @@ -288,33 +288,38 @@ return (map textToAL ts, kxs) pickNumber :: MonadClientUI m => Bool -> Int -> m (Either MError Int) -pickNumber askNumber kAll = do +pickNumber askNumber kAll = assert (kAll >= 1) $ do let shownKeys = [ K.returnKM, K.mkChar '+', K.mkChar '-' , K.spaceKM, K.escKM ] frontKeyKeys = K.backspaceKM : shownKeys ++ map K.mkChar ['0'..'9'] - gatherNumber pointer kCurRaw = do - let kCur = min kAll $ max 1 kCurRaw - kprompt = "Choose number:" <+> tshow kCur + gatherNumber pointer kCur = assert (1 <= kCur && kCur <= kAll) $ do + let kprompt = "Choose number:" <+> tshow kCur promptAdd kprompt sli <- reportToSlideshow shownKeys - (Left kkm, pointer2) <- + (ekkm, pointer2) <- displayChoiceScreen ColorFull False pointer sli frontKeyKeys - case K.key kkm of - K.Char '+' -> - gatherNumber pointer2 $ if kCur + 1 > kAll then 1 else kCur + 1 - K.Char '-' -> - gatherNumber pointer2 $ if kCur - 1 < 1 then kAll else kCur - 1 - K.Char l | kCur == kAll -> gatherNumber pointer2 $ Char.digitToInt l - K.Char l -> gatherNumber pointer2 $ kCur * 10 + Char.digitToInt l - K.BackSpace -> gatherNumber pointer2 $ kCur `div` 10 - K.Return -> return $ Right kCur - K.Esc -> weaveJust <$> failWith "never mind" - K.Space -> return $ Left Nothing - _ -> assert `failure` "unexpected key:" `twith` kkm - if | kAll == 0 -> assert `failure` askNumber - | kAll == 1 || not askNumber -> return $ Right kAll + case ekkm of + Left kkm -> + case K.key kkm of + K.Char '+' -> + gatherNumber pointer2 $ if kCur + 1 > kAll then 1 else kCur + 1 + K.Char '-' -> + gatherNumber pointer2 $ if kCur - 1 < 1 then kAll else kCur - 1 + K.Char l | kCur * 10 + Char.digitToInt l > kAll -> + gatherNumber pointer2 + $ if Char.digitToInt l == 0 + then kAll + else min kAll (Char.digitToInt l) + K.Char l -> gatherNumber pointer2 $ kCur * 10 + Char.digitToInt l + K.BackSpace -> gatherNumber pointer2 $ max 1 (kCur `div` 10) + K.Return -> return $ Right kCur + K.Esc -> weaveJust <$> failWith "never mind" + K.Space -> return $ Left Nothing + _ -> error $ "unexpected key" `showFailure` kkm + Right sc -> error $ "unexpected slot char" `showFailure` sc + if | kAll == 1 || not askNumber -> return $ Right kAll | otherwise -> do res <- gatherNumber 0 kAll case res of - Right k | k <= 0 -> assert `failure` (res, kAll) + Right k | k <= 0 -> error $ "" `showFailure` (res, kAll) _ -> return res 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 @@ -308,7 +308,7 @@ -- Select adjacent actor by bumping into him. Takes no time. success <- pickLeader True target let !_A = assert (success `blame` "bump self" - `twith` (leader, target, tb)) () + `swith` (leader, target, tb)) () failWith "by bumping" else -- Attacking does not require full access, adjacency is enough. @@ -382,7 +382,7 @@ -- Displacing requires full access. if Tile.isWalkable coTileSpeedup $ lvl `at` tpos then case posToAidsLvl tpos lvl of - [] -> assert `failure` (leader, sb, target, tb) + [] -> error $ "" `showFailure` (leader, sb, target, tb) [_] -> return $ Right $ ReqDisplace target _ -> failSer DisplaceProjectiles else failSer DisplaceAccess @@ -502,7 +502,7 @@ arena <- getArenaUI runOutcome <- multiActorGoTo arena c paramOld case runOutcome of - Left stopMsg -> failWith stopMsg + Left stopMsg -> return $ Left stopMsg Right (finalGoal, dir) -> moveRunHuman initialStep finalGoal run False dir _ -> do @@ -523,12 +523,10 @@ moveRunHuman initialStep finalGoal run False dir multiActorGoTo :: MonadClientUI m - => LevelId -> Point -> RunParams - -> m (Either Text (Bool, Vector)) + => LevelId -> Point -> RunParams -> m (FailOrCmd (Bool, Vector)) multiActorGoTo arena c paramOld = case paramOld of - RunParams{runMembers = []} -> - return $ Left "selected actors no longer there" + RunParams{runMembers = []} -> failWith "selected actors no longer there" RunParams{runMembers = r : rs, runWaiting} -> do onLevel <- getsState $ memActor r arena if not onLevel then do @@ -545,11 +543,9 @@ xhairMoused <- getsSession sxhairMoused case mpath of _ | xhairMoused && isNothing (accessBfs bfs c) -> - return $ Left "no route to crosshair" - NoPath -> return $ Left "no route to crosshair" - AndPath{pathList=[]} -> - -- This actor already at goal; will be caught in goToXhair. - return $ Left "" + failWith "no route to crosshair" + NoPath -> failWith "no route to crosshair" + AndPath{pathList=[]} -> failWith "almost there" AndPath{pathList = p1 : _} -> do let finalGoal = p1 == c dir = towards (bpos b) p1 @@ -563,7 +559,7 @@ -- to avoid cycles. When all wait for each other, fail. multiActorGoTo arena c paramNew{runWaiting=runWaiting + 1} _ -> - return $ Left "actor in the way" + failWith "actor in the way" -- * RunOnceToXhair @@ -637,11 +633,18 @@ -- and the server will ignore and warn (and content may avoid that, -- e.g., making all rings identified) actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` leader) (EM.lookup leader actorAspect) + lastItemMove <- getsSession slastItemMove + let ar = fromMaybe (error $ "" `showFailure` leader) + (EM.lookup leader actorAspect) calmE = calmEnough b ar - cLegal | calmE = cLegalRaw - | destCStore == CSha = [] - | otherwise = delete CSha cLegalRaw + cLegalE | calmE = cLegalRaw + | destCStore == CSha = [] + | otherwise = delete CSha cLegalRaw + cLegal = case lastItemMove of + Just (lastFrom, lastDest) | lastDest == destCStore + && lastFrom `elem` cLegalE -> + lastFrom : delete lastFrom cLegalE + _ -> cLegalE prompt = makePhrase ["What to", verb] promptEqp = makePhrase ["What consumable to", verb] (promptGeneric, psuit) = @@ -658,9 +661,12 @@ (\_ _ _ cCur -> promptGeneric <+> ppItemDialogModeFrom cCur) cLegalRaw cLegal (not auto) True case ggi of - Right (l, (MStore fromCStore, _)) -> return $ Right (fromCStore, l) + Right (l, (MStore fromCStore, _)) -> do + modifySession $ \sess -> + sess {slastItemMove = Just (fromCStore, destCStore)} + return $ Right (fromCStore, l) Left err -> failWith err - _ -> assert `failure` ggi + _ -> error $ "" `showFailure` ggi moveItems :: forall m. MonadClientUI m => [CStore] -> (CStore, [(ItemId, ItemFull)]) -> CStore @@ -670,7 +676,8 @@ b <- getsState $ getActorBody leader actorAspect <- getsClient sactorAspect discoBenefit <- getsClient sdiscoBenefit - let ar = fromMaybe (assert `failure` leader) (EM.lookup leader actorAspect) + let ar = fromMaybe (error $ "" `showFailure` leader) + (EM.lookup leader actorAspect) calmE = calmEnough b ar ret4 :: MonadClientUI m => [(ItemId, ItemFull)] @@ -718,7 +725,7 @@ l4 <- ret4 l 0 [] return $! case l4 of Left err -> Left err - Right [] -> assert `failure` l + Right [] -> error $ "" `showFailure` l Right lr -> Right $ ReqMoveItems lr -- * Project @@ -747,7 +754,8 @@ leader <- getLeaderUI b <- getsState $ getActorBody leader actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` leader) (EM.lookup leader actorAspect) + let ar = fromMaybe (error $ "" `showFailure` leader) + (EM.lookup leader actorAspect) calmE = calmEnough b ar if not calmE && fromCStore == CSha then failSer ItemNotCalm else do @@ -793,7 +801,8 @@ leader <- getLeaderUI b <- getsState $ getActorBody leader actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` leader) (EM.lookup leader actorAspect) + let ar = fromMaybe (error $ "" `showFailure` leader) + (EM.lookup leader actorAspect) calmE = calmEnough b ar if not calmE && fromCStore == CSha then failSer ItemNotCalm else do @@ -973,7 +982,7 @@ _ | km == K.escKM -> return $ Left Nothing Just (_desc, _cats, cmd) -> cmdAction cmd Nothing -> weaveJust <$> failWith "never mind" - Right _slot -> assert `failure` ekm + Right _slot -> error $ "" `showFailure` ekm -- * ItemMenu @@ -992,7 +1001,7 @@ Nothing -> weaveJust <$> failWith "no item to open Item Menu for" Just kit -> do actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` leader) + let ar = fromMaybe (error $ "" `showFailure` leader) (EM.lookup leader actorAspect) itemToF <- itemToFullClient lidV <- viewedLevelUI @@ -1069,10 +1078,10 @@ modifySession $ \sess -> sess {sitemSel = Just (newCStore, iid)} itemMenuHuman cmdAction - _ -> assert `failure` km + _ -> error $ "" `showFailure` km Just (_desc, _cats, cmd) -> cmdAction cmd Nothing -> weaveJust <$> failWith "never mind" - Right _slot -> assert `failure` ekm + Right _slot -> error $ "" `showFailure` ekm Nothing -> weaveJust <$> failWith "no item to open Item Menu for" -- * ChooseItemMenu @@ -1166,7 +1175,7 @@ Left km -> case km `lookup` kds of Just (_desc, cmd) -> cmdAction cmd Nothing -> weaveJust <$> failWith "never mind" - Right _slot -> assert `failure` ekm + Right _slot -> error $ "" `showFailure` ekm -- | Display the main menu. mainMenuHuman :: MonadClientUI m @@ -1209,7 +1218,7 @@ 0 -> "off" 1 -> "on" 2 -> "all" - _ -> assert `failure` n + _ -> error $ "" `showFailure` n tsuspect = "suspect terrain:" <+> offOnAll markSuspect tvisible = "visible zone:" <+> offOn markVision tsmell = "smell clues:" <+> offOn markSmell @@ -1223,7 +1232,7 @@ bindingLen = 30 gameInfo = map T.unpack [ T.justifyLeft bindingLen ' ' "" - , T.justifyLeft bindingLen ' ' "Game settings:" + , T.justifyLeft bindingLen ' ' "Convenience settings:" , T.justifyLeft bindingLen ' ' "" ] generateMenu cmdAction kds gameInfo "settings" diff --git a/Game/LambdaHack/Client/UI/HandleHumanLocalM.hs b/Game/LambdaHack/Client/UI/HandleHumanLocalM.hs --- a/Game/LambdaHack/Client/UI/HandleHumanLocalM.hs +++ b/Game/LambdaHack/Client/UI/HandleHumanLocalM.hs @@ -174,7 +174,7 @@ localTime <- getsState $ getLocalTime (blid b) factionD <- getsState sfactionD actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` leader) + let ar = fromMaybe (error $ "" `showFailure` leader) (EM.lookup leader actorAspect) attrLine = itemDesc (bfid b) factionD (aHurtMelee ar) store localTime itemFull @@ -202,7 +202,7 @@ Just (_, store) -> (leader, store) Nothing -> case found of (aid, (_, store)) : _ -> (aid, store) - [] -> assert `failure` iid + [] -> error $ "" `showFailure` iid modifySession $ \sess -> sess {sitemSel = Just (bestStore, iid)} arena <- getArenaUI b2 <- getsState $ getActorBody newAid @@ -213,21 +213,21 @@ | otherwise -> do void $ pickLeader True newAid return $ Right c2 - MStats -> assert `failure` ggi + MStats -> error $ "" `showFailure` ggi MLoreItem -> displayLore CGround (makeSentence [ MU.SubjectVerbSg (partActor bUI) "remember" , "item lore" ]) MLoreOrgan -> displayLore COrgan (makeSentence [ MU.SubjectVerbSg (partActor bUI) "remember" , "organ lore" ]) - (Left _, (MStats, ekm)) -> case ekm of - Right slot -> do + (Left err, (MStats, ekm)) -> case ekm of + Right slot -> assert (err == "stats") $ do let eqpSlot = statSlots !! fromJust (elemIndex slot allZeroSlots) leader <- getLeaderUI b <- getsState $ getActorBody leader bUI <- getsSession $ getActorUI leader actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` leader) + let ar = fromMaybe (error $ "" `showFailure` leader) (EM.lookup leader actorAspect) valueText = slotToDecorator eqpSlot b $ prEqpSlot eqpSlot ar prompt2 = makeSentence @@ -248,7 +248,8 @@ leader <- getLeaderUI b <- getsState $ getActorBody leader actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` leader) (EM.lookup leader actorAspect) + let ar = fromMaybe (error $ "" `showFailure` leader) + (EM.lookup leader actorAspect) let calmE = calmEnough b ar cLegalRaw = [CGround, CInv, CSha, CEqp] cLegal | calmE = cLegalRaw @@ -271,7 +272,7 @@ modifySession $ \sess -> sess {sitemSel = Just (fromCStore, iid)} return Nothing Left err -> failMsg err - _ -> assert `failure` ggi + _ -> error $ "" `showFailure` ggi permittedProjectClient :: MonadClientUI m => [Char] -> m (ItemFull -> Either ReqFailure Bool) @@ -281,7 +282,8 @@ actorSk <- leaderSkillsClientUI let skill = EM.findWithDefault 0 AbProject actorSk actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` leader) (EM.lookup leader actorAspect) + let ar = fromMaybe (error $ "" `showFailure` leader) + (EM.lookup leader actorAspect) calmE = calmEnough b ar return $ permittedProject False skill calmE triggerSyms @@ -296,8 +298,8 @@ Level{lxsize, lysize} <- getLevel lid case bla lxsize lysize eps spos tpos of Nothing -> return $ Just ProjectAimOnself - Just [] -> assert `failure` "project from the edge of level" - `twith` (spos, tpos, sb) + Just [] -> error $ "project from the edge of level" + `showFailure` (spos, tpos, sb) Just (pos : _) -> do lvl <- getLevel lid let t = lvl `at` pos @@ -342,13 +344,13 @@ let pos = bpos body if blid body == lidV then findNewEps False pos - else assert `failure` (xhair, body, lidV) + else error $ "" `showFailure` (xhair, body, lidV) TPoint TEnemyPos{} _ _ -> return $ Left "selected opponent not visible" TPoint _ lid pos -> if lid == lidV then findNewEps True pos - else assert `failure` (xhair, lidV) + else error $ "" `showFailure` (xhair, lidV) TVector v -> do Level{lxsize, lysize} <- getLevel lidV let shifted = shiftBounded lxsize lysize (bpos b) v @@ -366,7 +368,7 @@ sxhair <- getsSession sxhair mpos <- xhairToPos case mpos of - Nothing -> assert `failure` sxhair + Nothing -> error $ "" `showFailure` sxhair Just pos -> do munit <- projectCheck pos case munit of @@ -407,7 +409,8 @@ leader <- getLeaderUI b <- getsState $ getActorBody leader actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` leader) (EM.lookup leader actorAspect) + let ar = fromMaybe (error $ "" `showFailure` leader) + (EM.lookup leader actorAspect) calmE = calmEnough b ar cLegalRaw = [CGround, CInv, CSha, CEqp] cLegal | calmE = cLegalRaw @@ -427,7 +430,7 @@ modifySession $ \sess -> sess {sitemSel = Just (fromCStore, iid)} return Nothing Left err -> failMsg err - _ -> assert `failure` ggi + _ -> error $ "" `showFailure` ggi permittedApplyClient :: MonadClientUI m => [Char] -> m (ItemFull -> Either ReqFailure Bool) @@ -437,7 +440,8 @@ actorSk <- leaderSkillsClientUI let skill = EM.findWithDefault 0 AbApply actorSk actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` leader) (EM.lookup leader actorAspect) + let ar = fromMaybe (error $ "" `showFailure` leader) + (EM.lookup leader actorAspect) calmE = calmEnough b ar localTime <- getsState $ getLocalTime (blid b) return $ permittedApply localTime skill calmE triggerSyms @@ -618,11 +622,11 @@ promptAdd "Try to survive a few seconds more, if you can." Right SlotChar{..} | slotChar == 'a' -> displayOneReport slotPrefix - _ -> assert `failure` ekm + _ -> error $ "" `showFailure` ekm displayOneReport :: Int -> m () displayOneReport histSlot = do let timeReport = case drop histSlot rh of - [] -> assert `failure` histSlot + [] -> error $ "" `showFailure` histSlot tR : _ -> tR ov0 = splitReportForHistory lxsize timeReport prompt = makeSentence @@ -639,7 +643,7 @@ K.Up -> displayOneReport $ histSlot - 1 K.Down -> displayOneReport $ histSlot + 1 K.Esc -> promptAdd "Try to learn from your previous mistakes." - _ -> assert `failure` km + _ -> error $ "" `showFailure` km displayAllHistory -- * MarkVision @@ -721,6 +725,7 @@ case saimMode of Nothing -> return () Just aimMode -> do + side <- getsClient sside leader <- getLeaderUI let lidV = aimLevelId aimMode lvl <- getLevel lidV @@ -735,23 +740,36 @@ seps <- getsClient seps mnewEps <- makeLine False b p seps itemToF <- itemToFullClient + factionD <- getsState sfactionD + s <- getState let aims = isJust mnewEps enemyMsg = case inhabitants of [] -> "" (_, body) : rest -> - -- Even if it's the leader, give his proper name, not 'you'. - let subjects = map (\(_, _, bUI) -> - partActor bUI) inhabitantsUI - subject = MU.WWandW subjects - verb = "be here" - desc = - if not (null rest) -- many actors, only list names - then "" - else case itemDisco $ itemToF (btrunk body) (1, []) of - Nothing -> "" -- no details, only show the name - Just ItemDisco{itemKind} -> IK.idesc itemKind - pdesc = if desc == "" then "" else "(" <> desc <> ")" - in makeSentence [MU.SubjectVerbSg subject verb] <+> pdesc + let Item{jfid} = getItemBody (btrunk body) s + bfact = factionD EM.! bfid body + -- Even if it's the leader, give his proper name, not 'you'. + subjects = map (\(_, _, bUI) -> partActor bUI) + inhabitantsUI + subject = MU.WWandW subjects + verb = "be here" + factDesc = case jfid of + Just tfid | tfid /= bfid body -> + let dominatedBy = if bfid body == side + then "us" + else gname bfact + tfact = factionD EM.! tfid + in "Originally of" <+> gname tfact + <> ", now fighting for" <+> dominatedBy <> "." + _ | bfid body == side -> "" -- just one of us + _ -> "One of" <+> gname bfact <> "." + idesc = case itemDisco $ itemToF (btrunk body) (1, []) of + Nothing -> "" -- no details, only show the name + Just ItemDisco{itemKind} -> IK.idesc itemKind + -- If many actors (projectiles), only list names. + desc = if not (null rest) then "" else factDesc <+> idesc + pdesc = if desc == "" then "" else "(" <> desc <> ")" + in makeSentence [MU.SubjectVerbSg subject verb] <+> pdesc canSee = ES.member p (totalVisible per) vis | isUknownSpace $ lvl `at` p = "that is" | not canSee = "you remember" @@ -768,7 +786,7 @@ moveXhairHuman dir n = do leader <- getLeaderUI saimMode <- getsSession saimMode - let lidV = maybe (assert `failure` leader) aimLevelId saimMode + let lidV = maybe (error $ "" `showFailure` leader) aimLevelId saimMode Level{lxsize, lysize} <- getLevel lidV lpos <- getsState $ bpos . getActorBody leader sxhair <- getsSession sxhair diff --git a/Game/LambdaHack/Client/UI/HumanCmd.hs b/Game/LambdaHack/Client/UI/HumanCmd.hs --- a/Game/LambdaHack/Client/UI/HumanCmd.hs +++ b/Game/LambdaHack/Client/UI/HumanCmd.hs @@ -85,29 +85,29 @@ -- | Abstract syntax of player commands. data HumanCmd = -- Meta. - Macro ![String] - | ByArea ![(CmdArea, HumanCmd)] -- if outside the areas, do nothing - | ByAimMode {exploration :: !HumanCmd, aiming :: !HumanCmd} - | ByItemMode {ts :: ![Trigger], notChosen :: !HumanCmd, chosen :: !HumanCmd} - | ComposeIfLocal !HumanCmd !HumanCmd - | ComposeUnlessError !HumanCmd !HumanCmd - | Compose2ndLocal !HumanCmd !HumanCmd - | LoopOnNothing !HumanCmd + Macro [String] + | ByArea [(CmdArea, HumanCmd)] -- if outside the areas, do nothing + | ByAimMode {exploration :: HumanCmd, aiming :: HumanCmd} + | ByItemMode {ts :: [Trigger], notChosen :: HumanCmd, chosen :: HumanCmd} + | ComposeIfLocal HumanCmd HumanCmd + | ComposeUnlessError HumanCmd HumanCmd + | Compose2ndLocal HumanCmd HumanCmd + | LoopOnNothing HumanCmd -- Global. -- These usually take time. | Wait | Wait10 - | MoveDir !Vector - | RunDir !Vector + | MoveDir Vector + | RunDir Vector | RunOnceAhead | MoveOnceToXhair | RunOnceToXhair | ContinueToXhair - | MoveItem ![CStore] !CStore !(Maybe MU.Part) !Bool - | Project ![Trigger] - | Apply ![Trigger] - | AlterDir ![Trigger] - | AlterWithPointer ![Trigger] + | MoveItem [CStore] CStore (Maybe MU.Part) Bool + | Project [Trigger] + | Apply [Trigger] + | AlterDir [Trigger] + | AlterWithPointer [Trigger] | Help | ItemMenu | MainMenu @@ -124,18 +124,18 @@ -- Local. Below this line, commands do not notify the server. | Clear | SortSlots - | ChooseItem !ItemDialogMode - | ChooseItemMenu !ItemDialogMode - | ChooseItemProject ![Trigger] - | ChooseItemApply ![Trigger] - | PickLeader !Int + | ChooseItem ItemDialogMode + | ChooseItemMenu ItemDialogMode + | ChooseItemProject [Trigger] + | ChooseItemApply [Trigger] + | PickLeader Int | PickLeaderWithPointer | MemberCycle | MemberBack | SelectActor | SelectNone | SelectWithPointer - | Repeat !Int + | Repeat Int | Record | History | MarkVision @@ -148,16 +148,16 @@ | Accept | TgtClear | ItemClear - | MoveXhair !Vector !Int + | MoveXhair Vector Int | AimTgt | AimFloor | AimEnemy | AimItem - | AimAscend !Int - | EpsIncr !Bool + | AimAscend Int + | EpsIncr Bool | XhairUnknown | XhairItem - | XhairStair !Bool + | XhairStair Bool | XhairPointerFloor | XhairPointerEnemy | AimPointerFloor @@ -187,12 +187,12 @@ _ -> False data Trigger = - ApplyItem {verb :: !MU.Part, object :: !MU.Part, symbol :: !Char} - | AlterFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !TK.Feature} + ApplyItem {verb :: MU.Part, object :: MU.Part, symbol :: Char} + | AlterFeature {verb :: MU.Part, object :: MU.Part, feature :: TK.Feature} deriving (Show, Eq, Ord, Generic) instance Read Trigger where - readsPrec = assert `failure` "parsing of Trigger not implemented" `twith` () + readsPrec = error $ "parsing of Trigger not implemented" `showFailure` () instance NFData Trigger 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 @@ -101,7 +101,7 @@ case soc of Left err -> return $ Left err Right ([(iid, itemFull)], cekm) -> return $ Right ((iid, itemFull), cekm) - Right _ -> assert `failure` soc + Right _ -> error $ "" `showFailure` soc -- | Display all items from a store and let the human player choose any -- or switch to any other store. @@ -125,7 +125,7 @@ case soc of (Left err, cekm) -> return (Left err, cekm) (Right [(iid, itemFull)], cekm) -> return (Right (iid, itemFull), cekm) - (Right{}, _) -> assert `failure` soc + (Right{}, _) -> error $ "" `showFailure` soc -- | Let the human player choose a single, preferably suitable, -- item from a list of items. Don't display stores empty for all actors. @@ -220,7 +220,7 @@ ItemSlots itemSlots organSlots <- getsSession sslots let isOrgan = cCur `elem` [MStore COrgan, MLoreOrgan] lSlots = if isOrgan then organSlots else itemSlots - slotChar = fromMaybe (assert `failure` (iid, lSlots)) + slotChar = fromMaybe (error $ "" `showFailure` (iid, lSlots)) $ lookup iid $ map swap $ EM.assocs lSlots return (Right [(iid, itemToF iid k)], (cCur, Right slotChar)) _ -> @@ -228,11 +228,11 @@ 0 cCur cRest ISuitable data DefItemKey m = DefItemKey - { defLabel :: Either Text K.KM -- ^ can be undefined if not @defCond@ - , defCond :: !Bool + { defLabel :: Either Text K.KM + , defCond :: Bool , defAction :: Either K.KM SlotChar - -> m ( Either Text [(ItemId, ItemFull)] - , (ItemDialogMode, Either K.KM SlotChar) ) + -> m ( Either Text [(ItemId, ItemFull)] + , (ItemDialogMode, Either K.KM SlotChar) ) } data Suitability = @@ -259,7 +259,8 @@ body <- getsState $ getActorBody leader bodyUI <- getsSession $ getActorUI leader actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` leader) (EM.lookup leader actorAspect) + let ar = fromMaybe (error $ "" `showFailure` leader) + (EM.lookup leader actorAspect) fact <- getsState $ (EM.! bfid body) . sfactionD hs <- partyAfterLeader leader bagAll <- getsState $ \s -> accessModeBag leader s cCur @@ -307,7 +308,7 @@ revCmd dflt cmd = case M.lookup cmd brevMap of Nothing -> dflt Just (k : _) -> k - Just [] -> assert `failure` brevMap + Just [] -> error $ "" `showFailure` brevMap keyDefs :: [(K.KM, DefItemKey m)] keyDefs = filter (defCond . snd) $ [ let km = K.mkChar '?' @@ -378,9 +379,9 @@ (cCurAfterCalm, cRestAfterCalm) = case cRest ++ mcCur of c1@(MStore CSha) : c2 : rest | not calmE -> (c2, c1 : rest) - [MStore CSha] | not calmE -> assert `failure` cRest + [MStore CSha] | not calmE -> error $ "" `showFailure` cRest c1 : rest -> (c1, rest) - [] -> assert `failure` cRest + [] -> error $ "" `showFailure` cRest recCall numPrefix cCurAfterCalm cRestAfterCalm itemDialogState } useMultipleDef defLabel = DefItemKey @@ -406,12 +407,12 @@ let slot = case ekm of Left K.KM{key} -> case key of K.Char l -> SlotChar numPrefix l - _ -> assert `failure` "unexpected key:" - `twith` K.showKey key + _ -> error $ "unexpected key:" + `showFailure` K.showKey key Right sl -> sl in case EM.lookup slot bagItemSlotsAll of - Nothing -> assert `failure` "unexpected slot" - `twith` (slot, bagItemSlots) + Nothing -> error $ "unexpected slot" + `showFailure` (slot, bagItemSlots) Just iid -> return $! getResult (Right slot) iid } (bagFiltered, promptChosen) = @@ -431,10 +432,10 @@ let slot = case ekm of Left K.KM{key} -> case key of K.Char l -> SlotChar numPrefix l - _ -> assert `failure` "unexpected key:" - `twith` K.showKey key + _ -> error $ "unexpected key:" + `showFailure` K.showKey key Right sl -> sl - in return (Left "", (MStats, Right slot)) + in return (Left "stats", (MStats, Right slot)) } runDefItemKey keyDefs statsDef io slotKeys promptChosen MStats _ -> do @@ -444,7 +445,7 @@ runDefItemKey keyDefs lettersDef io slotKeys promptChosen cCur keyOfEKM :: Int -> Either [K.KM] SlotChar -> Maybe K.KM -keyOfEKM _ (Left kms) = assert `failure` kms +keyOfEKM _ (Left kms) = error $ "" `showFailure` kms keyOfEKM numPrefix (Right SlotChar{..}) | slotPrefix == numPrefix = Just $ K.mkChar slotChar keyOfEKM _ _ = Nothing @@ -458,13 +459,14 @@ let newLegal = cCur : cRest -- not updated in any way yet b <- getsState $ getActorBody leader actorAspect <- getsClient sactorAspect - let ar = fromMaybe (assert `failure` leader) (EM.lookup leader actorAspect) + let ar = fromMaybe (error $ "" `showFailure` leader) + (EM.lookup leader actorAspect) calmE = calmEnough b ar legalAfterCalm = case newLegal of c1@(MStore CSha) : c2 : rest | not calmE -> (c2, c1 : rest) [MStore CSha] | not calmE -> (MStore CGround, newLegal) c1 : rest -> (c1, rest) - [] -> assert `failure` (cCur, cRest) + [] -> error $ "" `showFailure` (cCur, cRest) return legalAfterCalm -- We don't create keys from slots in @okx@, so they have to be diff --git a/Game/LambdaHack/Client/UI/ItemDescription.hs b/Game/LambdaHack/Client/UI/ItemDescription.hs --- a/Game/LambdaHack/Client/UI/ItemDescription.hs +++ b/Game/LambdaHack/Client/UI/ItemDescription.hs @@ -1,6 +1,6 @@ -- | Descripitons of items. module Game.LambdaHack.Client.UI.ItemDescription - ( partItem, partItemHigh, partItemWs, partItemWsRanged + ( partItem, partItemShort, partItemHigh, partItemWs, partItemWsRanged , partItemShortAW, partItemMediumAW, partItemShortWownW , viewItem, show64With2 ) where @@ -63,10 +63,11 @@ effTs = filter (not . T.null) effTsRaw ++ if ranged then rangedDamage else [] lsource = case jfid $ itemBase itemFull of - Nothing -> [] - Just fid -> ["by" <+> if fid == side - then "us" - else gname (factionD EM.! fid)] + Just fid | jname (itemBase itemFull) `elem` ["impressed"] -> + ["by" <+> if fid == side + then "us" + else gname (factionD EM.! fid)] + _ -> [] ts = lsource ++ take n effTs ++ ["(...)" | length effTs > n] @@ -133,13 +134,13 @@ Just (IK.Timeout t) -> "(every" <+> reduce_a t <> ":" <+> rechargingTs <> ")" - _ -> assert `failure` mtimeout + _ -> error $ "" `showFailure` mtimeout | otherwise -> case mtimeout of Nothing -> "" Just (IK.Timeout t) -> "(timeout" <+> reduce_a t <> ":" <+> rechargingTs <> ")" - _ -> assert `failure` mtimeout + _ -> error $ "" `showFailure` mtimeout onSmash = if T.null onSmashTs then "" else "(on smash:" <+> onSmashTs <> ")" elab = case find elabel effects of @@ -188,6 +189,10 @@ -> CStore -> Time -> ItemFull -> (Bool, Bool, MU.Part, MU.Part) partItem side factionD = partItemN side factionD False 5 4 +partItemShort :: FactionId -> FactionDict + -> CStore -> Time -> ItemFull -> (Bool, Bool, MU.Part, MU.Part) +partItemShort side factionD = partItemN side factionD False 4 4 + partItemHigh :: FactionId -> FactionDict -> CStore -> Time -> ItemFull -> (Bool, Bool, MU.Part, MU.Part) partItemHigh side factionD = partItemN side factionD False 10 100 @@ -215,8 +220,7 @@ partItemShortAW :: FactionId -> FactionDict -> CStore -> Time -> ItemFull -> MU.Part partItemShortAW side factionD c localTime itemFull = - let (_, unique, name, _) = - partItemN side factionD False 4 4 c localTime itemFull + let (_, unique, name, _) = partItemShort side factionD c localTime itemFull in if unique then MU.Phrase ["the", name] else MU.AW name @@ -231,10 +235,9 @@ else MU.AW $ MU.Phrase [name, stats] partItemShortWownW :: FactionId -> FactionDict - -> MU.Part -> CStore -> Time -> ItemFull -> MU.Part + -> MU.Part -> CStore -> Time -> ItemFull -> MU.Part partItemShortWownW side factionD partA c localTime itemFull = - let (_, _, name, _) = - partItemN side factionD False 4 4 c localTime itemFull + let (_, _, name, _) = partItemShort side factionD c localTime itemFull in MU.WownW partA name viewItem :: Item -> Color.AttrCharW32 diff --git a/Game/LambdaHack/Client/UI/ItemSlot.hs b/Game/LambdaHack/Client/UI/ItemSlot.hs --- a/Game/LambdaHack/Client/UI/ItemSlot.hs +++ b/Game/LambdaHack/Client/UI/ItemSlot.hs @@ -23,7 +23,7 @@ import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.State -data SlotChar = SlotChar {slotPrefix :: !Int, slotChar :: !Char} +data SlotChar = SlotChar {slotPrefix :: Int, slotChar :: Char} deriving (Show, Eq) instance Ord SlotChar where @@ -42,8 +42,8 @@ c100 = c0 - if c0 > 150 then 100 else 0 in SlotChar n (chr c100) -data ItemSlots = ItemSlots !(EM.EnumMap SlotChar ItemId) - !(EM.EnumMap SlotChar ItemId) +data ItemSlots = ItemSlots (EM.EnumMap SlotChar ItemId) + (EM.EnumMap SlotChar ItemId) deriving Show instance Binary ItemSlots where diff --git a/Game/LambdaHack/Client/UI/Key.hs b/Game/LambdaHack/Client/UI/Key.hs --- a/Game/LambdaHack/Client/UI/Key.hs +++ b/Game/LambdaHack/Client/UI/Key.hs @@ -41,9 +41,9 @@ | Insert | Delete | Home - | KP !Char -- ^ a keypad key for a character (digits and operators) - | Char !Char -- ^ a single printable character - | Fun !Int -- ^ function key + | KP Char -- ^ a keypad key for a character (digits and operators) + | Char Char -- ^ a single printable character + | Fun Int -- ^ function key | LeftButtonPress -- ^ left mouse button pressed | MiddleButtonPress -- ^ middle mouse button pressed | RightButtonPress -- ^ right mouse button pressed @@ -52,7 +52,7 @@ | RightButtonRelease -- ^ right mouse button released | WheelNorth -- ^ mouse wheel rotated north | WheelSouth -- ^ mouse wheel rotated south - | Unknown !String -- ^ an unknown key, registered to warn the user + | Unknown String -- ^ an unknown key, registered to warn the user | DeadKey deriving (Ord, Eq, Generic) @@ -72,8 +72,8 @@ instance NFData Modifier -data KM = KM { modifier :: !Modifier - , key :: !Key } +data KM = KM { modifier :: Modifier + , key :: Key } deriving (Ord, Eq, Generic) instance Binary KM @@ -249,7 +249,7 @@ mkKM :: String -> KM mkKM s = let mkKey sk = case keyTranslate sk of - Unknown _ -> assert `failure` "unknown key" `twith` s + Unknown _ -> error $ "unknown key" `showFailure` s key -> key in case s of 'S':'-':rest -> KM Shift (mkKey rest) diff --git a/Game/LambdaHack/Client/UI/KeyBindings.hs b/Game/LambdaHack/Client/UI/KeyBindings.hs --- a/Game/LambdaHack/Client/UI/KeyBindings.hs +++ b/Game/LambdaHack/Client/UI/KeyBindings.hs @@ -23,10 +23,10 @@ -- | Bindings and other information about human player commands. data Binding = Binding - { bcmdMap :: !(M.Map K.KM CmdTriple) -- ^ binding of keys to commands - , bcmdList :: ![(K.KM, CmdTriple)] -- ^ the properly ordered list - -- of commands for the help menu - , brevMap :: !(M.Map HumanCmd [K.KM]) -- ^ and from commands to their keys + { bcmdMap :: M.Map K.KM CmdTriple -- ^ binding of keys to commands + , bcmdList :: [(K.KM, CmdTriple)] -- ^ the properly ordered list + -- of commands for the help menu + , brevMap :: M.Map HumanCmd [K.KM] -- ^ and from commands to their keys } -- | Binding of keys to movement and other standard commands, @@ -61,8 +61,8 @@ ++ K.moveBinding configVi configLaptop (\v -> ([CmdMove], "", moveXhairOr 1 MoveDir v)) (\v -> ([CmdMove], "", moveXhairOr 10 RunDir v)) - rejectRepetitions t1 t2 = assert `failure` "duplicate key" - `twith` (t1, t2) + rejectRepetitions t1 t2 = error $ "duplicate key" + `showFailure` (t1, t2) in Binding { bcmdMap = M.fromListWith rejectRepetitions [ (k, triple) @@ -181,21 +181,21 @@ keySel sel key = let cmd = case M.lookup key bcmdMap of Just (_, _, cmd2) -> cmd2 - Nothing -> assert `failure` key + Nothing -> error $ "" `showFailure` key caCmds = case cmd of ByAimMode{..} -> case sel (exploration, aiming) of ByArea l -> sort l - _ -> assert `failure` cmd - _ -> assert `failure` cmd + _ -> error $ "" `showFailure` cmd + _ -> error $ "" `showFailure` cmd caMakeChoice (ca, cmd2) = let (km, desc) = case M.lookup cmd2 brevMap of Just ks -> let descOfKM km2 = case M.lookup km2 bcmdMap of Just (_, "", _) -> Nothing Just (_, desc2, _) -> Just (km2, desc2) - Nothing -> assert `failure` km2 + Nothing -> error $ "" `showFailure` km2 in case mapMaybe descOfKM ks of - [] -> assert `failure` (ks, cmd2) + [] -> error $ "" `showFailure` (ks, cmd2) kmdesc3 : _ -> kmdesc3 Nothing -> (key, "(not described:" <+> tshow cmd2 <> ")") in (ca, Left km, desc) @@ -209,7 +209,7 @@ f (ca1, Left km1, _) (ca2, Left km2, _) y = assert (ca1 == ca2) [ (Left [km1], (y, keyM + 3, keyB + keyM + 3)) , (Left [km2], (y, keyB + keyM + 5, 2 * keyB + keyM + 5)) ] - f c d e = assert `failure` (c, d, e) + f c d e = error $ "" `showFailure` (c, d, e) kxs = concat $ zipWith3 f kst1 kst2 [offset + length header..] render (ca1, _, desc1) (_, _, desc2) = fmm (areaDescription ca1) desc1 desc2 @@ -247,7 +247,7 @@ okxsN Binding{..} offset n greyedOut cat header footer = let fmt k h = " " <> T.justifyLeft n ' ' k <+> h coImage :: HumanCmd -> [K.KM] - coImage cmd = M.findWithDefault (assert `failure` cmd) cmd brevMap + coImage cmd = M.findWithDefault (error $ "" `showFailure` cmd) cmd brevMap disp = T.intercalate " or " . map (T.pack . K.showKM) keys :: [(Either [K.KM] SlotChar, (Bool, Text))] keys = [ (Left kms, (greyedOut cmd, fmt (disp kms) desc)) diff --git a/Game/LambdaHack/Client/UI/MonadClientUI.hs b/Game/LambdaHack/Client/UI/MonadClientUI.hs --- a/Game/LambdaHack/Client/UI/MonadClientUI.hs +++ b/Game/LambdaHack/Client/UI/MonadClientUI.hs @@ -153,7 +153,7 @@ getLeaderUI = do cli <- getClient case _sleader cli of - Nothing -> assert `failure` "leader expected but not found" `twith` cli + Nothing -> error $ "leader expected but not found" `showFailure` cli Just leader -> return leader getArenaUI :: MonadClientUI m => m LevelId @@ -383,7 +383,7 @@ else do side <- getsClient sside prefix <- getsClient $ ssavePrefixCli . sdebugCli - let fileName = prefix <.> Save.saveNameCli side + let fileName = prefix <> Save.saveNameCli cops side res <- liftIO $ Save.restoreGame cops fileName let stdRuleset = Kind.stdRuleset corule cfgUIName = rcfgUIName stdRuleset diff --git a/Game/LambdaHack/Client/UI/Msg.hs b/Game/LambdaHack/Client/UI/Msg.hs --- a/Game/LambdaHack/Client/UI/Msg.hs +++ b/Game/LambdaHack/Client/UI/Msg.hs @@ -43,8 +43,8 @@ -- | The type of a single game message. data Msg = Msg - { msgLine :: !AttrLine -- ^ the colours and characters of the message - , msgHist :: !Bool -- ^ whether message should be recorded in history + { msgLine :: AttrLine -- ^ the colours and characters of the message + , msgHist :: Bool -- ^ whether message should be recorded in history } deriving (Show, Eq, Generic) @@ -60,7 +60,7 @@ -- * Report -data RepMsgN = RepMsgN {repMsg :: !Msg, _repN :: !Int} +data RepMsgN = RepMsgN {repMsg :: Msg, _repN :: Int} deriving (Show, Generic) instance Binary RepMsgN @@ -127,7 +127,7 @@ -- * History -- | The history of reports. This is a ring buffer of the given length -data History = History !Time !Report !(RB.RingBuffer UAttrLine) +data History = History Time Report (RB.RingBuffer UAttrLine) deriving (Show, Generic) instance Binary History diff --git a/Game/LambdaHack/Client/UI/Overlay.hs b/Game/LambdaHack/Client/UI/Overlay.hs --- a/Game/LambdaHack/Client/UI/Overlay.hs +++ b/Game/LambdaHack/Client/UI/Overlay.hs @@ -98,8 +98,11 @@ IK.ThrowMod{IK.throwVelocity, IK.throwLinger} = strengthToThrow itemBase speed = speedFromWeight (jweight itemBase) throwVelocity range = rangeFromSpeedAndLinger speed throwLinger - tspeed = "When thrown, it flies with speed of" - <+> tshow (fromSpeed speed `divUp` 10) + tspeed | speed < speedLimp = "When thrown, it drops at once." + | speed < speedWalk = "When thrown, it travels only one meter and drops immediately." + | otherwise = + "When thrown, it flies with speed of" + <+> tshow (fromSpeed speed `div` 10) <> if throwLinger /= 100 then " m/s and range" <+> tshow range <+> "m." else " m/s." @@ -156,15 +159,18 @@ (tshow $ fromIntegral weight / (1000 :: Double), "kg") | otherwise = (tshow weight, "g") onLevel = "on level" <+> tshow (abs $ fromEnum $ jlid itemBase) <> "." + discoFirst = (if unique then "Discovered" else "First seen") + <+> onLevel + whose fid = gname (factionD EM.! fid) sourceDesc = case jfid itemBase of - Just fid -> "First created" - <+> (if fid == side - then "by us" - else "by" <+> gname (factionD EM.! fid)) - <+> onLevel - Nothing -> (if unique then "Discovered" else "First seen") - <+> onLevel + Just fid | jsymbol itemBase `elem` ['+'] -> + "Caused by" <+> (if fid == side then "us" else whose fid) + <> ". First observed" <+> onLevel + Just fid -> + "Coming from" <+> whose fid + <> "." <+> discoFirst + _ -> discoFirst colorSymbol = viewItem itemBase blurb = " " 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 @@ -103,7 +103,7 @@ continueRunDir :: MonadClientUI m => RunParams -> m (Either Text Vector) continueRunDir params = case params of - RunParams{ runMembers = [] } -> assert `failure` params + RunParams{ runMembers = [] } -> error $ "" `showFailure` params RunParams{ runLeader , runMembers = aid : _ , runInitial } -> do @@ -121,7 +121,7 @@ cops@Kind.COps{cotile} <- getsState scops rbody <- getsState $ getActorBody runLeader let rposHere = bpos rbody - rposLast = fromMaybe (assert `failure` (runLeader, rbody)) + rposLast = fromMaybe (error $ "" `showFailure` (runLeader, rbody)) (boldpos rbody) -- Match run-leader dir, because we want runners to keep formation. dir = rposHere `vectorToFrom` rposLast @@ -161,7 +161,7 @@ let lid = blid body lvl <- getLevel lid let posHere = bpos body - posLast = fromMaybe (assert `failure` (aid, body)) (boldpos body) + posLast = fromMaybe (error $ "" `showFailure` (aid, body)) (boldpos body) dirLast = posHere `vectorToFrom` posLast let openableDir dir = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir)) dirEnterable dir = enterableDir cops lvl posHere dir || openableDir dir @@ -192,7 +192,7 @@ posHasItems pos = EM.member pos $ lfloor lvl posThere = posHere `shift` dir actorsThere = posToAidsLvl posThere lvl - let posLast = fromMaybe (assert `failure` (aid, body)) (boldpos body) + let posLast = fromMaybe (error $ "" `showFailure` (aid, body)) (boldpos body) dirLast = posHere `vectorToFrom` posLast -- This is supposed to work on unit vectors --- diagonal, as well as, -- vertical and horizontal. diff --git a/Game/LambdaHack/Client/UI/SessionUI.hs b/Game/LambdaHack/Client/UI/SessionUI.hs --- a/Game/LambdaHack/Client/UI/SessionUI.hs +++ b/Game/LambdaHack/Client/UI/SessionUI.hs @@ -37,39 +37,40 @@ -- Some of it is saved, some is reset when a new playing session starts. -- An important component is a frontend session. data SessionUI = SessionUI - { sxhair :: !Target -- ^ the common xhair - , sactorUI :: !ActorDictUI -- ^ assigned actor UI presentations - , sslots :: !ItemSlots -- ^ map from slots to items - , slastSlot :: !SlotChar -- ^ last used slot - , schanF :: !ChanFrontend -- ^ connection with the frontend - , sbinding :: !Binding -- ^ binding of keys to commands - , sconfig :: !Config - , saimMode :: !(Maybe AimMode) -- ^ aiming mode - , sxhairMoused :: !Bool -- ^ last mouse aiming not vacuus - , sitemSel :: !(Maybe (CStore, ItemId)) -- ^ selected item, if any - , sselected :: !(ES.EnumSet ActorId) - -- ^ the set of currently selected actors - , srunning :: !(Maybe RunParams) - -- ^ parameters of the current run, if any - , _sreport :: !Report -- ^ current messages - , shistory :: !History -- ^ history of messages - , spointer :: !Point -- ^ mouse pointer position - , slastRecord :: !LastRecord -- ^ state of key sequence recording - , slastPlay :: ![K.KM] -- ^ state of key sequence playback - , slastLost :: !(ES.EnumSet ActorId) - -- ^ actors that just got out of sight - , swaitTimes :: !Int -- ^ player just waited this many times - , smarkVision :: !Bool -- ^ mark leader and party FOV - , smarkSmell :: !Bool -- ^ mark smell, if the leader can smell - , smenuIxMap :: !(M.Map String Int) - -- ^ indices of last used menu items - , sdisplayNeeded :: !Bool -- ^ something to display on current level - , skeysHintMode :: !KeysHintMode -- ^ how to show keys hints when no messages - , sstart :: !POSIXTime -- ^ this session start time - , sgstart :: !POSIXTime -- ^ this game start time - , sallTime :: !Time -- ^ clips from start of session to current game start - , snframes :: !Int -- ^ this game current frame count - , sallNframes :: !Int -- ^ frame count from start of session to current game start + { sxhair :: Target -- ^ the common xhair + , sactorUI :: ActorDictUI -- ^ assigned actor UI presentations + , sslots :: ItemSlots -- ^ map from slots to items + , slastSlot :: SlotChar -- ^ last used slot + , slastItemMove :: Maybe (CStore, CStore) -- ^ last item move stores + , schanF :: ChanFrontend -- ^ connection with the frontend + , sbinding :: Binding -- ^ binding of keys to commands + , sconfig :: Config + , saimMode :: Maybe AimMode -- ^ aiming mode + , sxhairMoused :: Bool -- ^ last mouse aiming not vacuus + , sitemSel :: Maybe (CStore, ItemId) -- ^ selected item, if any + , sselected :: ES.EnumSet ActorId + -- ^ the set of currently selected actors + , srunning :: Maybe RunParams + -- ^ parameters of the current run, if any + , _sreport :: Report -- ^ current messages + , shistory :: History -- ^ history of messages + , spointer :: Point -- ^ mouse pointer position + , slastRecord :: LastRecord -- ^ state of key sequence recording + , slastPlay :: [K.KM] -- ^ state of key sequence playback + , slastLost :: ES.EnumSet ActorId + -- ^ actors that just got out of sight + , swaitTimes :: Int -- ^ player just waited this many times + , smarkVision :: Bool -- ^ mark leader and party FOV + , smarkSmell :: Bool -- ^ mark smell, if the leader can smell + , smenuIxMap :: M.Map String Int + -- ^ indices of last used menu items + , sdisplayNeeded :: Bool -- ^ something to display on current level + , skeysHintMode :: KeysHintMode -- ^ how to show keys hints when no messages + , sstart :: POSIXTime -- ^ this session start time + , sgstart :: POSIXTime -- ^ this game start time + , sallTime :: Time -- ^ clips from start of session to current game start + , snframes :: Int -- ^ this game current frame count + , sallNframes :: Int -- ^ frame count from start of session to current game start } -- | Current aiming mode of a client. @@ -78,12 +79,12 @@ -- | Parameters of the current run. data RunParams = RunParams - { runLeader :: !ActorId -- ^ the original leader from run start - , runMembers :: ![ActorId] -- ^ the list of actors that take part - , runInitial :: !Bool -- ^ initial run continuation by any - -- run participant, including run leader - , runStopMsg :: !(Maybe Text) -- ^ message with the next stop reason - , runWaiting :: !Int -- ^ waiting for others to move out of the way + { runLeader :: ActorId -- ^ the original leader from run start + , runMembers :: [ActorId] -- ^ the list of actors that take part + , runInitial :: Bool -- ^ initial run continuation by any + -- run participant, including run leader + , runStopMsg :: Maybe Text -- ^ message with the next stop reason + , runWaiting :: Int -- ^ waiting for others to move out of the way } deriving (Show) @@ -106,8 +107,9 @@ , sactorUI = EM.empty , sslots = ItemSlots EM.empty EM.empty , slastSlot = SlotChar 0 'Z' + , slastItemMove = Nothing , schanF = ChanFrontend $ const $ - assert `failure` ("emptySessionUI: ChanFrontend " :: String) + error $ "emptySessionUI: ChanFrontend" `showFailure` () , sbinding = Binding M.empty [] M.empty , sconfig , saimMode = Nothing @@ -142,7 +144,7 @@ getActorUI :: ActorId -> SessionUI -> ActorUI getActorUI aid sess = - EM.findWithDefault (assert `failure` (aid, sactorUI sess)) aid + EM.findWithDefault (error $ "" `showFailure` (aid, sactorUI sess)) aid $ sactorUI sess instance Binary SessionUI where @@ -176,8 +178,9 @@ smarkVision <- get smarkSmell <- get sdisplayNeeded <- get - let schanF = ChanFrontend $ const $ - assert `failure` ("Binary: ChanFrontend" :: String) + let slastItemMove = Nothing + schanF = ChanFrontend $ const $ + error $ "Binary: ChanFrontend" `showFailure` () sbinding = Binding M.empty [] M.empty sxhairMoused = True spointer = originPoint diff --git a/Game/LambdaHack/Client/UI/Slideshow.hs b/Game/LambdaHack/Client/UI/Slideshow.hs --- a/Game/LambdaHack/Client/UI/Slideshow.hs +++ b/Game/LambdaHack/Client/UI/Slideshow.hs @@ -37,7 +37,7 @@ toSlideshow :: [OKX] -> Slideshow toSlideshow okxs = Slideshow $ addFooters False okxs where - addFooters _ [] = assert `failure` okxs + addFooters _ [] = error $ "" `showFailure` okxs addFooters _ [(als, [])] = [( als ++ [stringToAL endMsg] , [(Left [K.safeSpaceKM], (length als, 0, 15))] )] diff --git a/Game/LambdaHack/Client/UI/SlideshowM.hs b/Game/LambdaHack/Client/UI/SlideshowM.hs --- a/Game/LambdaHack/Client/UI/SlideshowM.hs +++ b/Game/LambdaHack/Client/UI/SlideshowM.hs @@ -87,7 +87,7 @@ => ColorMode -> [K.KM] -> Slideshow -> m K.KM getConfirms dm extraKeys slides = do (ekm, _) <- displayChoiceScreen dm False 0 slides extraKeys - return $! either id (assert `failure` ekm) ekm + return $! either id (error $ "" `showFailure` ekm) ekm -- This is the only source of menus and so, effectively, UI modes. displayChoiceScreen :: forall m . MonadClientUI m @@ -122,7 +122,7 @@ maxIx = length (concatMap snd frs) - 1 page :: Int -> m (Either K.KM SlotChar, Int) page pointer = assert (pointer >= 0) $ case findKYX pointer frs of - Nothing -> assert `failure` "no menu keys" `twith` frs + Nothing -> error $ "no menu keys" `showFailure` frs Just ((ov, kyxs), (ekm, (y, x1, x2)), ixOnPage) -> do let highableAttrs = [Color.defAttr, Color.defAttr {Color.fg = Color.BrBlack}] @@ -145,7 +145,7 @@ case K.key ikm of K.Return | ekm /= Left [K.returnKM] -> case ekm of Left (km : _) -> interpretKey km - Left [] -> assert `failure` ikm + Left [] -> error $ "" `showFailure` ikm Right c -> return (Right c, pointer) K.LeftButtonRelease -> do Point{..} <- getsSession spointer @@ -157,8 +157,11 @@ then return (Left K.spaceKM, pointer) else ignoreKey Just (ckm, _) -> case ckm of - Left (km : _) -> interpretKey km - Left [] -> assert `failure` ikm + Left (km : _) -> + if K.key km == K.Return && km `elem` keys + then return (Left km, pointer) + else interpretKey km + Left [] -> error $ "" `showFailure` ikm Right c -> return (Right c, pointer) K.RightButtonRelease -> if | ikm `elem` keys -> return (Left ikm, pointer) @@ -189,7 +192,7 @@ _ | K.key ikm `elem` [K.PgDn, K.WheelSouth] -> page (min maxIx (pointer + pageLen - ixOnPage)) K.Space -> ignoreKey - _ -> assert `failure` "unknown key" `twith` ikm + _ -> error $ "unknown key" `showFailure` ikm pkm <- promptGetKey dm ov1 sfBlank legalKeys interpretKey pkm (km, pointer) <- if null frs 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 @@ -38,34 +38,34 @@ -- to the original value from @ActorKind@ over time. E.g., HP. data Actor = Actor { -- The trunk of the actor's body (present also in @borgan@ or @beqp@) - btrunk :: !ItemId + btrunk :: ItemId -- Resources - , bhp :: !Int64 -- ^ current hit points * 1M - , bhpDelta :: !ResDelta -- ^ HP delta this turn * 1M - , bcalm :: !Int64 -- ^ current calm * 1M - , bcalmDelta :: !ResDelta -- ^ calm delta this turn * 1M + , bhp :: Int64 -- ^ current hit points * 1M + , bhpDelta :: ResDelta -- ^ HP delta this turn * 1M + , bcalm :: Int64 -- ^ current calm * 1M + , bcalmDelta :: ResDelta -- ^ calm delta this turn * 1M -- Location - , bpos :: !Point -- ^ current position - , boldpos :: !(Maybe Point) - -- ^ previous position, if any - , blid :: !LevelId -- ^ current level - , bfid :: !FactionId -- ^ faction the actor currently belongs to - , btrajectory :: !(Maybe ([Vector], Speed)) - -- ^ trajectory the actor must - -- travel and his travel speed + , bpos :: Point -- ^ current position + , boldpos :: (Maybe Point) + -- ^ previous position, if any + , blid :: LevelId -- ^ current level + , bfid :: FactionId -- ^ faction the actor currently belongs to + , btrajectory :: (Maybe ([Vector], Speed)) + -- ^ trajectory the actor must + -- travel and his travel speed -- Items - , borgan :: !ItemBag -- ^ organs - , beqp :: !ItemBag -- ^ personal equipment - , binv :: !ItemBag -- ^ personal inventory pack - , bweapon :: !Int -- ^ number of weapons among eqp and organs + , borgan :: ItemBag -- ^ organs + , beqp :: ItemBag -- ^ personal equipment + , binv :: ItemBag -- ^ personal inventory pack + , bweapon :: Int -- ^ number of weapons among eqp and organs -- Assorted - , bwait :: !Bool -- ^ is the actor waiting right now? - , bproj :: !Bool -- ^ is a projectile? (shorthand only, - -- this can be deduced from btrunk) + , bwait :: Bool -- ^ is the actor waiting right now? + , bproj :: Bool -- ^ is a projectile? (shorthand only, + -- this can be deduced from btrunk) } deriving (Show, Eq, Generic) @@ -73,8 +73,8 @@ -- The resource changes in the tuple are negative and positive, respectively. data ResDelta = ResDelta - { resCurrentTurn :: !(Int64, Int64) -- ^ resource change this player turn - , resPreviousTurn :: !(Int64, Int64) -- ^ resource change last player turn + { resCurrentTurn :: (Int64, Int64) -- ^ resource change this player turn + , resPreviousTurn :: (Int64, Int64) -- ^ resource change last player turn } deriving (Show, Eq, Generic) diff --git a/Game/LambdaHack/Common/ActorState.hs b/Game/LambdaHack/Common/ActorState.hs --- a/Game/LambdaHack/Common/ActorState.hs +++ b/Game/LambdaHack/Common/ActorState.hs @@ -74,7 +74,7 @@ getItemBody :: ItemId -> State -> Item getItemBody iid s = - let assFail = assert `failure` "item body not found" `twith` (iid, s) + let assFail = error $ "item body not found" `showFailure` (iid, s) in EM.findWithDefault assFail iid $ sitemD s bagAssocs :: State -> ItemBag -> [(ItemId, Item)] @@ -184,7 +184,7 @@ CEmbed lid p -> getEmbedBag lid p s CActor aid cstore -> let b = getActorBody aid s in getBodyStoreBag b cstore s - CTrunk{} -> assert `failure` c + CTrunk{} -> error $ "" `showFailure` c getFloorBag :: LevelId -> Point -> State -> ItemBag getFloorBag lid p s = EM.findWithDefault EM.empty p @@ -315,13 +315,13 @@ CFloor{} -> CGround CEmbed{} -> CGround CActor _ cstore -> cstore - CTrunk{} -> assert `failure` c + CTrunk{} -> error $ "" `showFailure` c aidFromC :: Container -> Maybe ActorId aidFromC CFloor{} = Nothing aidFromC CEmbed{} = Nothing aidFromC (CActor aid _) = Just aid -aidFromC c@CTrunk{} = assert `failure` c +aidFromC c@CTrunk{} = error $ "" `showFailure` c -- | Determine the dungeon level of the container. If the item is in a shared -- stash, the level depends on which actor asks. @@ -329,13 +329,13 @@ lidFromC (CFloor lid _) _ = lid lidFromC (CEmbed lid _) _ = lid lidFromC (CActor aid _) s = blid $ getActorBody aid s -lidFromC c@CTrunk{} _ = assert `failure` c +lidFromC c@CTrunk{} _ = error $ "" `showFailure` c posFromC :: Container -> State -> Point posFromC (CFloor _ pos) _ = pos posFromC (CEmbed _ pos) _ = pos posFromC (CActor aid _) s = bpos $ getActorBody aid s -posFromC c@CTrunk{} _ = assert `failure` c +posFromC c@CTrunk{} _ = error $ "" `showFailure` c isEscape :: LevelId -> Point -> State -> Bool isEscape lid p s = diff --git a/Game/LambdaHack/Common/ClientOptions.hs b/Game/LambdaHack/Common/ClientOptions.hs --- a/Game/LambdaHack/Common/ClientOptions.hs +++ b/Game/LambdaHack/Common/ClientOptions.hs @@ -12,46 +12,46 @@ import GHC.Generics (Generic) data DebugModeCli = DebugModeCli - { sgtkFontFamily :: !(Maybe Text) + { sgtkFontFamily :: Maybe Text -- ^ Font family to use for the GTK main game window. - , sdlFontFile :: !(Maybe Text) + , sdlFontFile :: Maybe Text -- ^ Font file to use for the SDL2 main game window. - , sdlTtfSizeAdd :: !(Maybe Int) + , sdlTtfSizeAdd :: Maybe Int -- ^ Pixels to add to map cells on top of scalable font max glyph height. - , sdlFonSizeAdd :: !(Maybe Int) + , sdlFonSizeAdd :: Maybe Int -- ^ Pixels to add to map cells on top of .fon font max glyph height. - , sfontSize :: !(Maybe Int) + , sfontSize :: Maybe Int -- ^ Font size to use for the main game window. - , scolorIsBold :: !(Maybe Bool) + , scolorIsBold :: Maybe Bool -- ^ Whether to use bold attribute for colorful characters. - , smaxFps :: !(Maybe Int) + , smaxFps :: Maybe Int -- ^ Maximal frames per second. -- This is better low and fixed, to avoid jerkiness and delays -- that tell the player there are many intelligent enemies on the level. -- That's better than scaling AI sofistication down based -- on the FPS setting and machine speed. - , sdisableAutoYes :: !Bool + , sdisableAutoYes :: Bool -- ^ Never auto-answer all prompts, even if under AI control. - , snoAnim :: !(Maybe Bool) + , snoAnim :: Maybe Bool -- ^ Don't show any animations. - , snewGameCli :: !Bool + , snewGameCli :: Bool -- ^ Start a new game, overwriting the save file. - , sbenchmark :: !Bool + , sbenchmark :: Bool -- ^ Don't create directories and files and show time stats. - , stitle :: !(Maybe Text) - , sfontDir :: !(Maybe FilePath) - , ssavePrefixCli :: !String + , stitle :: Maybe Text + , sfontDir :: Maybe FilePath + , ssavePrefixCli :: String -- ^ Prefix of the save game file name. - , sfrontendTeletype :: !Bool + , sfrontendTeletype :: Bool -- ^ Whether to use the stdout/stdin frontend. - , sfrontendNull :: !Bool + , sfrontendNull :: Bool -- ^ Whether to use null (no input/output) frontend. - , sfrontendLazy :: !Bool + , sfrontendLazy :: Bool -- ^ Whether to use lazy (output not even calculated) frontend. - , sdbgMsgCli :: !Bool + , sdbgMsgCli :: Bool -- ^ Show clients' internal debug messages. - , sstopAfterSeconds :: !(Maybe Int) - , sstopAfterFrames :: !(Maybe Int) + , sstopAfterSeconds :: Maybe Int + , sstopAfterFrames :: Maybe Int } deriving (Show, Eq, Generic) @@ -72,7 +72,7 @@ , sbenchmark = False , stitle = Nothing , sfontDir = Nothing - , ssavePrefixCli = "save" + , ssavePrefixCli = "" , sfrontendTeletype = False , sfrontendNull = False , sfrontendLazy = False diff --git a/Game/LambdaHack/Common/Color.hs b/Game/LambdaHack/Common/Color.hs --- a/Game/LambdaHack/Common/Color.hs +++ b/Game/LambdaHack/Common/Color.hs @@ -65,6 +65,8 @@ | HighlightBlue | HighlightYellow | HighlightGrey + | HighlightWhite + | HighlightMagenta deriving (Show, Eq, Ord, Enum, Bounded, Generic) instance Binary Highlight where @@ -75,8 +77,8 @@ -- | Text attributes: foreground and backgroud colors. data Attr = Attr - { fg :: !Color -- ^ foreground colour - , bg :: !Highlight -- ^ backgroud highlight + { fg :: Color -- ^ foreground colour + , bg :: Highlight -- ^ backgroud highlight } deriving (Show, Eq, Ord) @@ -90,8 +92,8 @@ defAttr = Attr defFG HighlightNone data AttrChar = AttrChar - { acAttr :: !Attr - , acChar :: !Char + { acAttr :: Attr + , acChar :: Char } deriving (Show, Eq, Ord) diff --git a/Game/LambdaHack/Common/ContentDef.hs b/Game/LambdaHack/Common/ContentDef.hs --- a/Game/LambdaHack/Common/ContentDef.hs +++ b/Game/LambdaHack/Common/ContentDef.hs @@ -21,14 +21,14 @@ -- | The general type of a particular game content, e.g., item kinds. data ContentDef a = ContentDef - { getSymbol :: !(a -> Char) -- ^ symbol, e.g., to print on the map - , getName :: !(a -> Text) -- ^ name, e.g., to show to the player - , getFreq :: !(a -> Freqs a) -- ^ frequency within groups - , validateSingle :: !(a -> [Text]) + { getSymbol :: a -> Char -- ^ symbol, e.g., to print on the map + , getName :: a -> Text -- ^ name, e.g., to show to the player + , getFreq :: a -> Freqs a -- ^ frequency within groups + , validateSingle :: a -> [Text] -- ^ validate a content item and list all offences - , validateAll :: !([a] -> [Text]) + , validateAll :: [a] -> [Text] -- ^ validate the whole defined content of this type and list all offences - , content :: !(V.Vector a) -- ^ all content of this type + , content :: V.Vector a -- ^ all content of this type } contentFromList :: [a] -> V.Vector a diff --git a/Game/LambdaHack/Common/Dice.hs b/Game/LambdaHack/Common/Dice.hs --- a/Game/LambdaHack/Common/Dice.hs +++ b/Game/LambdaHack/Common/Dice.hs @@ -1,7 +1,5 @@ {-# LANGUAGE DeriveGeneric, FlexibleInstances, TypeSynonymInstances #-} -#if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -Wno-orphans #-} -#endif -- | Representation of dice for parameters scaled with current level depth. module Game.LambdaHack.Common.Dice ( -- * Frequency distribution for casting dice scaled with level depth @@ -101,9 +99,9 @@ -- Dice like 100d100 lead to enormous lists, so we help a bit -- by keeping simple dice nonstrict below. data Dice = Dice - { diceConst :: SimpleDice - , diceLevel :: SimpleDice - , diceMult :: !Int + { diceConst :: ~SimpleDice + , diceLevel :: ~SimpleDice + , diceMult :: Int } deriving (Eq, Ord, Generic) @@ -130,7 +128,7 @@ Dice (scaleFreq ds1 dc1 + scaleFreq ds2 dc2) (scaleFreq ds1 dl1 + scaleFreq ds2 dl2) (if ds1 == 1 && ds2 == 1 then 1 else - assert `failure` (ds1, ds2, "|*| must be at top level" :: Text)) + error $ "|*| must be at top level" `showFailure` (ds1, ds2)) (Dice dc1 dl1 ds1) * (Dice dc2 dl2 ds2) = -- Hacky, but necessary (unless we forgo general multiplication and -- stick to multiplications by a scalar from the left and from the right). @@ -149,12 +147,12 @@ (scaleFreq ds1 dc1 * scaleFreq ds2 dl2 + scaleFreq ds1 dl1 * scaleFreq ds2 dc2) (if ds1 == 1 && ds2 == 1 then 1 else - assert `failure` (ds1, ds2, "|*| must be at top level" :: Text)) + error $ "|*| must be at top level" `showFailure` (ds1, ds2)) (Dice dc1 dl1 ds1) - (Dice dc2 dl2 ds2) = Dice (scaleFreq ds1 dc1 - scaleFreq ds2 dc2) (scaleFreq ds1 dl1 - scaleFreq ds2 dl2) (if ds1 == 1 && ds2 == 1 then 1 else - assert `failure` (ds1, ds2, "|*| must be at top level" :: Text)) + error $ "|*| must be at top level" `showFailure` (ds1, ds2)) negate = affectBothDice negate abs = affectBothDice abs signum = affectBothDice signum @@ -213,7 +211,7 @@ -- | Dice for rolling a pair of integer parameters pertaining to, -- respectively, the X and Y cartesian 2D coordinates. -data DiceXY = DiceXY !Dice !Dice +data DiceXY = DiceXY Dice Dice deriving (Show, Eq, Ord, Generic) instance Hashable DiceXY diff --git a/Game/LambdaHack/Common/Faction.hs b/Game/LambdaHack/Common/Faction.hs --- a/Game/LambdaHack/Common/Faction.hs +++ b/Game/LambdaHack/Common/Faction.hs @@ -39,18 +39,18 @@ type FactionDict = EM.EnumMap FactionId Faction data Faction = Faction - { gname :: !Text -- ^ individual name - , gcolor :: !Color.Color -- ^ color of actors or their frames - , gplayer :: !Player -- ^ the player spec for this faction - , ginitial :: ![(Int, Int, GroupName ItemKind)] -- ^ initial actors - , gdipl :: !Dipl -- ^ diplomatic mode - , gquit :: !(Maybe Status) -- ^ cause of game end/exit - , _gleader :: !(Maybe ActorId) -- ^ the leader of the faction; don't use - -- in place of _sleader on clients! - , gsha :: !ItemBag -- ^ faction's shared inventory - , gvictims :: !(EM.EnumMap (Kind.Id ItemKind) Int) -- ^ members killed - , gvictimsD :: !(EM.EnumMap (Kind.Id ModeKind) - (IM.IntMap (EM.EnumMap (Kind.Id ItemKind) Int))) + { gname :: Text -- ^ individual name + , gcolor :: Color.Color -- ^ color of actors or their frames + , gplayer :: Player -- ^ the player spec for this faction + , ginitial :: [(Int, Int, GroupName ItemKind)] -- ^ initial actors + , gdipl :: Dipl -- ^ diplomatic mode + , gquit :: Maybe Status -- ^ cause of game end/exit + , _gleader :: Maybe ActorId -- ^ the leader of the faction; don't use + -- in place of _sleader on clients + , gsha :: ItemBag -- ^ faction's shared inventory + , gvictims :: EM.EnumMap (Kind.Id ItemKind) Int -- ^ members killed + , gvictimsD :: EM.EnumMap (Kind.Id ModeKind) + (IM.IntMap (EM.EnumMap (Kind.Id ItemKind) Int)) -- ^ members killed in the past, by game mode and difficulty level } deriving (Show, Eq, Ord, Generic) @@ -71,10 +71,10 @@ -- | Current game status. data Status = Status - { stOutcome :: !Outcome -- ^ current game outcome - , stDepth :: !Int -- ^ depth of the final encounter - , stNewGame :: !(Maybe (GroupName ModeKind)) - -- ^ new game group to start, if any + { stOutcome :: Outcome -- ^ current game outcome + , stDepth :: Int -- ^ depth of the final encounter + , stNewGame :: Maybe (GroupName ModeKind) + -- ^ new game group to start, if any } deriving (Show, Eq, Ord, Generic) @@ -82,21 +82,21 @@ -- | The type of na actor target. data Target = - TEnemy !ActorId !Bool + TEnemy ActorId Bool -- ^ target an actor; cycle only trough seen foes, unless the flag is set - | TPoint !TGoal !LevelId !Point -- ^ target a concrete spot - | TVector !Vector -- ^ target position relative to actor + | TPoint TGoal LevelId Point -- ^ target a concrete spot + | TVector Vector -- ^ target position relative to actor deriving (Show, Eq, Ord, Generic) instance Binary Target data TGoal = - TEnemyPos !ActorId !Bool + TEnemyPos ActorId Bool -- ^ last seen position of the targeted actor - | TEmbed !ItemBag !Point + | TEmbed ItemBag Point -- ^ in @TPoint (TEmbed bag p) _ q@ usually @bag@ is embbedded in @p@ -- and @q@ is an adjacent open tile - | TItem !ItemBag + | TItem ItemBag | TSmell | TUnknown | TKnown @@ -106,9 +106,9 @@ instance Binary TGoal data Challenge = Challenge - { cdiff :: !Int -- ^ game difficulty level (HP bonus or malus) - , cwolf :: !Bool -- ^ lone wolf challenge (only one starting character) - , cfish :: !Bool -- ^ cold fish challenge (no healing from enemies) + { cdiff :: Int -- ^ game difficulty level (HP bonus or malus) + , cwolf :: Bool -- ^ lone wolf challenge (only one starting character) + , cfish :: Bool -- ^ cold fish challenge (no healing from enemies) } deriving (Show, Eq, Ord, Generic) diff --git a/Game/LambdaHack/Common/Flavour.hs b/Game/LambdaHack/Common/Flavour.hs --- a/Game/LambdaHack/Common/Flavour.hs +++ b/Game/LambdaHack/Common/Flavour.hs @@ -30,8 +30,8 @@ -- | The type of item flavours. data Flavour = Flavour - { fancyName :: !FancyName -- ^ how fancy should the colour description be - , baseColor :: !Color -- ^ the colour of the flavour + { fancyName :: FancyName -- ^ how fancy should the colour description be + , baseColor :: Color -- ^ the colour of the flavour } deriving (Show, Eq, Ord, Generic) diff --git a/Game/LambdaHack/Common/Frequency.hs b/Game/LambdaHack/Common/Frequency.hs --- a/Game/LambdaHack/Common/Frequency.hs +++ b/Game/LambdaHack/Common/Frequency.hs @@ -32,9 +32,9 @@ -- the expected equalities, unless they do some kind of normalization -- (see 'Dice'). data Frequency a = Frequency - { runFrequency :: ![(Int, a)] -- ^ give acces to raw frequency values - , nameFrequency :: Text -- ^ short description for debug, etc.; - -- keep it lazy, because it's rarely used + { runFrequency :: [(Int, a)] -- ^ give acces to raw frequency values + , nameFrequency :: ~Text -- ^ short description for debug, etc.; + -- keep it lazy, because it's rarely used } deriving (Show, Eq, Ord, Foldable, Traversable, Generic) @@ -89,7 +89,7 @@ -- by a positive integer constant. scaleFreq :: Show a => Int -> Frequency a -> Frequency a scaleFreq n (Frequency xs name) = - assert (n > 0 `blame` "non-positive frequency scale" `twith` (name, n, xs)) $ + assert (n > 0 `blame` "non-positive frequency scale" `swith` (name, n, xs)) $ Frequency (map (first (* n)) xs) name -- | Change the description of the frequency. @@ -120,7 +120,7 @@ -- it in the other code higher up, which would equate 1d0 with 1d1. meanFreq :: Frequency Int -> Int meanFreq fr@(Frequency xs _) = case xs of - [] -> assert `failure` fr + [] -> error $ "empty frequency" `showFailure` fr _ -> let sumX = sum [ p * x | (p, x) <- xs ] sumP = sum $ map fst xs in sumX `divUp` sumP diff --git a/Game/LambdaHack/Common/HighScore.hs b/Game/LambdaHack/Common/HighScore.hs --- a/Game/LambdaHack/Common/HighScore.hs +++ b/Game/LambdaHack/Common/HighScore.hs @@ -32,14 +32,14 @@ -- | A single score record. Records are ordered in the highscore table, -- from the best to the worst, in lexicographic ordering wrt the fields below. data ScoreRecord = ScoreRecord - { points :: !Int -- ^ the score - , negTime :: !Time -- ^ game time spent (negated, so less better) - , date :: !POSIXTime -- ^ date of the last game interruption - , status :: !Status -- ^ reason of the game interruption - , challenge :: !Challenge -- ^ challenge setup of the game - , gplayerName :: !Text -- ^ name of the faction's gplayer - , ourVictims :: !(EM.EnumMap (Kind.Id ItemKind) Int) -- ^ allies lost - , theirVictims :: !(EM.EnumMap (Kind.Id ItemKind) Int) -- ^ foes killed + { points :: Int -- ^ the score + , negTime :: Time -- ^ game time spent (negated, so less better) + , date :: POSIXTime -- ^ date of the last game interruption + , status :: Status -- ^ reason of the game interruption + , challenge :: Challenge -- ^ challenge setup of the game + , gplayerName :: Text -- ^ name of the faction's gplayer + , ourVictims :: EM.EnumMap (Kind.Id ItemKind) Int -- ^ allies lost + , theirVictims :: EM.EnumMap (Kind.Id ItemKind) Int -- ^ foes killed } deriving (Eq, Ord, Show, Generic) @@ -88,7 +88,7 @@ getRecord :: Int -> ScoreTable -> ScoreRecord getRecord pos (ScoreTable table) = - fromMaybe (assert `failure` (pos, table)) + fromMaybe (error $ "" `showFailure` (pos, table)) $ listToMaybe $ drop (pred pos) table -- | Empty score table 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 @@ -49,8 +49,8 @@ deriving (Show, Eq, Ord, Enum, Ix.Ix, Hashable, Binary) data KindMean = KindMean - { kmKind :: !(Kind.Id IK.ItemKind) - , kmMean :: !AspectRecord + { kmKind :: Kind.Id IK.ItemKind + , kmMean :: AspectRecord } deriving (Show, Eq, Generic) @@ -68,11 +68,11 @@ -- 4. the (usually negative) benefit of hitting a foe in meleeing with the item -- 5. the (usually negative) benefit of flinging an item at an opponent data Benefit = Benefit - { benInEqp :: Bool - , benPickup :: Int - , benApply :: Int - , benMelee :: Int - , benFling :: Int + { benInEqp :: ~Bool + , benPickup :: ~Int + , benApply :: ~Int + , benMelee :: ~Int + , benFling :: ~Int } deriving (Show, Generic) @@ -87,19 +87,19 @@ deriving (Show, Eq, Ord, Enum, Hashable, Binary) data AspectRecord = AspectRecord - { aTimeout :: !Int - , aHurtMelee :: !Int - , aArmorMelee :: !Int - , aArmorRanged :: !Int - , aMaxHP :: !Int - , aMaxCalm :: !Int - , aSpeed :: !Int - , aSight :: !Int - , aSmell :: !Int - , aShine :: !Int - , aNocto :: !Int - , aAggression :: !Int - , aSkills :: !Ability.Skills + { aTimeout :: Int + , aHurtMelee :: Int + , aArmorMelee :: Int + , aArmorRanged :: Int + , aMaxHP :: Int + , aMaxCalm :: Int + , aSpeed :: Int + , aSight :: Int + , aSmell :: Int + , aShine :: Int + , aNocto :: Int + , aAggression :: Int + , aSkills :: Ability.Skills } deriving (Show, Eq, Ord, Generic) @@ -151,19 +151,19 @@ -- Tiny speedup from making fields non-strict (1%, a bit more GC, less alloc). -- The fields of @KindMean@ also need to be non-strict then, otherwise slowdown. data ItemDisco = ItemDisco - { itemKindId :: !(Kind.Id IK.ItemKind) - , itemKind :: !IK.ItemKind - , itemAspectMean :: !AspectRecord - , itemAspect :: !(Maybe AspectRecord) + { itemKindId :: Kind.Id IK.ItemKind + , itemKind :: IK.ItemKind + , itemAspectMean :: AspectRecord + , itemAspect :: Maybe AspectRecord } deriving Show -- No speedup from making fields non-strict. data ItemFull = ItemFull - { itemBase :: !Item - , itemK :: !Int - , itemTimer :: !ItemTimer - , itemDisco :: !(Maybe ItemDisco) + { itemBase :: Item + , itemK :: Int + , itemTimer :: ItemTimer + , itemDisco :: Maybe ItemDisco } deriving Show @@ -189,16 +189,16 @@ -- and draw an unidentified item. Full information about item is available -- through the @jkindIx@ index as soon as the item is identified. data Item = Item - { jkindIx :: !ItemKindIx -- ^ index pointing to the kind of the item - , jlid :: !LevelId -- ^ lowest level the item was created at - , jfid :: !(Maybe FactionId) - -- ^ the faction that created the item, if any - , jsymbol :: !Char -- ^ map symbol - , jname :: !Text -- ^ generic name - , jflavour :: !Flavour -- ^ flavour - , jfeature :: ![IK.Feature] -- ^ public properties - , jweight :: !Int -- ^ weight in grams, obvious enough - , jdamage :: !Dice.Dice -- ^ impact damage of this particular weapon + { jkindIx :: ItemKindIx -- ^ index pointing to the kind of the item + , jlid :: LevelId -- ^ lowest level the item was created at + , jfid :: Maybe FactionId + -- ^ the faction that created the item, if any + , jsymbol :: Char -- ^ map symbol + , jname :: Text -- ^ generic name + , jflavour :: Flavour -- ^ flavour + , jfeature :: [IK.Feature] -- ^ public properties + , jweight :: Int -- ^ weight in grams, obvious enough + , jdamage :: Dice.Dice -- ^ impact damage of this particular weapon } deriving (Show, Eq, Generic) @@ -207,8 +207,8 @@ instance Binary Item data ItemSource = - ItemSourceLevel !LevelId - | ItemSourceFaction !FactionId + ItemSourceLevel LevelId + | ItemSourceFaction FactionId deriving (Show, Eq, Generic) instance Hashable ItemSource diff --git a/Game/LambdaHack/Common/ItemStrongest.hs b/Game/LambdaHack/Common/ItemStrongest.hs --- a/Game/LambdaHack/Common/ItemStrongest.hs +++ b/Game/LambdaHack/Common/ItemStrongest.hs @@ -60,7 +60,7 @@ in case strengthEffect p item of [] -> Nothing [x] -> Just x - xs -> assert `failure` (xs, item) + xs -> error $ "" `showFailure` (xs, item) strengthToThrow :: Item -> ThrowMod strengthToThrow item = @@ -69,13 +69,13 @@ in case concatMap p (jfeature item) of [] -> ThrowMod 100 100 [x] -> x - xs -> assert `failure` (xs, item) + xs -> error $ "" `showFailure` (xs, item) computeTrajectory :: Int -> Int -> Int -> [Point] -> ([Vector], (Speed, Int)) computeTrajectory weight throwVelocity throwLinger path = let speed = speedFromWeight weight throwVelocity trange = rangeFromSpeedAndLinger speed throwLinger - btrajectory = pathToTrajectory $ take trange path + btrajectory = pathToTrajectory $ take (trange + 1) path in (btrajectory, (speed, trange)) itemTrajectory :: Item -> [Point] -> ([Vector], (Speed, Int)) @@ -100,7 +100,7 @@ EqpSlotAddSpeed -> aSpeed EqpSlotAddSight -> aSight EqpSlotLightSource -> aShine - EqpSlotWeapon -> assert `failure` ar + EqpSlotWeapon -> error $ "" `showFailure` ar EqpSlotMiscAbility -> EM.findWithDefault 0 Ability.AbWait aSkills + EM.findWithDefault 0 Ability.AbMoveItem aSkills @@ -126,7 +126,8 @@ in length it1 < itemK damageUsefulness :: Item -> Int -damageUsefulness item = min 1000 (10 * Dice.meanDice (jdamage item)) +damageUsefulness item = let v = min 1000 (10 * Dice.meanDice (jdamage item)) + in assert (v >= 0) v strongestMelee :: Maybe DiscoveryBenefit -> Time -> [(ItemId, ItemFull)] -> [(Int, (ItemId, ItemFull))] diff --git a/Game/LambdaHack/Common/JSFile.hs b/Game/LambdaHack/Common/JSFile.hs --- a/Game/LambdaHack/Common/JSFile.hs +++ b/Game/LambdaHack/Common/JSFile.hs @@ -70,7 +70,7 @@ storage <- getLocalStorage win mitem <- getItem storage path case mitem of - Nothing -> assert `failure` "Fatal error: no file " ++ path + Nothing -> fail $ "Fatal error: no file " ++ path Just item -> return item renameFile :: FilePath -> FilePath -> IO () @@ -79,7 +79,7 @@ storage <- getLocalStorage win mitem <- getItem storage path case mitem :: Maybe String of - Nothing -> assert `failure` "Fatal error: no file " ++ path + Nothing -> fail $ "Fatal error: no file " ++ path Just item -> do setItem storage path2 item -- overwrites removeItem storage path diff --git a/Game/LambdaHack/Common/Kind.hs b/Game/LambdaHack/Common/Kind.hs --- a/Game/LambdaHack/Common/Kind.hs +++ b/Game/LambdaHack/Common/Kind.hs @@ -45,19 +45,19 @@ allOffences = validateAll $ V.toList content in assert (allB correct $ V.toList content) $ assert (null singleOffenders `blame` "some content items not valid" - `twith` singleOffenders) $ + `swith` singleOffenders) $ assert (null allOffences `blame` "the content set not valid" - `twith` allOffences) + `swith` allOffences) -- By this point 'content' can be GCd. Ops { okind = \ !i -> content V.! fromEnum i , ouniqGroup = \ !cgroup -> - let freq = let assFail = assert `failure` "no unique group" - `twith` (cgroup, kindFreq) + let freq = let assFail = error $ "no unique group" + `showFailure` (cgroup, kindFreq) in M.findWithDefault assFail cgroup kindFreq in case freq of [(n, (i, _))] | n > 0 -> i - l -> assert `failure` "not unique" `twith` (l, cgroup, kindFreq) + l -> error $ "not unique" `showFailure` (l, cgroup, kindFreq) , opick = \ !cgroup !p -> case M.lookup cgroup kindFreq of Just freqRaw -> @@ -81,21 +81,22 @@ , ofoldlGroup' = \cgroup f z -> case M.lookup cgroup kindFreq of Just freq -> foldl' (\acc (p, (i, a)) -> f acc p i a) z freq - _ -> assert `failure` "no group '" <> tshow cgroup - <> "' among content that has groups" - <+> tshow (M.keys kindFreq) + _ -> error $ "no group '" ++ show cgroup + ++ "' among content that has groups " + ++ show (M.keys kindFreq) + `showFailure` () , olength = V.length content } -- | Operations for all content types, gathered together. data COps = COps - { cocave :: !(Ops CaveKind) -- server only - , coitem :: !(Ops ItemKind) - , comode :: !(Ops ModeKind) -- server only - , coplace :: !(Ops PlaceKind) -- server only, so far - , corule :: !(Ops RuleKind) - , cotile :: !(Ops TileKind) - , coTileSpeedup :: !TileSpeedup + { cocave :: Ops CaveKind -- server only + , coitem :: Ops ItemKind + , comode :: Ops ModeKind -- server only + , coplace :: Ops PlaceKind -- server only, so far + , corule :: Ops RuleKind + , cotile :: Ops TileKind + , coTileSpeedup :: TileSpeedup } instance Show COps where diff --git a/Game/LambdaHack/Common/KindOps.hs b/Game/LambdaHack/Common/KindOps.hs --- a/Game/LambdaHack/Common/KindOps.hs +++ b/Game/LambdaHack/Common/KindOps.hs @@ -19,19 +19,19 @@ -- | Content operations for the content of type @a@. data Ops a = Ops - { okind :: !(Id a -> a) -- ^ content element at given id - , ouniqGroup :: !(GroupName a -> Id a) - -- ^ the id of the unique member of - -- a singleton content group - , opick :: !(GroupName a -> (a -> Bool) -> Rnd (Maybe (Id a))) - -- ^ pick a random id belonging to a group - -- and satisfying a predicate - , ofoldrWithKey :: !(forall b. (Id a -> a -> b -> b) -> b -> b) - -- ^ fold over all content elements of @a@ - , ofoldlWithKey' :: !(forall b. (b -> Id a -> a -> b) -> b -> b) - -- ^ fold strictly over all content @a@ - , ofoldlGroup' :: !(forall b. - GroupName a -> (b -> Int -> Id a -> a -> b) -> b -> b) - -- ^ fold over the given group only - , olength :: !Int -- ^ size of content @a@ + { okind :: Id a -> a -- ^ content element at given id + , ouniqGroup :: GroupName a -> Id a + -- ^ the id of the unique member of + -- a singleton content group + , opick :: GroupName a -> (a -> Bool) -> Rnd (Maybe (Id a)) + -- ^ pick a random id belonging to a group + -- and satisfying a predicate + , ofoldrWithKey :: forall b. (Id a -> a -> b -> b) -> b -> b + -- ^ fold over all content elements of @a@ + , ofoldlWithKey' :: forall b. (b -> Id a -> a -> b) -> b -> b + -- ^ fold strictly over all content @a@ + , ofoldlGroup' :: forall b. + GroupName a -> (b -> Int -> Id a -> a -> b) -> b -> b + -- ^ fold over the given group only + , olength :: Int -- ^ size of content @a@ } diff --git a/Game/LambdaHack/Common/Level.hs b/Game/LambdaHack/Common/Level.hs --- a/Game/LambdaHack/Common/Level.hs +++ b/Game/LambdaHack/Common/Level.hs @@ -39,7 +39,7 @@ let (minD, maxD) = case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of (Just ((s, _), _), Just ((e, _), _)) -> (s, e) - _ -> assert `failure` "null dungeon" `twith` dungeon + _ -> error $ "null dungeon" `showFailure` dungeon ln = max minD $ min maxD $ toEnum $ fromEnum lid + if up then 1 else -1 in case EM.lookup ln dungeon of Just _ | ln /= lid -> [ln] @@ -64,15 +64,15 @@ Just isnd -> (False, isnd) Nothing -> case mup of Just forcedUp -> (forcedUp, 0) -- for ascending via, e.g., spells - Nothing -> assert `failure` "no stairs at" `twith` (lid, pos) + Nothing -> error $ "no stairs at" `showFailure` (lid, pos) !_A = assert (maybe True (== up) mup) () in case ascendInBranch dungeon up lid of [] | isJust mup -> (lid, pos) -- spell fizzles - [] -> assert `failure` "no dungeon level to go to" `twith` (lid, pos) + [] -> error $ "no dungeon level to go to" `showFailure` (lid, pos) ln : _ -> let lvlDest = dungeon EM.! ln stairsDest = (if up then snd else fst) (lstair lvlDest) in if length stairsDest < i + 1 - then assert `failure` "no stairs at index" `twith` (lid, pos) + then error $ "no stairs at index" `showFailure` (lid, pos) else (ln, stairsDest !! i) -- | Items located on map tiles. @@ -90,40 +90,40 @@ -- | A view on single, inhabited dungeon level. "Remembered" fields -- carry a subset of the info in the client copies of levels. data Level = Level - { ldepth :: !AbsDepth -- ^ absolute depth of the level - , lfloor :: !ItemFloor -- ^ remembered items lying on the floor - , lembed :: !ItemFloor -- ^ items embedded in the tile - , lactor :: !ActorMap -- ^ seen actors at positions on the level - , ltile :: !TileMap -- ^ remembered level map - , lxsize :: !X -- ^ width of the level - , lysize :: !Y -- ^ height of the level - , lsmell :: !SmellMap -- ^ remembered smells on the level - , ldesc :: !Text -- ^ level description - , lstair :: !([Point], [Point]) - -- ^ positions of (up, down) stairs - , lseen :: !Int -- ^ currently remembered clear tiles - , lexplorable :: !Int -- ^ total number of explorable tiles - , ltime :: !Time -- ^ local time on the level (possibly frozen) - , lactorCoeff :: !Int -- ^ the lower, the more monsters spawn - , lactorFreq :: !(Freqs ItemKind) - -- ^ frequency of spawned actors; [] for clients - , litemNum :: !Int -- ^ number of initial items, 0 for clients - , litemFreq :: !(Freqs ItemKind) - -- ^ frequency of initial items; [] for clients - , lescape :: ![Point] -- ^ positions of IK.Escape tiles - , lnight :: !Bool + { ldepth :: AbsDepth -- ^ absolute depth of the level + , lfloor :: ItemFloor -- ^ remembered items lying on the floor + , lembed :: ItemFloor -- ^ items embedded in the tile + , lactor :: ActorMap -- ^ seen actors at positions on the level + , ltile :: TileMap -- ^ remembered level map + , lxsize :: X -- ^ width of the level + , lysize :: Y -- ^ height of the level + , lsmell :: SmellMap -- ^ remembered smells on the level + , ldesc :: Text -- ^ level description + , lstair :: ([Point], [Point]) + -- ^ positions of (up, down) stairs + , lseen :: Int -- ^ currently remembered clear tiles + , lexplorable :: Int -- ^ total number of explorable tiles + , ltime :: Time -- ^ local time on the level (possibly frozen) + , lactorCoeff :: Int -- ^ the lower, the more monsters spawn + , lactorFreq :: Freqs ItemKind + -- ^ frequency of spawned actors; [] for clients + , litemNum :: Int -- ^ number of initial items, 0 for clients + , litemFreq :: Freqs ItemKind + -- ^ frequency of initial items; [] for clients + , lescape :: [Point] -- ^ positions of IK.Escape tiles + , lnight :: Bool } deriving (Show, Eq) assertSparseItems :: ItemFloor -> ItemFloor assertSparseItems m = assert (EM.null (EM.filter EM.null m) - `blame` "null floors found" `twith` m) m + `blame` "null floors found" `swith` m) m assertSparseActors :: ActorMap -> ActorMap assertSparseActors m = assert (EM.null (EM.filter null m) - `blame` "null actor lists found" `twith` m) m + `blame` "null actor lists found" `swith` m) m -- | Query for tile kinds on the map. at :: Level -> Point -> Kind.Id TileKind 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 @@ -1,7 +1,5 @@ {-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, TypeFamilies #-} -#if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -Wno-orphans #-} -#endif -- | Hacks that haven't found their home yet. module Game.LambdaHack.Common.Misc ( -- * Game object identifiers @@ -97,10 +95,10 @@ -- | Item container type. data Container = - CFloor !LevelId !Point - | CEmbed !LevelId !Point - | CActor !ActorId !CStore - | CTrunk !FactionId !LevelId !Point -- ^ for bootstrapping actor bodies + CFloor LevelId Point + | CEmbed LevelId Point + | CActor ActorId CStore + | CTrunk FactionId LevelId Point -- ^ for bootstrapping actor bodies deriving (Show, Eq, Ord, Generic) instance Binary Container @@ -197,12 +195,6 @@ instance (Enum k, Binary k) => Binary (ES.EnumSet k) where put m = put (ES.size m) >> mapM_ put (ES.toAscList m) get = ES.fromDistinctAscList <$> get - -#if !MIN_VERSION_binary(0,8,0) -instance Binary (Fixed.Fixed a) where - put (Fixed.MkFixed a) = put a - get = Fixed.MkFixed `liftM` get -#endif instance Binary Time.NominalDiffTime where get = fmap realToFrac (get :: Get Fixed.Pico) diff --git a/Game/LambdaHack/Common/MonadStateRead.hs b/Game/LambdaHack/Common/MonadStateRead.hs --- a/Game/LambdaHack/Common/MonadStateRead.hs +++ b/Game/LambdaHack/Common/MonadStateRead.hs @@ -56,7 +56,7 @@ let (minD, maxD) = case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of (Just ((s, _), _), Just ((e, _), _)) -> (s, e) - _ -> assert `failure` "empty dungeon" `twith` dungeon + _ -> error $ "empty dungeon" `showFailure` dungeon f [] = 0 f ((ln, _, _) : _) = ln return $! max minD $ min maxD $ toEnum $ f $ ginitial fact diff --git a/Game/LambdaHack/Common/Perception.hs b/Game/LambdaHack/Common/Perception.hs --- a/Game/LambdaHack/Common/Perception.hs +++ b/Game/LambdaHack/Common/Perception.hs @@ -52,8 +52,8 @@ -- | The type representing the perception of a faction on a level. data Perception = Perception - { psight :: !PerVisible - , psmell :: !PerSmelled + { psight :: PerVisible + , psmell :: PerSmelled } deriving (Show, Eq, Generic) diff --git a/Game/LambdaHack/Common/Point.hs b/Game/LambdaHack/Common/Point.hs --- a/Game/LambdaHack/Common/Point.hs +++ b/Game/LambdaHack/Common/Point.hs @@ -26,8 +26,8 @@ -- and down, so that the (0, 0) point is in the top-left corner of the screen. -- Coordinates are never negative. data Point = Point - { px :: !X - , py :: !Y + { px :: X + , py :: Y } deriving (Eq, Ord, Generic) @@ -54,7 +54,7 @@ #ifdef WITH_EXPENSIVE_ASSERTIONS assert (x >= 0 && y >= 0 && x <= maxLevelDim && y <= maxLevelDim `blame` "invalid point coordinates" - `twith` (x, y)) + `swith` (x, y)) #endif (x + unsafeShiftL y maxLevelDimExponent) toEnum n = Point (n .&. maxLevelDim) (unsafeShiftR n maxLevelDimExponent) @@ -135,8 +135,8 @@ result | x0 == x1 = map (Point x0) (fromTo1 y0 y1) | y0 == y1 = map (`Point` y0) (fromTo1 x0 x1) - | otherwise = assert `failure` "diagonal fromTo" - `twith` ((x0, y0), (x1, y1)) + | otherwise = error $ "diagonal fromTo" + `showFailure` ((x0, y0), (x1, y1)) in result originPoint :: Point diff --git a/Game/LambdaHack/Common/PointArray.hs b/Game/LambdaHack/Common/PointArray.hs --- a/Game/LambdaHack/Common/PointArray.hs +++ b/Game/LambdaHack/Common/PointArray.hs @@ -17,11 +17,7 @@ import Control.Monad.ST.Strict import Data.Binary import Data.Vector.Binary () -#if MIN_VERSION_vector(0,11,0) import qualified Data.Vector.Fusion.Bundle as Bundle -#else -import qualified Data.Vector.Fusion.Stream as Bundle -#endif import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as VM @@ -30,9 +26,9 @@ -- | Arrays indexed by @Point@. data GArray w c = Array - { axsize :: !X - , aysize :: !Y - , avector :: !(U.Vector w) + { axsize :: X + , aysize :: Y + , avector :: U.Vector w } deriving Eq diff --git a/Game/LambdaHack/Common/Prelude.hs b/Game/LambdaHack/Common/Prelude.hs --- a/Game/LambdaHack/Common/Prelude.hs +++ b/Game/LambdaHack/Common/Prelude.hs @@ -25,7 +25,7 @@ import Data.Maybe import Data.Monoid.Compat -import Control.Exception.Assert.Sugar +import Control.Exception.Assert.Sugar (allB, assert, blame, showFailure, swith) import Data.Text (Text) diff --git a/Game/LambdaHack/Common/Random.hs b/Game/LambdaHack/Common/Random.hs --- a/Game/LambdaHack/Common/Random.hs +++ b/Game/LambdaHack/Common/Random.hs @@ -40,7 +40,7 @@ -- | Get any element of a list with equal probability. oneOf :: [a] -> Rnd a -oneOf [] = assert `failure` "oneOf []" `twith` () +oneOf [] = error $ "oneOf []" `showFailure` () oneOf xs = do r <- randomR (0, length xs - 1) return $! xs !! r @@ -53,20 +53,20 @@ -- | Randomly choose an item according to the distribution. rollFreq :: Show a => Frequency a -> R.StdGen -> (a, R.StdGen) rollFreq fr g = case runFrequency fr of - [] -> assert `failure` "choice from an empty frequency" - `twith` nameFrequency fr - [(n, x)] | n <= 0 -> assert `failure` "singleton void frequency" - `twith` (nameFrequency fr, n, x) + [] -> error $ "choice from an empty frequency" + `showFailure` nameFrequency fr + [(n, x)] | n <= 0 -> error $ "singleton void frequency" + `showFailure` (nameFrequency fr, n, x) [(_, x)] -> (x, g) -- speedup fs -> let sumf = foldl' (\ !acc (!n, _) -> acc + n) 0 fs (r, ng) = R.randomR (1, sumf) g frec :: Int -> [(Int, a)] -> a - frec !m [] = assert `failure` "impossible roll" - `twith` (nameFrequency fr, fs, m) + frec !m [] = error $ "impossible roll" + `showFailure` (nameFrequency fr, fs, m) frec m ((n, x) : _) | m <= n = x frec m ((n, _) : xs) = frec (m - n) xs in assert (sumf > 0 `blame` "frequency with nothing to pick" - `twith` (nameFrequency fr, fs)) + `swith` (nameFrequency fr, fs)) (frec r fs, ng) -- | Fractional chance. @@ -86,7 +86,7 @@ castDice (AbsDepth n) (AbsDepth depth) dice = do let !_A = assert (n >= 0 && n <= depth `blame` "invalid depth for dice rolls" - `twith` (n, depth)) () + `swith` (n, depth)) () dc <- frequency $ Dice.diceConst dice dl <- frequency $ Dice.diceLevel dice return $! (dc + (dl * max 0 (n - 1)) `div` max 1 (depth - 1)) diff --git a/Game/LambdaHack/Common/Request.hs b/Game/LambdaHack/Common/Request.hs --- a/Game/LambdaHack/Common/Request.hs +++ b/Game/LambdaHack/Common/Request.hs @@ -41,16 +41,16 @@ data ReqUI = ReqUINop | ReqUITimed RequestAnyAbility - | ReqUIGameRestart !(GroupName ModeKind) !Challenge + | ReqUIGameRestart (GroupName ModeKind) Challenge | ReqUIGameExit | ReqUIGameSave - | ReqUITactic !Tactic + | ReqUITactic Tactic | ReqUIAutomate deriving Show type RequestUI = (ReqUI, Maybe ActorId) -data RequestAnyAbility = forall a. RequestAnyAbility !(RequestTimed a) +data RequestAnyAbility = forall a. RequestAnyAbility (RequestTimed a) deriving instance Show RequestAnyAbility @@ -59,15 +59,15 @@ -- | Client-server requests that take game time. Sent by both AI and UI clients. data RequestTimed :: Ability -> * where - ReqMove :: !Vector -> RequestTimed 'AbMove - ReqMelee :: !ActorId -> !ItemId -> !CStore -> RequestTimed 'AbMelee - ReqDisplace :: !ActorId -> RequestTimed 'AbDisplace - ReqAlter :: !Point -> RequestTimed 'AbAlter + 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 + ReqMoveItems :: [(ItemId, Int, CStore, CStore)] -> RequestTimed 'AbMoveItem + ReqProject :: Point -> Int -> ItemId -> CStore -> RequestTimed 'AbProject + ReqApply :: ItemId -> CStore -> RequestTimed 'AbApply deriving instance Show (RequestTimed a) diff --git a/Game/LambdaHack/Common/Response.hs b/Game/LambdaHack/Common/Response.hs --- a/Game/LambdaHack/Common/Response.hs +++ b/Game/LambdaHack/Common/Response.hs @@ -17,9 +17,9 @@ -- | Abstract syntax of client commands for both AI and UI clients. data Response = - RespUpdAtomic !UpdAtomic - | RespQueryAI !ActorId - | RespSfxAtomic !SfxAtomic + RespUpdAtomic UpdAtomic + | RespQueryAI ActorId + | RespSfxAtomic SfxAtomic | RespQueryUI deriving Show @@ -27,7 +27,7 @@ -- | Connection channel between the server and a single client. data ChanServer = ChanServer - { responseS :: !(CliSerQueue Response) - , requestAIS :: !(CliSerQueue RequestAI) - , requestUIS :: !(Maybe (CliSerQueue RequestUI)) + { responseS :: CliSerQueue Response + , requestAIS :: CliSerQueue RequestAI + , requestUIS :: Maybe (CliSerQueue RequestUI) } diff --git a/Game/LambdaHack/Common/RingBuffer.hs b/Game/LambdaHack/Common/RingBuffer.hs --- a/Game/LambdaHack/Common/RingBuffer.hs +++ b/Game/LambdaHack/Common/RingBuffer.hs @@ -15,10 +15,10 @@ import GHC.Generics (Generic) data RingBuffer a = RingBuffer - { rbCarrier :: !(Seq.Seq a) - , rbMaxSize :: !Int - , rbNext :: !Int - , rbLength :: !Int + { rbCarrier :: Seq.Seq a + , rbMaxSize :: Int + , rbNext :: Int + , rbLength :: Int } deriving (Show, Generic) diff --git a/Game/LambdaHack/Common/Save.hs b/Game/LambdaHack/Common/Save.hs --- a/Game/LambdaHack/Common/Save.hs +++ b/Game/LambdaHack/Common/Save.hs @@ -137,13 +137,23 @@ T.hPutStrLn stdout t hFlush stdout -saveNameCli :: FactionId -> String -saveNameCli side = - let n = fromEnum side -- we depend on the numbering hack to number saves - in (if n > 0 - then "human_" ++ show n - else "computer_" ++ show (-n)) +saveNameCli :: Kind.COps -> FactionId -> String +saveNameCli cops side = + let gameShortName = + case T.words $ rtitle $ Kind.stdRuleset $ Kind.corule cops of + w : _ -> T.unpack w + _ -> "Game" + n = fromEnum side -- we depend on the numbering hack to number saves + in gameShortName + ++ (if n > 0 + then ".human_" ++ show n + else ".computer_" ++ show (-n)) ++ ".sav" -saveNameSer :: String -saveNameSer = "server.sav" +saveNameSer :: Kind.COps -> String +saveNameSer cops = + let gameShortName = + case T.words $ rtitle $ Kind.stdRuleset $ Kind.corule cops of + w : _ -> T.unpack w + _ -> "Game" + in gameShortName ++ ".server.sav" 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 @@ -34,15 +34,15 @@ -- in the client copies of the state. Clients never directly change -- their @State@, but apply atomic actions sent by the server to do so. data State = State - { _sdungeon :: !Dungeon -- ^ remembered dungeon - , _stotalDepth :: !AbsDepth -- ^ absolute dungeon depth, for item creation - , _sactorD :: !ActorDict -- ^ remembered actors in the dungeon - , _sitemD :: !ItemDict -- ^ remembered items in the dungeon - , _sfactionD :: !FactionDict -- ^ remembered sides still in game - , _stime :: !Time -- ^ global game time, for UI display only - , _scops :: Kind.COps -- ^ remembered content - , _shigh :: !HighScore.ScoreDict -- ^ high score table - , _sgameModeId :: !(Kind.Id ModeKind) -- ^ current game mode + { _sdungeon :: Dungeon -- ^ remembered dungeon + , _stotalDepth :: AbsDepth -- ^ absolute dungeon depth, for item creation + , _sactorD :: ActorDict -- ^ remembered actors in the dungeon + , _sitemD :: ItemDict -- ^ remembered items in the dungeon + , _sfactionD :: FactionDict -- ^ remembered sides still in game + , _stime :: Time -- ^ global game time, for UI display only + , _scops :: ~Kind.COps -- ^ remembered content + , _shigh :: HighScore.ScoreDict -- ^ high score table + , _sgameModeId :: Kind.Id ModeKind -- ^ current game mode } deriving (Show, Eq) @@ -197,5 +197,5 @@ _stime <- get _shigh <- get _sgameModeId <- get - let _scops = assert `failure` "overwritten by recreated cops" `twith` () + let _scops = error $ "overwritten by recreated cops" `showFailure` () return $! State{..} diff --git a/Game/LambdaHack/Common/Tile.hs b/Game/LambdaHack/Common/Tile.hs --- a/Game/LambdaHack/Common/Tile.hs +++ b/Game/LambdaHack/Common/Tile.hs @@ -232,7 +232,7 @@ let getTo (TK.OpenTo grp) acc = grp : acc getTo _ acc = acc case foldr getTo [] $ TK.tfeature $ okind t of - [grp] -> fromMaybe (assert `failure` grp) <$> opick grp (const True) + [grp] -> fromMaybe (error $ "" `showFailure` grp) <$> opick grp (const True) _ -> return t closeTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind) @@ -240,7 +240,7 @@ let getTo (TK.CloseTo grp) acc = grp : acc getTo _ acc = acc case foldr getTo [] $ TK.tfeature $ okind t of - [grp] -> fromMaybe (assert `failure` grp) <$> opick grp (const True) + [grp] -> fromMaybe (error $ "" `showFailure` grp) <$> opick grp (const True) _ -> return t embeddedItems :: Kind.Ops TileKind -> Kind.Id TileKind -> [GroupName ItemKind] @@ -257,7 +257,7 @@ [] -> return t groups -> do grp <- oneOf groups - fromMaybe (assert `failure` grp) <$> opick grp (const True) + fromMaybe (error $ "" `showFailure` grp) <$> opick grp (const True) obscureAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind) obscureAs Kind.Ops{okind, opick} t = do @@ -267,7 +267,7 @@ [] -> return t groups -> do grp <- oneOf groups - fromMaybe (assert `failure` grp) <$> opick grp (const True) + fromMaybe (error $ "" `showFailure` grp) <$> opick grp (const True) hideAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Kind.Id TileKind hideAs Kind.Ops{okind, ouniqGroup} t = diff --git a/Game/LambdaHack/Common/Time.hs b/Game/LambdaHack/Common/Time.hs --- a/Game/LambdaHack/Common/Time.hs +++ b/Game/LambdaHack/Common/Time.hs @@ -1,14 +1,14 @@ {-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving #-} -- | Game time and speed. module Game.LambdaHack.Common.Time - ( Time, timeZero, timeClip, timeTurn, timeEpsilon + ( Time, timeZero, timeClip, timeTurn, timeSecond, timeEpsilon , absoluteTimeAdd, absoluteTimeSubtract, absoluteTimeNegate , timeFit, timeFitUp , Delta(..), timeShift, timeDeltaToFrom , timeDeltaSubtract, timeDeltaReverse, timeDeltaScale, timeDeltaPercent , timeDeltaToDigit, ticksPerMeter , Speed, toSpeed, fromSpeed - , speedZero, speedWalk, speedThrust, modifyDamageBySpeed + , speedZero, speedWalk, speedLimp, speedThrust, modifyDamageBySpeed , speedScale, timeDeltaDiv, speedAdd, speedNegate , speedFromWeight, rangeFromSpeedAndLinger ) where @@ -24,7 +24,7 @@ -- | Game time in ticks. The time dimension. -- One tick is 1 microsecond (one millionth of a second), -- one turn is 0.5 s. -newtype Time = Time Int64 +newtype Time = Time {timeTicks :: Int64} deriving (Show, Eq, Ord, Enum, Bounded, Binary) -- | One-dimentional vectors. Introduced to tell apart the 2 uses of Time: @@ -64,10 +64,8 @@ turnsInSecond = 2 -- | This many ticks fits in a single second. Do not export, -_ticksInSecond :: Int64 -_ticksInSecond = - let Time ticksInTurn = timeTurn - in ticksInTurn * turnsInSecond +timeSecond :: Time +timeSecond = Time $ timeTicks timeTurn * turnsInSecond -- | Absolute time addition, e.g., for summing the total game session time -- from the times of individual games. @@ -124,7 +122,7 @@ {-# INLINE timeDeltaScale #-} timeDeltaScale (Delta (Time t)) s = Delta (Time (t * fromIntegral s)) --- | Take the given percent of the time vector.. +-- | Take the given percent of the time vector. timeDeltaPercent :: Delta Time -> Int -> Delta Time {-# INLINE timeDeltaPercent #-} timeDeltaPercent (Delta (Time t)) s = @@ -182,6 +180,11 @@ speedWalk :: Speed speedWalk = Speed $ 2 * sInMs +-- | Limp speed (1 m/s) that suffices to move one tile in two turns. +-- This is the minimal speed for projectiles to fly just one space and drop. +speedLimp :: Speed +speedLimp = Speed sInMs + -- | Sword thrust speed (10 m/s). Base weapon damages, both melee and ranged, -- are given assuming this speed and ranged damage is modified -- accordingly when projectile speeds differ. Differences in melee @@ -221,7 +224,7 @@ ticksPerMeter :: Speed -> Delta Time {-# INLINE ticksPerMeter #-} ticksPerMeter (Speed v) = - Delta $ Time $ _ticksInSecond * sInMs `divUp` max minimalSpeed v + Delta $ Time $ timeTicks timeSecond * sInMs `divUp` max minimalSpeed v -- | Calculate projectile speed from item weight in grams -- and velocity percent modifier. diff --git a/Game/LambdaHack/Common/Vector.hs b/Game/LambdaHack/Common/Vector.hs --- a/Game/LambdaHack/Common/Vector.hs +++ b/Game/LambdaHack/Common/Vector.hs @@ -29,8 +29,8 @@ -- and down, so that the (1, 1) vector points to the bottom-right corner -- of the screen. data Vector = Vector - { vx :: !X - , vy :: !Y + { vx :: X + , vy :: Y } deriving (Show, Read, Eq, Ord, Generic) @@ -100,7 +100,7 @@ compassText :: Vector -> Text compassText v = let m = EM.fromList $ zip moves longMoveTexts - assFail = assert `failure` "not a unit vector" `twith` v + assFail = error $ "not a unit vector" `showFailure` v in EM.findWithDefault assFail v m -- | Vectors of all cardinal direction unit moves, clockwise, starting north. @@ -210,7 +210,7 @@ -- (in the euclidean metric) maximally align with the original vector. normalize :: Double -> Double -> Vector normalize dx dy = - assert (dx /= 0 || dy /= 0 `blame` "can't normalize zero" `twith` (dx, dy)) $ + assert (dx /= 0 || dy /= 0 `blame` "can't normalize zero" `swith` (dx, dy)) $ let angle :: Double angle = atan (dy / dx) / (pi / 2) dxy | angle <= -0.75 && angle >= -1.25 = (0, -1) @@ -218,8 +218,7 @@ | angle <= 0.25 = (1, 0) | angle <= 0.75 = (1, 1) | angle <= 1.25 = (0, 1) - | otherwise = assert `failure` "impossible angle" - `twith` (dx, dy, angle) + | otherwise = error $ "impossible angle" `showFailure` (dx, dy, angle) in if dx >= 0 then uncurry Vector dxy else neg $ uncurry Vector dxy @@ -229,7 +228,7 @@ let res = normalize (fromIntegral vx) (fromIntegral vy) in assert (not (isUnit v) || v == res `blame` "unit vector gets untrivially normalized" - `twith` (v, res)) + `swith` (v, res)) res -- | Given two distinct positions, determine the direction (a unit vector) @@ -240,5 +239,5 @@ -- the two points. towards :: Point -> Point -> Vector towards pos0 pos1 = - assert (pos0 /= pos1 `blame` "towards self" `twith` (pos0, pos1)) + assert (pos0 /= pos1 `blame` "towards self" `swith` (pos0, pos1)) $ normalizeVector $ pos1 `vectorToFrom` pos0 diff --git a/Game/LambdaHack/Content/CaveKind.hs b/Game/LambdaHack/Content/CaveKind.hs --- a/Game/LambdaHack/Content/CaveKind.hs +++ b/Game/LambdaHack/Content/CaveKind.hs @@ -20,40 +20,40 @@ -- | Parameters for the generation of dungeon levels. -- Warning: for efficiency, avoid embedded items in any of the common tiles. data CaveKind = CaveKind - { csymbol :: !Char -- ^ a symbol - , cname :: !Text -- ^ short description - , cfreq :: !(Freqs CaveKind) -- ^ frequency within groups - , cxsize :: !X -- ^ X size of the whole cave - , cysize :: !Y -- ^ Y size of the whole cave - , cgrid :: !Dice.DiceXY -- ^ the dimensions of the grid of places - , cminPlaceSize :: !Dice.DiceXY -- ^ minimal size of places; for merging - , cmaxPlaceSize :: !Dice.DiceXY -- ^ maximal size of places - , cdarkChance :: !Dice.Dice -- ^ the chance a place is dark - , cnightChance :: !Dice.Dice -- ^ the chance the cave is dark - , cauxConnects :: !Rational -- ^ a proportion of extra connections - , cmaxVoid :: !Rational -- ^ at most this proportion of rooms void - , cminStairDist :: !Int -- ^ minimal distance between stairs - , cextraStairs :: !Dice.Dice -- ^ extra stairs on top of from above - , cdoorChance :: !Chance -- ^ the chance of a door in an opening - , copenChance :: !Chance -- ^ if there's a door, is it open? - , chidden :: !Int -- ^ if not open, hidden one in n times - , cactorCoeff :: !Int -- ^ the lower, the more monsters spawn - , cactorFreq :: !(Freqs ItemKind) -- ^ actor groups to consider - , citemNum :: !Dice.Dice -- ^ the number of items in the cave - , citemFreq :: !(Freqs ItemKind) - -- ^ item groups to consider - , cplaceFreq :: !(Freqs PlaceKind) - -- ^ place groups to consider - , cpassable :: !Bool -- ^ are passable default tiles permitted - , cdefTile :: !(GroupName TileKind) -- ^ the default cave tile - , cdarkCorTile :: !(GroupName TileKind) -- ^ the dark cave corridor tile - , clitCorTile :: !(GroupName TileKind) -- ^ the lit cave corridor tile - , cfillerTile :: !(GroupName TileKind) -- ^ the filler wall - , couterFenceTile :: !(GroupName TileKind) -- ^ the outer fence wall - , clegendDarkTile :: !(GroupName TileKind) -- ^ the dark place plan legend - , clegendLitTile :: !(GroupName TileKind) -- ^ the lit place plan legend - , cescapeGroup :: !(Maybe (GroupName PlaceKind)) -- ^ escape, if any - , cstairFreq :: !(Freqs PlaceKind) + { csymbol :: Char -- ^ a symbol + , cname :: Text -- ^ short description + , cfreq :: Freqs CaveKind -- ^ frequency within groups + , cxsize :: X -- ^ X size of the whole cave + , cysize :: Y -- ^ Y size of the whole cave + , cgrid :: Dice.DiceXY -- ^ the dimensions of the grid of places + , cminPlaceSize :: Dice.DiceXY -- ^ minimal size of places; for merging + , cmaxPlaceSize :: Dice.DiceXY -- ^ maximal size of places + , cdarkChance :: Dice.Dice -- ^ the chance a place is dark + , cnightChance :: Dice.Dice -- ^ the chance the cave is dark + , cauxConnects :: Rational -- ^ a proportion of extra connections + , cmaxVoid :: Rational -- ^ at most this proportion of rooms void + , cminStairDist :: Int -- ^ minimal distance between stairs + , cextraStairs :: Dice.Dice -- ^ extra stairs on top of from above + , cdoorChance :: Chance -- ^ the chance of a door in an opening + , copenChance :: Chance -- ^ if there's a door, is it open? + , chidden :: Int -- ^ if not open, hidden one in n times + , cactorCoeff :: Int -- ^ the lower, the more monsters spawn + , cactorFreq :: Freqs ItemKind -- ^ actor groups to consider + , citemNum :: Dice.Dice -- ^ the number of items in the cave + , citemFreq :: Freqs ItemKind + -- ^ item groups to consider + , cplaceFreq :: Freqs PlaceKind + -- ^ place groups to consider + , cpassable :: Bool -- ^ are passable default tiles permitted + , cdefTile :: GroupName TileKind -- ^ the default cave tile + , cdarkCorTile :: GroupName TileKind -- ^ the dark cave corridor tile + , clitCorTile :: GroupName TileKind -- ^ the lit cave corridor tile + , cfillerTile :: GroupName TileKind -- ^ the filler wall + , couterFenceTile :: GroupName TileKind -- ^ the outer fence wall + , clegendDarkTile :: GroupName TileKind -- ^ the dark place plan legend + , clegendLitTile :: GroupName TileKind -- ^ the lit place plan legend + , cescapeGroup :: Maybe (GroupName PlaceKind) -- ^ escape, if any + , cstairFreq :: Freqs PlaceKind -- ^ place groups to consider for stairs; in this case the rarity -- of items in the group does not affect group choice } diff --git a/Game/LambdaHack/Content/ItemKind.hs b/Game/LambdaHack/Content/ItemKind.hs --- a/Game/LambdaHack/Content/ItemKind.hs +++ b/Game/LambdaHack/Content/ItemKind.hs @@ -29,21 +29,21 @@ -- | Item properties that are fixed for a given kind of items. data ItemKind = ItemKind - { isymbol :: !Char -- ^ map symbol - , iname :: !Text -- ^ generic name - , ifreq :: !(Freqs ItemKind) -- ^ frequency within groups - , iflavour :: ![Flavour] -- ^ possible flavours - , icount :: !Dice.Dice -- ^ created in that quantity - , irarity :: !Rarity -- ^ rarity on given depths - , iverbHit :: !MU.Part -- ^ the verb&noun for applying and hit - , iweight :: !Int -- ^ weight in grams - , idamage :: ![(Int, Dice.Dice)] -- ^ frequency of basic impact damage - , iaspects :: ![Aspect] -- ^ keep the aspect continuously - , ieffects :: ![Effect] -- ^ cause the effect when triggered - , ifeature :: ![Feature] -- ^ public properties - , idesc :: !Text -- ^ description - , ikit :: ![(GroupName ItemKind, CStore)] - -- ^ accompanying organs and items + { isymbol :: Char -- ^ map symbol + , iname :: Text -- ^ generic name + , ifreq :: Freqs ItemKind -- ^ frequency within groups + , iflavour :: [Flavour] -- ^ possible flavours + , icount :: Dice.Dice -- ^ created in that quantity + , irarity :: Rarity -- ^ rarity on given depths + , iverbHit :: MU.Part -- ^ the verb&noun for applying and hit + , iweight :: Int -- ^ weight in grams + , idamage :: [(Int, Dice.Dice)] -- ^ frequency of basic impact damage + , iaspects :: [Aspect] -- ^ keep the aspect continuously + , ieffects :: [Effect] -- ^ cause the effect when triggered + , ifeature :: [Feature] -- ^ public properties + , idesc :: Text -- ^ description + , ikit :: [(GroupName ItemKind, CStore)] + -- ^ accompanying organs and items } deriving Show -- No Eq and Ord to make extending it logically sound @@ -52,43 +52,43 @@ -- are possible. Constructors are sorted vs increasing impact/danger. data Effect = -- Ordinary effects. - ELabel !Text -- ^ secret (learned as effect) label of the item - | EqpSlot !EqpSlot -- ^ AI and UI flag that leaks item properties - | Burn !Dice.Dice - | Explode !(GroupName ItemKind) + ELabel Text -- ^ secret (learned as effect) label of the item + | EqpSlot EqpSlot -- ^ AI and UI flag that leaks item properties + | Burn Dice.Dice + | Explode (GroupName ItemKind) -- ^ explode, producing this group of blasts - | RefillHP !Int - | RefillCalm !Int + | RefillHP Int + | RefillCalm Int | Dominate | Impress - | Summon !(GroupName ItemKind) !Dice.Dice - | Ascend !Bool + | Summon (GroupName ItemKind) Dice.Dice + | Ascend Bool | Escape - | Paralyze !Dice.Dice -- ^ expressed in game clips - | InsertMove !Dice.Dice -- ^ expressed in game turns - | Teleport !Dice.Dice - | CreateItem !CStore !(GroupName ItemKind) !TimerDice + | Paralyze Dice.Dice -- ^ expressed in game clips + | InsertMove Dice.Dice -- ^ expressed in game turns + | Teleport Dice.Dice + | CreateItem CStore (GroupName ItemKind) TimerDice -- ^ create an item of the group and insert into the store with the given -- random timer - | DropItem !Int !Int !CStore !(GroupName ItemKind) + | DropItem Int Int CStore (GroupName ItemKind) | PolyItem | Identify - | Detect !Int - | DetectActor !Int - | DetectItem !Int - | DetectExit !Int - | DetectHidden !Int - | SendFlying !ThrowMod - | PushActor !ThrowMod - | PullActor !ThrowMod + | Detect Int + | DetectActor Int + | DetectItem Int + | DetectExit Int + | DetectHidden Int + | SendFlying ThrowMod + | PushActor ThrowMod + | PullActor ThrowMod | DropBestWeapon - | ActivateInv !Char -- ^ symbol @' '@ means all + | ActivateInv Char -- ^ symbol @' '@ means all | ApplyPerfume -- Exotic effects follow. - | OneOf ![Effect] - | OnSmash !Effect -- ^ trigger if item smashed (not applied nor meleed) - | Recharging !Effect -- ^ this effect inactive until timeout passes - | Temporary !Text + | OneOf [Effect] + | OnSmash Effect -- ^ trigger if item smashed (not applied nor meleed) + | Recharging Effect -- ^ this effect inactive until timeout passes + | Temporary Text -- ^ the item is temporary, vanishes at even void Periodic activation, -- unless Durable and not Fragile, and shows message with -- this verb at last copy activation or at each activation @@ -121,8 +121,8 @@ data TimerDice = TimerNone - | TimerGameTurn !Dice.Dice - | TimerActorTurn !Dice.Dice + | TimerGameTurn Dice.Dice + | TimerActorTurn Dice.Dice deriving (Eq, Ord, Generic) instance Show TimerDice where @@ -137,27 +137,27 @@ -- | Aspects of items. Those that are named @Add*@ are additive -- (starting at 0) for all items wielded by an actor and they affect the actor. data Aspect = - Timeout !Dice.Dice -- ^ some effects disabled until item recharges; - -- expressed in game turns - | AddHurtMelee !Dice.Dice -- ^ percentage damage bonus in melee - | AddArmorMelee !Dice.Dice -- ^ percentage armor bonus against melee - | AddArmorRanged !Dice.Dice -- ^ percentage armor bonus against ranged - | AddMaxHP !Dice.Dice -- ^ maximal hp - | AddMaxCalm !Dice.Dice -- ^ maximal calm - | AddSpeed !Dice.Dice -- ^ speed in m/10s (not of a projectile!) - | AddSight !Dice.Dice -- ^ FOV radius, where 1 means a single tile - | AddSmell !Dice.Dice -- ^ smell radius, where 1 means a single tile - | AddShine !Dice.Dice -- ^ shine radius, where 1 means a single tile - | AddNocto !Dice.Dice -- ^ noctovision radius, where 1 is single tile - | AddAggression !Dice.Dice -- ^ aggression, especially closing in for melee - | AddAbility !Ability.Ability !Dice.Dice -- ^ bonus to an ability + Timeout Dice.Dice -- ^ some effects disabled until item recharges; + -- expressed in game turns + | AddHurtMelee Dice.Dice -- ^ percentage damage bonus in melee + | AddArmorMelee Dice.Dice -- ^ percentage armor bonus against melee + | AddArmorRanged Dice.Dice -- ^ percentage armor bonus against ranged + | AddMaxHP Dice.Dice -- ^ maximal hp + | AddMaxCalm Dice.Dice -- ^ maximal calm + | AddSpeed Dice.Dice -- ^ speed in m/10s (not of a projectile) + | AddSight Dice.Dice -- ^ FOV radius, where 1 means a single tile + | AddSmell Dice.Dice -- ^ smell radius, where 1 means a single tile + | AddShine Dice.Dice -- ^ shine radius, where 1 means a single tile + | AddNocto Dice.Dice -- ^ noctovision radius, where 1 is single tile + | AddAggression Dice.Dice -- ^ aggression, especially closing in for melee + | AddAbility Ability.Ability Dice.Dice -- ^ bonus to an ability deriving (Show, Eq, Ord, Generic) -- | Parameters modifying a throw of a projectile or flight of pushed actor. -- Not additive and don't start at 0. data ThrowMod = ThrowMod - { throwVelocity :: !Int -- ^ fly with this percentage of base throw speed - , throwLinger :: !Int -- ^ fly for this percentage of 2 turns + { throwVelocity :: Int -- ^ fly with this percentage of base throw speed + , throwLinger :: Int -- ^ fly for this percentage of 2 turns } deriving (Show, Eq, Ord, Generic) @@ -169,7 +169,7 @@ Fragile -- ^ drop and break at target tile, even if no hit | Lobable -- ^ drop at target tile, even if no hit | Durable -- ^ don't break even when hitting or applying - | ToThrow !ThrowMod -- ^ parameters modifying a throw + | ToThrow ThrowMod -- ^ parameters modifying a throw | Identified -- ^ the item starts identified | Applicable -- ^ AI and UI flag: consider applying | Equipable -- ^ AI and UI flag: consider equipping (independent of @@ -177,7 +177,7 @@ | Meleeable -- ^ AI and UI flag: consider meleeing with | Precious -- ^ AI and UI flag: don't risk identifying by use -- also, can't throw or apply if not calm enough; - | Tactic !Tactic -- ^ overrides actor's tactic + | Tactic Tactic -- ^ overrides actor's tactic deriving (Show, Eq, Ord, Generic) data EqpSlot = @@ -256,6 +256,7 @@ [ "iname longer than 23" | T.length iname > 23 ] ++ [ "icount < 0" | icount < 0 ] ++ validateRarity irarity + ++ validateDamage idamage -- Reject duplicate Timeout, because it's not additive. ++ (let timeoutAspect :: Aspect -> Bool timeoutAspect Timeout{} = True @@ -275,7 +276,7 @@ ++ [ "EqpSlot specified but not Equipable nor Meleeable" | length ts > 0 && Equipable `notElem` ifeature && Meleeable `notElem` ifeature ]) - ++ ["Reduntand Equipable or Meleeable" | Equipable `elem` ifeature + ++ ["Redundant Equipable or Meleeable" | Equipable `elem` ifeature && Meleeable `elem` ifeature] ++ (let f :: Effect -> Bool f Temporary{} = True @@ -310,6 +311,12 @@ validateDups ItemKind{..} feat = let ts = filter (== feat) ifeature in ["more than one" <+> tshow feat <+> "specification" | length ts > 1] + +validateDamage :: [(Int, Dice.Dice)] -> [Text] +validateDamage = concatMap validateDice + where + validateDice (_, dice) = [ "potentially negative dice:" <+> tshow dice + | Dice.minDice dice < 0] -- | Validate all item kinds. validateAllItemKind :: [ItemKind] -> [Text] diff --git a/Game/LambdaHack/Content/ModeKind.hs b/Game/LambdaHack/Content/ModeKind.hs --- a/Game/LambdaHack/Content/ModeKind.hs +++ b/Game/LambdaHack/Content/ModeKind.hs @@ -25,12 +25,12 @@ -- | Game mode specification. data ModeKind = ModeKind - { msymbol :: !Char -- ^ a symbol - , mname :: !Text -- ^ short description - , mfreq :: !(Freqs ModeKind) -- ^ frequency within groups - , mroster :: !Roster -- ^ players taking part in the game - , mcaves :: !Caves -- ^ arena of the game - , mdesc :: !Text -- ^ description + { msymbol :: Char -- ^ a symbol + , mname :: Text -- ^ short description + , mfreq :: Freqs ModeKind -- ^ frequency within groups + , mroster :: Roster -- ^ players taking part in the game + , mcaves :: Caves -- ^ arena of the game + , mdesc :: Text -- ^ description } deriving Show @@ -41,11 +41,11 @@ -- | The specification of players for the game mode. data Roster = Roster - { rosterList :: ![(Player, [(Int, Dice.Dice, GroupName ItemKind)])] + { rosterList :: [(Player, [(Int, Dice.Dice, GroupName ItemKind)])] -- ^ players in the particular team and levels, numbers and groups -- of their initial members - , rosterEnemy :: ![(Text, Text)] -- ^ the initial enmity matrix - , rosterAlly :: ![(Text, Text)] -- ^ the initial aliance matrix + , rosterEnemy :: [(Text, Text)] -- ^ the initial enmity matrix + , rosterAlly :: [(Text, Text)] -- ^ the initial aliance matrix } deriving (Show, Eq) @@ -75,22 +75,22 @@ -- | Properties of a particular player. data Player = Player - { fname :: !Text -- ^ name of the player - , fgroups :: ![GroupName ItemKind] + { fname :: Text -- ^ name of the player + , fgroups :: [GroupName ItemKind] -- ^ names of actor groups that may naturally -- fall under player's control, e.g., upon -- spawning or summoning - , fskillsOther :: !Skills -- ^ fixed skill modifiers to the non-leader + , fskillsOther :: Skills -- ^ fixed skill modifiers to the non-leader -- actors; also summed with skills implied -- by ftactic (which is not fixed) - , fcanEscape :: !Bool -- ^ the player can escape the dungeon - , fneverEmpty :: !Bool -- ^ the faction declared killed if no actors - , fhiCondPoly :: !HiCondPoly -- ^ score polynomial for the player - , fhasGender :: !Bool -- ^ whether actors have gender - , ftactic :: !Tactic -- ^ non-leaders behave according to this + , fcanEscape :: Bool -- ^ the player can escape the dungeon + , fneverEmpty :: Bool -- ^ the faction declared killed if no actors + , fhiCondPoly :: HiCondPoly -- ^ score polynomial for the player + , fhasGender :: Bool -- ^ whether actors have gender + , ftactic :: Tactic -- ^ non-leaders behave according to this -- tactic; can be changed during the game - , fleaderMode :: !LeaderMode -- ^ the mode of switching the leader - , fhasUI :: !Bool -- ^ does the faction have a UI client + , fleaderMode :: LeaderMode -- ^ the mode of switching the leader + , fhasUI :: Bool -- ^ does the faction have a UI client -- (for control or passive observation) } deriving (Show, Eq, Ord, Generic) @@ -107,7 +107,7 @@ instance Binary LeaderMode data AutoLeader = AutoLeader - { autoDungeon :: !Bool + { autoDungeon :: Bool -- ^ leader switching between levels is automatically done by the server -- and client is not permitted to change to leaders from other levels -- (the frequency of leader level switching done by the server @@ -116,7 +116,7 @@ -- of the automatic switching, e.g., when the old leader dies -- and no other actor of the faction resides on his level, -- but the client (particularly UI) is expected to do changes as well - , autoLevel :: !Bool + , autoLevel :: Bool -- ^ client is discouraged from leader switching (e.g., because -- non-leader actors have the same skills as leader); -- server is guaranteed to switch leader within a level very rarely, diff --git a/Game/LambdaHack/Content/PlaceKind.hs b/Game/LambdaHack/Content/PlaceKind.hs --- a/Game/LambdaHack/Content/PlaceKind.hs +++ b/Game/LambdaHack/Content/PlaceKind.hs @@ -15,14 +15,14 @@ -- | Parameters for the generation of small areas within a dungeon level. data PlaceKind = PlaceKind - { psymbol :: !Char -- ^ a symbol - , pname :: !Text -- ^ short description - , pfreq :: !(Freqs PlaceKind) -- ^ frequency within groups - , prarity :: !Rarity -- ^ rarity on given depths - , pcover :: !Cover -- ^ how to fill whole place based on the corner - , pfence :: !Fence -- ^ whether to fence place with solid border - , ptopLeft :: ![Text] -- ^ plan of the top-left corner of the place - , poverride :: ![(Char, GroupName TileKind)] -- ^ legend override + { psymbol :: Char -- ^ a symbol + , pname :: Text -- ^ short description + , pfreq :: Freqs PlaceKind -- ^ frequency within groups + , prarity :: Rarity -- ^ rarity on given depths + , pcover :: Cover -- ^ how to fill whole place based on the corner + , pfence :: Fence -- ^ whether to fence place with solid border + , ptopLeft :: [Text] -- ^ plan of the top-left corner of the place + , poverride :: [(Char, GroupName TileKind)] -- ^ legend override } deriving Show -- No Eq and Ord to make extending it logically sound 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,21 +21,21 @@ -- and then @RuleKind@ will become just a starting template, analogously -- as for the other content. data RuleKind = RuleKind - { rsymbol :: !Char -- ^ a symbol - , rname :: !Text -- ^ short description - , rfreq :: !(Freqs RuleKind) -- ^ frequency within groups - , rtitle :: !Text -- ^ title of the game (not lib) - , rfontDir :: !FilePath -- ^ font directory for the game (not lib) - , rexeVersion :: !Version -- ^ version of the game - , rcfgUIName :: !FilePath -- ^ name of the UI config file - , rcfgUIDefault :: !String -- ^ the default UI settings config file - , rmainMenuArt :: !Text -- ^ the ASCII art for the Main Menu - , rfirstDeathEnds :: !Bool -- ^ whether first non-spawner actor death + { rsymbol :: Char -- ^ a symbol + , rname :: Text -- ^ short description + , rfreq :: Freqs RuleKind -- ^ frequency within groups + , rtitle :: Text -- ^ title of the game (not lib) + , rfontDir :: FilePath -- ^ font directory for the game (not lib) + , rexeVersion :: Version -- ^ version of the game + , rcfgUIName :: FilePath -- ^ name of the UI config file + , rcfgUIDefault :: String -- ^ the default UI settings config file + , rmainMenuArt :: Text -- ^ the ASCII art for the Main Menu + , rfirstDeathEnds :: Bool -- ^ whether first non-spawner actor death -- ends the game - , rwriteSaveClips :: !Int -- ^ game is saved that often - , rleadLevelClips :: !Int -- ^ server switches leader level that often - , rscoresFile :: !FilePath -- ^ name of the scores file - , rnearby :: !Int -- ^ what distance between actors is 'nearby' + , rwriteSaveClips :: Int -- ^ game is saved that often + , rleadLevelClips :: Int -- ^ server switches leader level that often + , rscoresFile :: FilePath -- ^ name of the scores file + , rnearby :: Int -- ^ what distance between actors is 'nearby' } -- | A dummy instance of the 'Show' class, to satisfy general requirments diff --git a/Game/LambdaHack/Content/TileKind.hs b/Game/LambdaHack/Content/TileKind.hs --- a/Game/LambdaHack/Content/TileKind.hs +++ b/Game/LambdaHack/Content/TileKind.hs @@ -37,36 +37,36 @@ -- Tile kind for unknown space has the minimal @KindOps.Id@ index. -- The @talter@ for unknown space is @1@ and no other tile kind has that value. data TileKind = TileKind - { tsymbol :: !Char -- ^ map symbol - , tname :: !Text -- ^ short description - , tfreq :: !(Freqs TileKind) -- ^ frequency within groups - , tcolor :: !Color -- ^ map color - , tcolor2 :: !Color -- ^ map color when not in FOV - , talter :: !Word8 -- ^ minimal skill needed to alter the tile - , tfeature :: ![Feature] -- ^ properties + { tsymbol :: Char -- ^ map symbol + , tname :: Text -- ^ short description + , tfreq :: Freqs TileKind -- ^ frequency within groups + , tcolor :: Color -- ^ map color + , tcolor2 :: Color -- ^ map color when not in FOV + , talter :: Word8 -- ^ minimal skill needed to alter the tile + , tfeature :: [Feature] -- ^ properties } deriving Show -- No Eq and Ord to make extending it logically sound -- | All possible terrain tile features. data Feature = - Embed !(GroupName ItemKind) + Embed (GroupName ItemKind) -- ^ initially an item of this group is embedded; -- we assume the item has effects and is supposed to be triggered - | OpenTo !(GroupName TileKind) + | OpenTo (GroupName TileKind) -- ^ goes from a closed to (randomly closed or) open tile when altered - | CloseTo !(GroupName TileKind) + | CloseTo (GroupName TileKind) -- ^ goes from an open to (randomly opened or) closed tile when altered - | ChangeTo !(GroupName TileKind) + | ChangeTo (GroupName TileKind) -- ^ alters tile, but does not change walkability - | HideAs !(GroupName TileKind) + | HideAs (GroupName TileKind) -- ^ when hidden, looks as the unique tile of the group -- The following three are only used in dungeon generation. - | BuildAs !(GroupName TileKind) + | BuildAs (GroupName TileKind) -- ^ when generating, may be transformed to the unique tile of the group - | RevealAs !(GroupName TileKind) + | RevealAs (GroupName TileKind) -- ^ when generating in opening, can be revealed to belong to the group - | ObscureAs !(GroupName TileKind) + | ObscureAs (GroupName TileKind) -- ^ when generating in solid wall, can be revealed to belong to the group | Walkable -- ^ actors can walk through @@ -95,21 +95,21 @@ instance NFData Feature data TileSpeedup = TileSpeedup - { isClearTab :: !(Tab Bool) - , isLitTab :: !(Tab Bool) - , isWalkableTab :: !(Tab Bool) - , isDoorTab :: !(Tab Bool) - , isChangableTab :: !(Tab Bool) - , isSuspectTab :: !(Tab Bool) - , isHideAsTab :: !(Tab Bool) - , consideredByAITab :: !(Tab Bool) - , isOftenItemTab :: !(Tab Bool) - , isOftenActorTab :: !(Tab Bool) - , isNoItemTab :: !(Tab Bool) - , isNoActorTab :: !(Tab Bool) - , isEasyOpenTab :: !(Tab Bool) - , alterMinSkillTab :: !(Tab Word8) - , alterMinWalkTab :: !(Tab Word8) + { isClearTab :: Tab Bool + , isLitTab :: Tab Bool + , isWalkableTab :: Tab Bool + , isDoorTab :: Tab Bool + , isChangableTab :: Tab Bool + , isSuspectTab :: Tab Bool + , isHideAsTab :: Tab Bool + , consideredByAITab :: Tab Bool + , isOftenItemTab :: Tab Bool + , isOftenActorTab :: Tab Bool + , isNoItemTab :: Tab Bool + , isNoActorTab :: Tab Bool + , isEasyOpenTab :: Tab Bool + , alterMinSkillTab :: Tab Word8 + , alterMinWalkTab :: Tab Word8 } -- Vectors of booleans can be slower than arrays, because they are not packed, @@ -210,7 +210,7 @@ mapVis :: (TileKind -> Color) -> M.Map (Char, Color) [(TileKind, IS.IntSet)] mapVis f = M.fromListWith (++) $ listVis f - isConfused [] = assert `failure` lt + isConfused [] = error $ "isConfused" `showFailure` lt isConfused [_] = False isConfused (hd : tl) = any ((Indistinct `notElem`) . tfeature . fst) (hd : tl) diff --git a/Game/LambdaHack/SampleImplementation/SampleMonadClient.hs b/Game/LambdaHack/SampleImplementation/SampleMonadClient.hs --- a/Game/LambdaHack/SampleImplementation/SampleMonadClient.hs +++ b/Game/LambdaHack/SampleImplementation/SampleMonadClient.hs @@ -19,9 +19,9 @@ import qualified Control.Monad.IO.Class as IO import Control.Monad.Trans.State.Strict hiding (State) import GHC.Generics (Generic) -import System.FilePath import Game.LambdaHack.Atomic +import Game.LambdaHack.Client import Game.LambdaHack.Client.HandleResponseM import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.State @@ -35,12 +35,12 @@ import Game.LambdaHack.Common.State data CliState = CliState - { cliState :: !State -- ^ current global state - , cliClient :: !StateClient -- ^ current client state - , cliSession :: !(Maybe SessionUI) -- ^ UI state, empty for AI clients - , cliDict :: !ChanServer -- ^ this client connection information - , cliToSave :: !(Save.ChanSave (State, StateClient, Maybe SessionUI)) - -- ^ connection to the save thread + { cliState :: State -- ^ current global state + , cliClient :: StateClient -- ^ current client state + , cliSession :: Maybe SessionUI -- ^ UI state, empty for AI clients + , cliDict :: ChanServer -- ^ this client connection information + , cliToSave :: Save.ChanSave (State, StateClient, Maybe SessionUI) + -- ^ connection to the save thread } deriving Generic @@ -129,15 +129,15 @@ -- | Init the client, then run an action, with a given session, -- state and history, in the @IO@ monad. -executorCli :: CliImplementation () - -> Maybe SessionUI +executorCli :: KeyKind -> Config -> DebugModeCli -> Kind.COps + -> Maybe SessionUI -> FactionId -> ChanServer -> IO () -executorCli m cliSession cops fid cliDict = +executorCli copsClient sconfig sdebugMode cops cliSession fid cliDict = let stateToFileName (_, cli, _) = - ssavePrefixCli (sdebugCli cli) <.> Save.saveNameCli (sside cli) + ssavePrefixCli (sdebugCli cli) <> Save.saveNameCli cops (sside cli) totalState cliToSave = CliState { cliState = emptyState cops , cliClient = emptyStateClient fid @@ -145,5 +145,6 @@ , cliToSave , cliSession } + m = loopCli copsClient sconfig sdebugMode exe = evalStateT (runCliImplementation m) . totalState in Save.wrapInSaves cops stateToFileName exe diff --git a/Game/LambdaHack/SampleImplementation/SampleMonadServer.hs b/Game/LambdaHack/SampleImplementation/SampleMonadServer.hs --- a/Game/LambdaHack/SampleImplementation/SampleMonadServer.hs +++ b/Game/LambdaHack/SampleImplementation/SampleMonadServer.hs @@ -21,14 +21,12 @@ import Control.Monad.Trans.State.Strict hiding (State) import qualified Data.EnumMap.Strict as EM import qualified Data.Text.IO as T -import System.Exit (ExitCode(ExitSuccess)) +import System.Exit (ExitCode (ExitSuccess)) import System.FilePath import System.IO (hFlush, stdout) import Game.LambdaHack.Atomic import Game.LambdaHack.Client -import Game.LambdaHack.Client.UI.Config -import Game.LambdaHack.Client.UI.Content.KeyKind import Game.LambdaHack.Common.ClientOptions import Game.LambdaHack.Common.File import qualified Game.LambdaHack.Common.Kind as Kind @@ -46,11 +44,11 @@ import Game.LambdaHack.Server.State data SerState = SerState - { serState :: !State -- ^ current global state - , serServer :: !StateServer -- ^ current server state - , serDict :: !ConnServerDict -- ^ client-server connection information - , serToSave :: !(Save.ChanSave (State, StateServer)) - -- ^ connection to the save thread + { serState :: State -- ^ current global state + , serServer :: StateServer -- ^ current server state + , serDict :: ConnServerDict -- ^ client-server connection information + , serToSave :: Save.ChanSave (State, StateServer) + -- ^ connection to the save thread } -- | Server state transformation monad. @@ -110,18 +108,18 @@ -- options and is never updated with config options, etc. let sdebugMode = applyConfigToDebug cops sconfig $ sdebugCli sdebugNxt -- Partially applied main loop of the clients. - executorClient = executorCli (loopCli copsClient sconfig sdebugMode) + executorClient = executorCli copsClient sconfig sdebugMode cops -- Wire together game content, the main loop of game clients -- and the game server loop. - let m = loopSer sdebugNxt sconfig executorClient - stateToFileName (_, ser) = - ssavePrefixSer (sdebugSer ser) <.> Save.saveNameSer + let stateToFileName (_, ser) = + ssavePrefixSer (sdebugSer ser) <> Save.saveNameSer cops totalState serToSave = SerState { serState = emptyState cops , serServer = emptyStateServer , serDict = EM.empty , serToSave } + m = loopSer sdebugNxt sconfig executorClient exe = evalStateT (runSerImplementation m) . totalState exeWithSaves = Save.wrapInSaves cops stateToFileName exe defPrefix = ssavePrefixSer defDebugModeSer @@ -132,9 +130,9 @@ when b $ renameFile (path "") (path "bkp.") bkpAllSaves = do T.hPutStrLn stdout "The game crashed, so savefiles are moved aside." - bkpOneSave $ defPrefix <.> Save.saveNameSer + bkpOneSave $ defPrefix <> Save.saveNameSer cops forM_ [-99..99] $ \n -> - bkpOneSave $ defPrefix <.> Save.saveNameCli (toEnum n) + bkpOneSave $ defPrefix <> Save.saveNameCli cops (toEnum n) -- Wait for clients to exit even in case of server crash -- (or server and client crash), which gives them time to save -- and report their own inconsistencies, if any. 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 @@ -117,7 +117,7 @@ when (fid == fid2) $ sendAtomic fid atomic PosSer -> return () PosAll -> sendAtomic fid atomic - PosNone -> assert `failure` (fid, fact, atomic) + PosNone -> error $ "" `showFailure` (fid, fact, atomic) -- Factions that are eliminated by the command are processed as well, -- because they are not deleted from @sfactionD@. factionD <- getsState sfactionD 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 @@ -4,7 +4,7 @@ ( execFailure, getPerFid , revealItems, moveStores, deduceQuits, deduceKilled , electLeader, supplantLeader - , addActor, addActorIid, projectFail, discoverIfNoEffects + , addActor, registerActor, addActorIid, projectFail, discoverIfNoEffects , pickWeaponServer, currentSkillsServer , recomputeCachePer ) where @@ -41,6 +41,7 @@ import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Server.Fov import Game.LambdaHack.Server.ItemM +import Game.LambdaHack.Server.ItemRev import Game.LambdaHack.Server.MonadServer import Game.LambdaHack.Server.State @@ -67,9 +68,9 @@ getPerFid :: MonadServer m => FactionId -> LevelId -> m Perception getPerFid fid lid = do pers <- getsServer sperFid - let failFact = assert `failure` "no perception for faction" `twith` (lid, fid) + let failFact = error $ "no perception for faction" `showFailure` (lid, fid) fper = EM.findWithDefault failFact fid pers - failLvl = assert `failure` "no perception for level" `twith` (lid, fid) + failLvl = error $ "no perception for level" `showFailure` (lid, fid) per = EM.findWithDefault failLvl lid fper return $! per @@ -83,7 +84,7 @@ Just ItemDisco{itemKindId} -> do seed <- getsServer $ (EM.! iid) . sitemSeedD execUpdAtomic $ UpdDiscover c iid itemKindId seed - _ -> assert `failure` (mfid, c, iid, itemFull) + _ -> error $ "" `showFailure` (mfid, c, iid, itemFull) f aid = do b <- getsState $ getActorBody aid let ourSide = maybe True (== bfid b) mfid @@ -132,7 +133,7 @@ deduceQuits :: (MonadAtomic m, MonadServer m) => FactionId -> Status -> m () deduceQuits fid0 status@Status{stOutcome} | stOutcome `elem` [Defeated, Camping, Restart, Conquer] = - assert `failure` "no quitting to deduce" `twith` (fid0, status) + error $ "no quitting to deduce" `showFailure` (fid0, status) deduceQuits fid0 status = do fact0 <- getsState $ (EM.! fid0) . sfactionD let factHasUI = fhasUI . gplayer @@ -244,8 +245,8 @@ lvl@Level{lxsize, lysize} <- getLevel lid case bla lxsize lysize eps spos tpxy of Nothing -> return $ Just ProjectAimOnself - Just [] -> assert `failure` "projecting from the edge of level" - `twith` (spos, tpxy) + Just [] -> error $ "projecting from the edge of level" + `showFailure` (spos, tpxy) Just (pos : restUnlimited) -> do bag <- getsState $ getBodyStoreBag sb cstore case EM.lookup iid bag of @@ -302,7 +303,7 @@ unless isBlast $ execSfxAtomic $ SfxProject source iid cstore bag <- getsState $ getBodyStoreBag sb cstore case iid `EM.lookup` bag of - Nothing -> assert `failure` (source, pos, rest, iid, cstore) + Nothing -> error $ "" `showFailure` (source, pos, rest, iid, cstore) Just kit@(_, it) -> do let btime = absoluteTimeAdd timeEpsilon localTime addProjectile pos rest iid kit lid (bfid sb) btime isBlast @@ -333,14 +334,34 @@ -> m (Maybe ActorId) addActor actorGroup bfid pos lid tweakBody time = do -- We bootstrap the actor by first creating the trunk of the actor's body - -- contains the constant properties. + -- that contains the constant properties. let trunkFreq = [(actorGroup, 1)] - m2 <- rollAndRegisterItem lid trunkFreq (CTrunk bfid lid pos) False Nothing - case m2 of + m5 <- rollItem 0 lid trunkFreq + case m5 of Nothing -> return Nothing - Just (trunkId, (trunkFull, _)) -> - addActorIid trunkId trunkFull False bfid pos lid tweakBody time + Just (itemKnownRaw, itemFullRaw, itemDisco, seed, _) -> + registerActor itemKnownRaw itemFullRaw itemDisco seed + bfid pos lid tweakBody time +registerActor :: (MonadAtomic m, MonadServer m) + => ItemKnown -> ItemFull -> ItemDisco -> ItemSeed + -> FactionId -> Point -> LevelId -> (Actor -> Actor) -> Time + -> m (Maybe ActorId) +registerActor (kindIx, ar, damage, _) itemFullRaw itemDisco seed + bfid pos lid tweakBody time = do + let container = CTrunk bfid lid pos + -- Other code adds to @sdiscoBenefit@ only @iid@ and not any other items + -- that share the same @jkindIx@, so this is broken if such items + -- are not fully IDed from the start, so check that before risking a copy + -- of the same item, but with different @jfid@. + jfid = if IK.Identified `elem` IK.ifeature (itemKind itemDisco) + then Just bfid + else Nothing + itemKnown = (kindIx, ar, damage, jfid) + itemFull = itemFullRaw {itemBase = (itemBase itemFullRaw) {jfid}} + trunkId <- registerItem itemFull itemKnown seed container False + addActorIid trunkId itemFull False bfid pos lid tweakBody time + addActorIid :: (MonadAtomic m, MonadServer m) => ItemId -> ItemFull -> Bool -> FactionId -> Point -> LevelId -> (Actor -> Actor) -> Time @@ -349,7 +370,7 @@ bfid pos lid tweakBody time = do let trunkKind = case itemDisco of Just ItemDisco{itemKind} -> itemKind - Nothing -> assert `failure` trunkFull + Nothing -> error $ "" `showFailure` trunkFull aspects = fromJust $ itemAspect $ fromJust itemDisco -- Initial HP and Calm is based only on trunk and ignores organs. hp = xM (max 2 $ aMaxHP aspects) `div` 2 @@ -397,7 +418,7 @@ itemFreq = [(ikText, 1)] mIidEtc <- rollAndRegisterItem lid itemFreq container False mk case mIidEtc of - Nothing -> assert `failure` (lid, itemFreq, container, mk) + Nothing -> error $ "" `showFailure` (lid, itemFreq, container, mk) Just (iid, (itemFull, _)) -> discoverIfNoEffects container iid itemFull return $ Just aid 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 @@ -68,14 +68,14 @@ serverPrint d data DebugAid a = DebugAid - { label :: !Text - , aid :: !ActorId - , cmd :: !a - , faction :: !FactionId - , lid :: !LevelId - , bHP :: !Int64 - , btime :: !Time - , time :: !Time + { label :: Text + , aid :: ActorId + , cmd :: a + , faction :: FactionId + , lid :: LevelId + , bHP :: Int64 + , btime :: Time + , time :: Time } deriving Show diff --git a/Game/LambdaHack/Server/DungeonGen.hs b/Game/LambdaHack/Server/DungeonGen.hs --- a/Game/LambdaHack/Server/DungeonGen.hs +++ b/Game/LambdaHack/Server/DungeonGen.hs @@ -94,13 +94,13 @@ nightCond kt = not (Tile.kindHasFeature TK.Walkable kt) || (if dnight then id else not) (Tile.kindHasFeature TK.Dark kt) - pickDefTile = - fromMaybe (assert `failure` cdefTile) <$> opick cdefTile nightCond + pickDefTile = fromMaybe (error $ "" `showFailure` cdefTile) + <$> opick cdefTile nightCond wcond kt = Tile.isEasyOpenKind kt && nightCond kt mpickPassable = if cpassable - then Just - $ fromMaybe (assert `failure` cdefTile) <$> opick cdefTile wcond + then Just $ fromMaybe (error $ "" `showFailure` cdefTile) + <$> opick cdefTile wcond else Nothing nwcond kt = not (Tile.kindHasFeature TK.Walkable kt) && nightCond kt areAllWalkable <- isNothing <$> opick cdefTile nwcond @@ -113,7 +113,8 @@ -> Rnd (Level, [Point]) buildLevel cops@Kind.COps{cocave=Kind.Ops{okind=okind, opick}} ln genName minD totalDepth lstairPrev = do - dkind <- fromMaybe (assert `failure` genName) <$> opick genName (const True) + dkind <- fromMaybe (error $ "" `showFailure` genName) + <$> opick genName (const True) let kc = okind dkind -- Simple rule for now: level @ln@ has depth (difficulty) @abs ln@. ldepth = AbsDepth $ abs ln @@ -233,8 +234,8 @@ -- | Freshly generated and not yet populated dungeon. data FreshDungeon = FreshDungeon - { freshDungeon :: !Dungeon -- ^ maps for all levels - , freshTotalDepth :: !AbsDepth -- ^ absolute dungeon depth + { freshDungeon :: Dungeon -- ^ maps for all levels + , freshTotalDepth :: AbsDepth -- ^ absolute dungeon depth } -- | Generate the dungeon for a new game. @@ -243,7 +244,7 @@ let (minD, maxD) = case (IM.minViewWithKey caves, IM.maxViewWithKey caves) of (Just ((s, _), _), Just ((e, _), _)) -> (s, e) - _ -> assert `failure` "no caves" `twith` caves + _ -> error $ "no caves" `showFailure` caves freshTotalDepth = assert (signum minD == signum maxD) $ AbsDepth $ max 10 $ max (abs minD) (abs maxD) diff --git a/Game/LambdaHack/Server/DungeonGen/Area.hs b/Game/LambdaHack/Server/DungeonGen/Area.hs --- a/Game/LambdaHack/Server/DungeonGen/Area.hs +++ b/Game/LambdaHack/Server/DungeonGen/Area.hs @@ -18,7 +18,7 @@ import Game.LambdaHack.Content.PlaceKind (PlaceKind) -- | The type of areas. The bottom left and the top right points. -data Area = Area !X !Y !X !Y +data Area = Area X Y X Y deriving (Show, Eq) -- | Checks if it's an area with at least one field. @@ -37,9 +37,9 @@ isTrivialArea (Area x0 y0 x1 y1) = x0 == x1 && y0 == y1 data SpecialArea = - SpecialArea !Area - | SpecialFixed !Point !(GroupName PlaceKind) !Area - | SpecialMerged !SpecialArea !Point + SpecialArea Area + | SpecialFixed Point (GroupName PlaceKind) Area + | SpecialMerged SpecialArea Point deriving Show -- | Divide uniformly a larger area into the given number of smaller areas @@ -67,7 +67,7 @@ ++ f z0 z1 n (c1 + len * (2 * cn - 1) `div` (2 * cn)) (c2 : rest) f _ z1 _ prev [c1] = [(prev, z1, Just c1)] - f _ _ _ _ [] = assert `failure` fixedCenters + f _ _ _ _ [] = error $ "empty list of centers" `showFailure` fixedCenters xcs = IS.toList $ IS.fromList $ map px $ EM.keys fixedCenters ++ boot xallCenters = zip [0..] $ f x0 x1 nx x0 xcs ycs = IS.toList $ IS.fromList $ map py $ EM.keys fixedCenters ++ boot @@ -104,7 +104,7 @@ Area x0 y0 x1' y1 | x0 == x1' -> assert (y0 == y0' && y1 == y1' `blame` (a, a')) $ Area x0' y0' x1 y1' - | otherwise -> assert `failure` (a, a') + | otherwise -> error $ "areas not adjacent" `showFailure` (a, a') instance Binary Area where put (Area x0 y0 x1 y1) = do diff --git a/Game/LambdaHack/Server/DungeonGen/AreaRnd.hs b/Game/LambdaHack/Server/DungeonGen/AreaRnd.hs --- a/Game/LambdaHack/Server/DungeonGen/AreaRnd.hs +++ b/Game/LambdaHack/Server/DungeonGen/AreaRnd.hs @@ -48,13 +48,13 @@ xspan = x1 - x0 + 1 yspan = y1 - y0 + 1 aW = (min xm xspan, min ym yspan, min xM xspan, min yM yspan) - areaW = fromMaybe (assert `failure` aW) $ toArea aW + areaW = fromMaybe (error $ "" `showFailure` aW) $ toArea aW Point xW yW <- xyInArea areaW -- roll size let a1 = (x0, y0, max x0 (x1 - xW + 1), max y0 (y1 - yW + 1)) - area1 = fromMaybe (assert `failure` a1) $ toArea a1 + area1 = fromMaybe (error $ "" `showFailure` a1) $ toArea a1 Point rx1 ry1 <- xyInArea area1 -- roll top-left corner let a3 = (rx1, ry1, rx1 + xW - 1, ry1 + yW - 1) - area3 = fromMaybe (assert `failure` a3) $ toArea a3 + area3 = fromMaybe (error $ "" `showFailure` a3) $ toArea a3 return $! area3 -- Doesn't respect minimum sizes, because staircases are specified verbatim, @@ -71,7 +71,7 @@ xradius = min ((xM + 1) `div` 2) $ min (px - x0) (x1 - px) yradius = min ((yM + 1) `div` 2) $ min (py - y0) (y1 - py) a = (px - xradius, py - yradius, px + xradius, py + yradius) - in fromMaybe (assert `failure` (a, xM, yM, area, p)) $ toArea a + in fromMaybe (error $ "" `showFailure` (a, xM, yM, area, p)) $ toArea a -- Choosing connections between areas in a grid @@ -194,7 +194,7 @@ 2 -> 1 3 -> 1 _ -> 3 - in fromMaybe (assert `failure` (area, s3, t3)) + in fromMaybe (error $ "" `showFailure` (area, s3, t3)) $ toArea (x0 + dx, y0 + dy, x1 - dx, y1 - dy) Point sx sy <- xyInArea $ trim sa Point tx ty <- xyInArea $ trim ta @@ -221,13 +221,13 @@ x1 = if tgy0 <= sy && sy <= tgy1 then tox0 - 1 else sgx1 in case toArea (x0, min sy ty, x1, max sy ty) of Just a -> (Horiz, a, Point (sax1 + 1) sy, Point (tax0 - 1) ty) - Nothing -> assert `failure` (sx, sy, tx, ty, s3, t3) + Nothing -> error $ "" `showFailure` (sx, sy, tx, ty, s3, t3) | otherwise = assert (sgy1 == tgy0) $ let y0 = if sgx0 <= tx && tx <= sgx1 then soy1 + 1 else sgy1 y1 = if tgx0 <= sx && sx <= tgx1 then toy0 - 1 else sgy1 in case toArea (min sx tx, y0, max sx tx, y1) of Just a -> (Vert, a, Point sx (say1 + 1), Point tx (tay0 - 1)) - Nothing -> assert `failure` (sx, sy, tx, ty, s3, t3) + Nothing -> error $ "" `showFailure` (sx, sy, tx, ty, s3, t3) nin p = not $ p `inside` fromArea sa || p `inside` fromArea ta !_A = assert (strivial || ttrivial || allB nin [p0, p1]`blame` (sx, sy, tx, ty, s3, t3)) () diff --git a/Game/LambdaHack/Server/DungeonGen/Cave.hs b/Game/LambdaHack/Server/DungeonGen/Cave.hs --- a/Game/LambdaHack/Server/DungeonGen/Cave.hs +++ b/Game/LambdaHack/Server/DungeonGen/Cave.hs @@ -27,11 +27,11 @@ -- | The type of caves (not yet inhabited dungeon levels). data Cave = Cave - { dkind :: !(Kind.Id CaveKind) -- ^ the kind of the cave - , dsecret :: !Int -- ^ secret tile seed - , dmap :: !TileMapEM -- ^ tile kinds in the cave - , dplaces :: ![Place] -- ^ places generated in the cave - , dnight :: !Bool -- ^ whether the cave is dark + { dkind :: Kind.Id CaveKind -- ^ the kind of the cave + , dsecret :: Int -- ^ secret tile seed + , dmap :: TileMapEM -- ^ tile kinds in the cave + , dplaces :: [Place] -- ^ places generated in the cave + , dnight :: Bool -- ^ whether the cave is dark } deriving Show @@ -78,13 +78,13 @@ -- Make sure that in caves not filled with rock, there is a passage -- across the cave, even if a single room blocks most of the cave. -- Also, ensure fancy outer fences are not obstructed by room walls. - let fullArea = fromMaybe (assert `failure` kc) + let fullArea = fromMaybe (error $ "" `showFailure` kc) $ toArea (0, 0, cxsize - 1, cysize - 1) - subFullArea = fromMaybe (assert `failure` kc) + subFullArea = fromMaybe (error $ "" `showFailure` kc) $ toArea (1, 1, cxsize - 2, cysize - 2) - darkCorTile <- fromMaybe (assert `failure` cdarkCorTile) + darkCorTile <- fromMaybe (error $ "" `showFailure` cdarkCorTile) <$> opick cdarkCorTile (const True) - litCorTile <- fromMaybe (assert `failure` clitCorTile) + litCorTile <- fromMaybe (error $ "" `showFailure` clitCorTile) <$> opick clitCorTile (const True) dnight <- chanceDice ldepth totalDepth cnightChance let createPlaces lgr' = do @@ -151,10 +151,10 @@ in case vics of [p2] -> mergeSpecial ar p2 (SpecialFixed p placeGroup) _ -> gs0 - SpecialMerged{} -> assert `failure` (gs, gs0, i) + SpecialMerged{} -> error $ "" `showFailure` (gs, gs0, i) gs2 = foldl' mergeFixed gs $ EM.assocs gs voidPlaces <- do - let gridArea = fromMaybe (assert `failure` lgr) + let gridArea = fromMaybe (error $ "" `showFailure` lgr) $ toArea (0, 0, gx - 1, gy - 1) voidNum = round $ cmaxVoid * fromIntegral (EM.size gs2) isOrdinaryArea p = case p `EM.lookup` gs2 of @@ -173,7 +173,7 @@ case special of SpecialArea ar -> do -- Reserved for corridors and the global fence. - let innerArea = fromMaybe (assert `failure` (i, ar)) + let innerArea = fromMaybe (error $ "" `showFailure` (i, ar)) $ shrink ar !_A0 = shrink innerArea !_A1 = assert (isJust _A0 `blame` (innerArea, gs2)) () @@ -192,7 +192,7 @@ , EM.insert i (qarea place, fence, ar) qls ) SpecialFixed p@Point{..} placeGroup ar -> do -- Reserved for corridors and the global fence. - let innerArea = fromMaybe (assert `failure` (i, ar)) + let innerArea = fromMaybe (error $ "" `showFailure` (i, ar)) $ shrink ar !_A0 = shrink innerArea !_A1 = assert (isJust _A0 `blame` (innerArea, gs2)) () diff --git a/Game/LambdaHack/Server/DungeonGen/Place.hs b/Game/LambdaHack/Server/DungeonGen/Place.hs --- a/Game/LambdaHack/Server/DungeonGen/Place.hs +++ b/Game/LambdaHack/Server/DungeonGen/Place.hs @@ -30,13 +30,13 @@ -- | The parameters of a place. All are immutable and set -- at the time when a place is generated. data Place = Place - { qkind :: !(Kind.Id PlaceKind) - , qarea :: !Area - , qseen :: !Bool - , qlegend :: !(GroupName TileKind) - , qFWall :: !(Kind.Id TileKind) - , qFFloor :: !(Kind.Id TileKind) - , qFGround :: !(Kind.Id TileKind) + { qkind :: Kind.Id PlaceKind + , qarea :: Area + , qseen :: Bool + , qlegend :: GroupName TileKind + , qFWall :: Kind.Id TileKind + , qFFloor :: Kind.Id TileKind + , qFGround :: Kind.Id TileKind } deriving Show @@ -88,7 +88,7 @@ in if pcover kr `elem` [CVerbatim, CMirror] then let (x0, y0, x1, y1) = fromArea r dx = case ptopLeft kr of - [] -> assert `failure` kr + [] -> error $ "" `showFailure` kr l : _ -> T.length l dy = length $ ptopLeft kr mx = (x1 - x0 + 1 - dx) `div` 2 @@ -99,7 +99,7 @@ else case requiredForFence of 0 -> Just r 1 -> shrink r - _ -> assert `failure` kr + _ -> error $ "" `showFailure` kr -- | Given a few parameters, roll and construct a 'Place' datastructure -- and fill a cave section acccording to it. @@ -119,7 +119,7 @@ CaveKind{..} dnight darkCorTile litCorTile ldepth@(AbsDepth ld) totalDepth@(AbsDepth depth) dsecret r mplaceGroup = do - qFWall <- fromMaybe (assert `failure` cfillerTile) + qFWall <- fromMaybe (error $ "" `showFailure` cfillerTile) <$> opick cfillerTile (const True) let findInterval x1y1 [] = (x1y1, (11, 0)) findInterval !x1y1 ((!x, !y) : rest) = @@ -153,7 +153,7 @@ qFGround = if dnight then darkCorTile else litCorTile qlegend = if dark then clegendDarkTile else clegendLitTile qseen = False - qarea = fromMaybe (assert `failure` (kr, r)) $ interiorArea kr r + qarea = fromMaybe (error $ "" `showFailure` (kr, r)) $ interiorArea kr r place = Place {..} (overrideOneIn, override) <- ooverride cops (poverride kr) (legendOneIn, legend) <- olegend cops qlegend @@ -180,8 +180,9 @@ Just (oneInChance, tk) -> if isChancePos oneInChance dsecret xy then tk - else EM.findWithDefault (assert `failure` (c, mOneIn, m)) c m - Nothing -> EM.findWithDefault (assert `failure` (c, mOneIn, m)) c m + else EM.findWithDefault (error $ "" `showFailure` (c, mOneIn, m)) c m + Nothing -> EM.findWithDefault (error $ "" `showFailure` (c, mOneIn, m)) + c m interior = case pfence kr of FNone | not dnight -> EM.mapWithKey digDay cmap _ -> EM.mapWithKey (lookupOneIn xlegend) cmap @@ -203,7 +204,7 @@ getLegend s !acc = do (mOneIn, m) <- acc let p f t = TK.tsymbol t == s && f (Tile.kindHasFeature TK.Spice t) - tk <- fmap (fromMaybe $ assert `failure` (cgroup, s)) + tk <- fmap (fromMaybe $ error $ "" `showFailure` (cgroup, s)) $ opick cgroup (p not) mtkSpice <- opick cgroup (p id) return $! case mtkSpice of @@ -223,7 +224,7 @@ let getLegend (s, cgroup) acc = do (mOneIn, m) <- acc mtkSpice <- opick cgroup (Tile.kindHasFeature TK.Spice) - tk <- fromMaybe (assert `failure` (s, cgroup, poverride)) + tk <- fromMaybe (error $ "" `showFailure` (s, cgroup, poverride)) <$> opick cgroup (not . Tile.kindHasFeature TK.Spice) return $! case mtkSpice of Nothing -> (mOneIn, EM.insert s tk m) @@ -251,7 +252,7 @@ let isCorner x y = x `elem` [x0-1, x1+1] && y `elem` [y0-1, y1+1] tileGroup | isCorner xf yf = "basic outer fence" | otherwise = couterFenceTile - fenceId <- fromMaybe (assert `failure` tileGroup) + fenceId <- fromMaybe (error $ "" `showFailure` tileGroup) <$> opick tileGroup (const True) return (Point xf yf, fenceId) pointList = [ (x, y) | x <- [x0-1, x1+1], y <- [y0..y1] ] @@ -268,7 +269,7 @@ xwidth = x1 - x0 + 1 ywidth = y1 - y0 + 1 dxcorner = case ptopLeft of - [] -> assert `failure` (area, pl) + [] -> error $ "" `showFailure` (area, pl) l : _ -> T.length l (dx, dy) = assert (xwidth >= dxcorner && ywidth >= length ptopLeft `blame` (area, pl)) @@ -295,12 +296,12 @@ interior <- case pcover of CAlternate -> do let tile :: Int -> [a] -> [a] - tile _ [] = assert `failure` "nothing to tile" `twith` pl + tile _ [] = error $ "nothing to tile" `showFailure` pl tile d pat = take d (cycle $ init pat ++ init (reverse pat)) return $! fillInterior tile tile CStretch -> do let stretch :: Int -> [a] -> [a] - stretch _ [] = assert `failure` "nothing to stretch" `twith` pl + stretch _ [] = error $ "nothing to stretch" `showFailure` pl stretch d pat = tileReflect d (pat ++ repeat (last pat)) return $! fillInterior stretch stretch CReflect -> do diff --git a/Game/LambdaHack/Server/Fov.hs b/Game/LambdaHack/Server/Fov.hs --- a/Game/LambdaHack/Server/Fov.hs +++ b/Game/LambdaHack/Server/Fov.hs @@ -57,7 +57,7 @@ -- * Perception cache types data FovValid a = - FovValid !a + FovValid a | FovInvalid deriving (Show, Eq) @@ -70,9 +70,9 @@ deriving (Show, Eq) data CacheBeforeLucid = CacheBeforeLucid - { creachable :: !PerReachable - , cnocto :: !PerVisible - , csmell :: !PerSmelled + { creachable :: PerReachable + , cnocto :: PerVisible + , csmell :: PerSmelled } deriving (Show, Eq) @@ -83,8 +83,8 @@ -- lights lit it). But this is complex and unions of EnumSets are cheaper -- than the EnumMaps that would be required. data PerceptionCache = PerceptionCache - { ptotal :: !(FovValid CacheBeforeLucid) - , perActor :: !PerActor + { ptotal :: FovValid CacheBeforeLucid + , perActor :: PerActor } deriving (Show, Eq) @@ -177,7 +177,7 @@ totalFromPerActor perActor = let as = map (\a -> case a of FovValid x -> x - FovInvalid -> assert `failure` perActor) + FovInvalid -> error $ "" `showFailure` perActor) $ EM.elems perActor in CacheBeforeLucid { creachable = PerReachable @@ -309,9 +309,9 @@ (sdungeon s) fovLucid lid = case EM.lookup lid fovLucidLid of Just (FovValid fl) -> fl - _ -> assert `failure` (lid, fovLucidLid) + _ -> error $ "" `showFailure` (lid, fovLucidLid) getValid (FovValid pc) = pc - getValid FovInvalid = assert `failure` fid + getValid FovInvalid = error $ "" `showFailure` fid in ( EM.mapWithKey (\lid pc -> perceptionFromPTotal (fovLucid lid) (getValid (ptotal pc))) em , em ) diff --git a/Game/LambdaHack/Server/FovDigital.hs b/Game/LambdaHack/Server/FovDigital.hs --- a/Game/LambdaHack/Server/FovDigital.hs +++ b/Game/LambdaHack/Server/FovDigital.hs @@ -39,13 +39,13 @@ -- coordinate setup, where quadrant I, with x and y positive, -- is on the upper right. data Bump = B - { bx :: !Int - , by :: !Int + { bx :: Int + , by :: Int } deriving Show -- | Straight line between points. -data Line = Line !Bump !Bump +data Line = Line Bump Bump deriving Show -- | Convex hull represented as a list of points. diff --git a/Game/LambdaHack/Server/HandleAtomicM.hs b/Game/LambdaHack/Server/HandleAtomicM.hs --- a/Game/LambdaHack/Server/HandleAtomicM.hs +++ b/Game/LambdaHack/Server/HandleAtomicM.hs @@ -211,21 +211,21 @@ actorHasShine :: ActorAspect -> ActorId -> Bool actorHasShine actorAspect aid = case EM.lookup aid actorAspect of Just AspectRecord{aShine} -> aShine > 0 - Nothing -> assert `failure` aid + Nothing -> error $ "" `showFailure` aid itemAffectsShineRadius :: DiscoveryAspect -> ItemId -> [CStore] -> Bool itemAffectsShineRadius discoAspect iid stores = (null stores || not (null $ intersect stores [CEqp, COrgan, CGround])) && case EM.lookup iid discoAspect of Just AspectRecord{aShine} -> aShine /= 0 - Nothing -> assert `failure` iid + Nothing -> error $ "" `showFailure` iid itemAffectsPerRadius :: DiscoveryAspect -> ItemId -> Bool itemAffectsPerRadius discoAspect iid = case EM.lookup iid discoAspect of Just AspectRecord{aSight, aSmell, aNocto} -> aSight /= 0 || aSmell /= 0 || aNocto /= 0 - Nothing -> assert `failure` iid + Nothing -> error $ "" `showFailure` iid addPerActor :: MonadServer m => ActorId -> Actor -> m () addPerActor aid b = do 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 @@ -90,7 +90,7 @@ meleePerformed <- applyMeleeDamage source target iid bag <- getsState $ getContainerBag c case iid `EM.lookup` bag of - Nothing -> assert `failure` (source, target, iid, c) + Nothing -> error $ "" `showFailure` (source, target, iid, c) Just kit -> do itemToF <- itemToFullServer let itemFull = itemToF iid kit @@ -98,7 +98,7 @@ Just ItemDisco {itemKind=IK.ItemKind{IK.ieffects}} -> effectAndDestroy meleePerformed source target iid c False ieffects itemFull - _ -> assert `failure` (source, target, iid, c) + _ -> error $ "" `showFailure` (source, target, iid, c) effectAndDestroy :: (MonadAtomic m, MonadServer m) => Bool -> ActorId -> ActorId -> ItemId -> Container -> Bool @@ -116,7 +116,7 @@ itemFull@ItemFull{..} = do let timeout = case itemDisco of Just ItemDisco{itemAspect=Just ar} -> aTimeout ar - _ -> assert `failure` itemDisco + _ -> error $ "" `showFailure` itemDisco lid <- getsState $ lidFromC container localTime <- getsState $ getLocalTime lid let it1 = let timeoutTurns = timeDeltaScale (Delta timeTurn) timeout @@ -150,6 +150,16 @@ triggeredEffect <- itemEffectDisco source target iid container recharged periodic effs let triggered = triggeredEffect || meleePerformed + sb <- getsState $ getActorBody source + -- Announce no effect, which is rare and wastes time, so noteworthy. + unless (triggered -- some effects triggered, so feedback comes from them + || periodic -- don't spam via fizzled periodic effects + || bproj sb -- don't spam, projectiles can be very numerous + ) $ + execSfxAtomic $ SfxMsgFid (bfid sb) $ + if any IK.forApplyEffect effs + then SfxFizzles -- something didn't work, despite promising effects + else SfxNothingHappens -- fully expected -- If none of item's effects was performed, we try to recreate the item. -- Regardless, we don't rewind the time, because some info is gained -- (that the item does not exhibit any effects in the given context). @@ -205,17 +215,8 @@ execUpdAtomic $ UpdDiscover c iid kmKind seed trs <- mapM (effectSem source target iid c recharged periodic) effs let triggered = or trs - sb <- getsState $ getActorBody source - -- Announce no effect, which is rare and wastes time, so noteworthy. - unless (triggered -- some effects triggered, so feedback comes from them - || periodic -- don't spam via fizzled periodic effects - || bproj sb -- don't spam, projectiles can be very numerous - || not (any IK.forApplyEffect effs) - -- no effects expected, so nothing to announce - ) $ - execSfxAtomic $ SfxMsgFid (bfid sb) SfxFizzles return triggered - _ -> assert `failure` (source, target, iid, item) + _ -> error $ "" `showFailure` (source, target, iid, item) -- | The source actor affects the target actor, with a given effect and power. -- Both actors are on the current level and can be the same actor. @@ -248,7 +249,8 @@ IK.Paralyze p -> effectParalyze execSfx p target IK.InsertMove p -> effectInsertMove execSfx p target IK.Teleport p -> effectTeleport execSfx p source target - IK.CreateItem store grp tim -> effectCreateItem Nothing target store grp tim + IK.CreateItem store grp tim -> + effectCreateItem (Just $ bfid sb) Nothing target store grp tim IK.DropItem n k store grp -> effectDropItem execSfx n k store grp target IK.PolyItem -> effectPolyItem execSfx source target IK.Identify -> effectIdentify execSfx iid source target @@ -287,7 +289,7 @@ let ar = actorAspect EM.! target hpMax = aMaxHP ar n <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm - let rawDeltaHP = - (fromIntegral $ xM n) + let rawDeltaHP = - xM n -- We ignore minor burns. serious = not (bproj tb) && source /= target && n > 1 deltaHP | serious = -- if HP overfull, at least cut back to max HP @@ -317,7 +319,7 @@ container = CActor target COrgan m2 <- rollAndRegisterItem (blid tb) itemFreq container False Nothing let (iid, (ItemFull{itemBase, itemK}, _)) = - fromMaybe (assert `failure` cgroup) m2 + fromMaybe (error $ "" `showFailure` cgroup) m2 Point x y = bpos tb semirandom = fromEnum (jkindIx itemBase) projectN k100 (n, _) = do @@ -502,7 +504,7 @@ isImpression iid = case EM.lookup (jkindIx $ getItem iid) discoKind of Just KindMean{kmKind} -> maybe False (> 0) $ lookup "impressed" $ IK.ifreq (okind kmKind) - Nothing -> assert `failure` iid + Nothing -> error $ "" `showFailure` iid dropAllImpressions = EM.filterWithKey (\iid _ -> not $ isImpression iid) borganNoImpression = dropAllImpressions $ borgan tb btime <- @@ -527,7 +529,7 @@ then return True -- avoid spam else do -- Add some nostalgia for the old faction. - void $ effectCreateItem (Just (bfid tb, 10)) target COrgan + void $ effectCreateItem (Just $ bfid tb) (Just 10) target COrgan "impressed" IK.TimerNone itemToF <- itemToFullServer let discoverIf (iid, cstore) = do @@ -555,7 +557,7 @@ return res | otherwise -> do execSfx - effectCreateItem (Just (bfid sb, 1)) target COrgan + effectCreateItem (Just $ bfid sb) (Just 1) target COrgan "impressed" IK.TimerNone -- ** Summon @@ -688,7 +690,7 @@ _ -> k == 2 -- moving a non-projectile friend unocc <- getsState posOcc case concatMap (\k -> filter (unocc k) ps) [0..3] of - [] -> assert `failure` ps + [] -> error $ "" `showFailure` ps posRes : _ -> return posRes switchLevels1 :: MonadAtomic m => (ActorId, Actor) -> m (Maybe ActorId) @@ -715,7 +717,7 @@ switchLevels2 lidNew posNew (aid, bOld) btime_bOld mlead = do let lidOld = blid bOld side = bfid bOld - let !_A = assert (lidNew /= lidOld `blame` "stairs looped" `twith` lidNew) () + let !_A = assert (lidNew /= lidOld `blame` "stairs looped" `swith` lidNew) () -- Sync actor's items' timeouts with the new local time of the level. -- We need to sync organs and equipment due to periodic activations, -- but also inventory pack (as well as some organs and equipment), @@ -866,10 +868,10 @@ -- ** CreateItem effectCreateItem :: (MonadAtomic m, MonadServer m) - => Maybe (FactionId, Int) -> ActorId -> CStore + => Maybe FactionId -> Maybe Int -> ActorId -> CStore -> GroupName ItemKind -> IK.TimerDice -> m Bool -effectCreateItem mfidSource target store grp tim = do +effectCreateItem jfidRaw mcount target store grp tim = do tb <- getsState $ getActorBody target delta <- case tim of IK.TimerNone -> return $ Delta timeZero @@ -889,16 +891,23 @@ let litemFreq = [(grp, 1)] -- Power depth of new items unaffected by number of spawned actors. m5 <- rollItem 0 (blid tb) litemFreq - let (itemKnownRaw, itemFullRaw, _, seed, _) = - fromMaybe (assert `failure` (blid tb, litemFreq, c)) m5 - (itemKnown, itemFull) = case mfidSource of - Just (fidSource, k) -> - let (kindIx, ar, damage, _) = itemKnownRaw - jfid = Just fidSource - in ( (kindIx, ar, damage, jfid) - , itemFullRaw { itemBase = (itemBase itemFullRaw) {jfid} - , itemK = k }) - Nothing -> (itemKnownRaw, itemFullRaw) + let (itemKnownRaw, itemFullRaw, itemDisco, seed, _) = + fromMaybe (error $ "" `showFailure` (blid tb, litemFreq, c)) m5 + -- Other code adds to @sdiscoBenefit@ only @iid@ and not any other items + -- that share the same @jkindIx@, so this is broken if such items + -- are not fully IDed from the start, so check that before risking a copy + -- of the same item, but with different @jfid@. + jfid = if store == COrgan + && IK.Identified `elem` IK.ifeature (itemKind itemDisco) + then jfidRaw + else Nothing + (itemKnown, itemFullFid) = + let (kindIx, ar, damage, _) = itemKnownRaw + in ( (kindIx, ar, damage, jfid) + , itemFullRaw {itemBase = (itemBase itemFullRaw) {jfid}} ) + itemFull = case mcount of + Just itemK -> itemFullFid {itemK} + Nothing -> itemFullFid itemRev <- getsServer sitemRev let mquant = case HM.lookup itemKnown itemRev of Nothing -> Nothing @@ -928,7 +937,7 @@ localTime <- getsState $ getLocalTime (blid tb) let newTimer = localTime `timeShift` delta (afterK, afterIt) = - fromMaybe (assert `failure` (iid, bagAfter, c)) + fromMaybe (error $ "" `showFailure` (iid, bagAfter, c)) (iid `EM.lookup` bagAfter) newIt = replicate afterK newTimer when (afterIt /= newIt) $ @@ -965,7 +974,7 @@ Just KindMean{kmKind} -> return $! maybe False (> 0) $ lookup grp $ IK.ifreq (okind kmKind) Nothing -> - assert `failure` (target, grp, iid, item) + error $ "" `showFailure` (target, grp, iid, item) assocsCStore <- getsState $ EM.assocs . getBodyStoreBag b store filterM hasGroup assocsCStore @@ -1037,8 +1046,9 @@ execSfx identifyIid iid c itemKindId execUpdAtomic $ UpdDestroyItem iid itemBase kit c - effectCreateItem Nothing target cstore "useful" IK.TimerNone - _ -> assert `failure` (target, iid, itemFull) + effectCreateItem (Just $ bfid sb) Nothing + target cstore "useful" IK.TimerNone + _ -> error $ "" `showFailure` (target, iid, itemFull) -- ** Identify @@ -1064,7 +1074,7 @@ execSfx identifyIid iid c itemKindId return True - _ -> assert `failure` (store, as) + _ -> error $ "" `showFailure` (store, as) tryStore stores = case stores of [] -> return False store : rest -> do @@ -1169,7 +1179,7 @@ -- ** SendFlying --- | Shend the target actor flying like a projectile. The arguments correspond +-- | Send the target actor flying like a projectile. The arguments correspond -- to @ToThrow@ and @Linger@ properties of items. If the actors are adjacent, -- the vector is directed outwards, if no, inwards, if it's the same actor, -- boldpos is used, if it can't, a random outward vector of length 10 @@ -1190,9 +1200,9 @@ execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxBracedImmune target return False else case bla lxsize lysize eps (bpos tb) fpos of - Nothing -> assert `failure` (fpos, tb) - Just [] -> assert `failure` "projecting from the edge of level" - `twith` (fpos, tb) + Nothing -> error $ "" `showFailure` (fpos, tb) + Just [] -> error $ "projecting from the edge of level" + `showFailure` (fpos, tb) Just (pos : rest) -> do let t = lvl `at` pos if not $ Tile.isWalkable coTileSpeedup t @@ -1201,26 +1211,23 @@ weightAssocs <- fullAssocsServer target [CInv, CEqp, COrgan] let weight = sum $ map (jweight . itemBase . snd) weightAssocs path = bpos tb : pos : rest - (trajectory, (speed, _)) = + (trajectory, (speed, range)) = computeTrajectory weight throwVelocity throwLinger path ts = Just (trajectory, speed) if null trajectory || btrajectory tb == ts || throwVelocity <= 0 || throwLinger <= 0 - then return False -- e.g., actor is too heavy; OK - else do - execSfx - execUpdAtomic $ UpdTrajectory target (btrajectory tb) ts - -- Give the actor one extra turn and also let the push start ASAP. - -- So, if the push lasts one (his) turn, he will not lose - -- any turn of movement (but he may need to retrace the push). - actorAspect <- getsServer sactorAspect - let ar = actorAspect EM.! target - actorTurn = ticksPerMeter $ bspeed tb ar - delta = timeDeltaScale actorTurn (-1) - modifyServer $ \ser -> - ser {sactorTime = ageActor (bfid tb) (blid tb) target delta - $ sactorTime ser} - return True + then return False -- e.g., actor is too heavy; OK + else do + execSfx + execUpdAtomic $ UpdTrajectory target (btrajectory tb) ts + -- Give the actor back all the time spent flying (speed * range) + -- and also let the push start ASAP. So, he will not lose + -- any turn of movement (but he may need to retrace the push). + let delta = timeDeltaScale (ticksPerMeter speed) (-range) + modifyServer $ \ser -> + ser {sactorTime = ageActor (bfid tb) (blid tb) target delta + $ sactorTime ser} + return True sendFlyingVector :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> Maybe Bool -> m Vector 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 @@ -141,7 +141,7 @@ `blame` (aidNew, bPre, fid, fact)) () !_A2 = assert (bfid bPre == fid `blame` "client tries to move other faction actors" - `twith` (aidNew, bPre, fid, fact)) () + `swith` (aidNew, bPre, fid, fact)) () let (autoDun, _) = autoDungeonLevel fact arena <- case mleader of Nothing -> return $! blid bPre @@ -271,7 +271,7 @@ upds <- generalMoveItem True iid2 k (CActor target CEqp) (CActor source CInv) mapM_ execUpdAtomic upds - err -> assert `failure` err + err -> error $ "" `showFailure` err -- Let the caught missile vanish, but don't remove its trajectory -- so that it doesn't pretend to be a non-projectile. execUpdAtomic $ UpdTrajectory target (btrajectory tb) @@ -343,7 +343,7 @@ -- Displacing requires full access. if Tile.isWalkable coTileSpeedup $ lvl `at` tpos then case posToAidsLvl tpos lvl of - [] -> assert `failure` (source, sb, target, tb) + [] -> error $ "" `showFailure` (source, sb, target, tb) [_] -> do execUpdAtomic $ UpdDisplaceActor source target -- We leave or wipe out smell, for consistency, but it's not @@ -390,8 +390,9 @@ -- Sometimes the tile is determined precisely by the ambient light -- of the source tiles. If not, default to cave day/night condition. mtoTile <- rndToAction $ opick tgroup nightCond - toTile <- maybe (rndToAction $ fromMaybe (assert `failure` tgroup) - <$> opick tgroup (const True)) + toTile <- maybe (rndToAction + $ fromMaybe (error $ "" `showFailure` tgroup) + <$> opick tgroup (const True)) return mtoTile unless (toTile == serverTile) $ do @@ -424,7 +425,7 @@ case groupsToAlterTo of [] -> return () [groupToAlterTo] -> changeTo groupToAlterTo - l -> assert `failure` "tile changeable in many ways" `twith` l + l -> error $ "tile changeable in many ways" `showFailure` l itemEffectEmbedded source tpos embeds else execFailure source req AlterBlockActor else execFailure source req AlterBlockItem @@ -500,7 +501,7 @@ Just rndT -> do bagAfter <- getsState $ getContainerBag toC let afterIt = case iid `EM.lookup` bagAfter of - Nothing -> assert `failure` (iid, bagAfter, toC) + Nothing -> error $ "" `showFailure` (iid, bagAfter, toC) Just (_, it2) -> it2 resetIt = beforeIt ++ replicate k rndT when (afterIt /= resetIt) $ @@ -517,7 +518,7 @@ let rndTurns = timeDeltaScale (Delta timeTurn) rndT return $ Just $ timeShift localTime rndTurns _ -> return Nothing - _ -> assert `failure` iid + _ -> error $ "" `showFailure` iid -- * ReqProject 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 @@ -111,8 +111,7 @@ case m5 of Nothing -> return Nothing Just (itemKnown, itemFullRaw, _, seed, itemGroup) -> do - let itemFull = itemFullRaw { itemK = fromMaybe (itemK itemFullRaw) mk - , itemBase = itemBase itemFullRaw } + let itemFull = itemFullRaw {itemK = fromMaybe (itemK itemFullRaw) mk} iid <- registerItem itemFull itemKnown seed container verbose return $ Just (iid, (itemFull, itemGroup)) 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 @@ -51,7 +51,7 @@ let kmMean = meanAspect $ okind kmKind in (EM.insert ix KindMean{..} ikMap, EM.insert kmKind ix ikRev, rest) f (ikMap, _, []) ik _ = - assert `failure` "too short ixs" `twith` (ik, ikMap) + error $ "too short ixs" `showFailure` (ik, ikMap) (discoS, discoRev, _) = ofoldlWithKey' f (EM.empty, EM.empty, shuffled) return (discoS, discoRev) @@ -122,8 +122,9 @@ itemK = max 1 itemN itemTimer = [timeZero | IK.Periodic `elem` IK.ieffects itemKind] -- delay first discharge of single organs - itemAspectMean = kmMean $ EM.findWithDefault (assert `failure` kindIx) - kindIx disco + itemAspectMean = + kmMean $ EM.findWithDefault (error $ "" `showFailure` kindIx) + kindIx disco itemDiscoData = ItemDisco { itemKindId, itemKind, itemAspectMean , itemAspect = Just aspectRecord } itemDisco = Just itemDiscoData @@ -162,7 +163,7 @@ proper = S.fromList flavours `S.intersection` available assert (not (S.null proper) `blame` "not enough flavours for items" - `twith` (flavours, available, ik, availableMap)) $ do + `swith` (flavours, available, ik, availableMap)) $ do flavour <- oneOf $ S.toList proper let availableReduced = S.delete flavour available return ( EM.insert key flavour assocs 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 @@ -21,7 +21,7 @@ import qualified Data.Ord as Ord import Game.LambdaHack.Atomic -import Game.LambdaHack.Client.UI (Config, SessionUI) +import Game.LambdaHack.Client (Config, SessionUI) import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.ClientOptions @@ -57,13 +57,13 @@ loopSer :: (MonadAtomic m, MonadServerReadRequest m) => DebugModeSer -- ^ server debug parameters -> Config - -> (Maybe SessionUI -> Kind.COps -> FactionId -> ChanServer -> IO ()) + -> (Maybe SessionUI -> FactionId -> ChanServer -> IO ()) -- ^ the code to run for UI clients -> m () loopSer sdebug sconfig executorClient = do -- Recover states and launch clients. cops <- getsState scops - let updConn = updateConn cops sconfig executorClient + let updConn = updateConn sconfig executorClient restored <- tryRestore cops sdebug case restored of Just (sRaw, ser) | not $ snewGameSer sdebug -> do -- a restored game @@ -114,7 +114,7 @@ let arenas = ES.toList $ ES.fromList $ catMaybes marenas !_A = assert (not (null arenas) `blame` "game over not caught earlier" - `twith` factionD) () + `swith` factionD) () return $! arenas handleFidUpd :: (MonadAtomic m, MonadServerReadRequest m) @@ -238,7 +238,7 @@ let isImpression iid = case EM.lookup (jkindIx $ getItem iid) discoKind of Just KindMean{kmKind} -> maybe False (> 0) (lookup "impressed" $ IK.ifreq $ okind kmKind) - Nothing -> assert `failure` iid + Nothing -> error $ "" `showFailure` iid impressions = EM.filterWithKey (\iid _ -> isImpression iid) $ borgan b dominated <- if bcalm b == 0 @@ -249,7 +249,7 @@ let f (_, (k, _)) = k maxImpression = maximumBy (Ord.comparing f) $ EM.assocs impressions in case jfid $ getItem $ fst maxImpression of - Nothing -> assert `failure` impressions + Nothing -> error $ "" `showFailure` impressions Just fid1 -> assert (fid1 /= bfid b) $ dominateFidSfx fid1 aid else return False unless dominated $ do @@ -282,7 +282,7 @@ -- Activate even if effects null, to possibly destroy item. effectAndDestroy False aid aid iid (CActor aid cstore) True (filterRecharging ieffects) itemFull - _ -> assert `failure` (aid, cstore, iid) + _ -> error $ "" `showFailure` (aid, cstore, iid) applyPeriodicActor (aid, b) = when (not (bproj b) && blid b `ES.member` arenasSet) $ do mapM_ (applyPeriodicItem aid COrgan borgan) $ EM.assocs $ borgan b @@ -373,7 +373,7 @@ -- Non-projectile actor stops flying. assert (not $ bproj b) $ execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing - _ -> assert `failure` "Nothing trajectory" `twith` (aid, b) + _ -> error $ "Nothing trajectory" `showFailure` (aid, b) handleActors :: (MonadAtomic m, MonadServerReadRequest m) => LevelId -> FactionId -> m Bool @@ -416,7 +416,7 @@ -- This is not proper UI-forced save, but a timeout, so don't save -- and no need to abort turn. modifyServer $ \ser -> ser {swriteSave = False} - _ -> assert `failure` cmdS + _ -> error $ "" `showFailure` cmdS let mswitchLeader :: Maybe ActorId -> m ActorId {-# NOINLINE mswitchLeader #-} mswitchLeader (Just aidNew) = switchLeader side aidNew >> return aidNew @@ -458,25 +458,25 @@ <- getsState $ perFidInDungeon discoAspect let !_A7 = assert (sfovLitLid == fovLitLid `blame` "wrong accumulated sfovLitLid" - `twith` (sfovLitLid, fovLitLid)) () + `swith` (sfovLitLid, fovLitLid)) () !_A6 = assert (sfovClearLid == fovClearLid `blame` "wrong accumulated sfovClearLid" - `twith` (sfovClearLid, fovClearLid)) () + `swith` (sfovClearLid, fovClearLid)) () !_A5 = assert (sactorAspect == actorAspect `blame` "wrong accumulated sactorAspect" - `twith` (sactorAspect, actorAspect)) () + `swith` (sactorAspect, actorAspect)) () !_A4 = assert (sfovLucidLid == fovLucidLid `blame` "wrong accumulated sfovLucidLid" - `twith` (sfovLucidLid, fovLucidLid)) () + `swith` (sfovLucidLid, fovLucidLid)) () !_A3 = assert (sperValidFid == perValidFid `blame` "wrong accumulated sperValidFid" - `twith` (sperValidFid, perValidFid)) () + `swith` (sperValidFid, perValidFid)) () !_A2 = assert (sperCacheFid == perCacheFid `blame` "wrong accumulated sperCacheFid" - `twith` (sperCacheFid, perCacheFid)) () + `swith` (sperCacheFid, perCacheFid)) () !_A1 = assert (sperFid == perFid `blame` "wrong accumulated perception" - `twith` (sperFid, perFid)) () + `swith` (sperFid, perFid)) () -- Kill all clients, including those that did not take part -- in the current game. -- Clients exit not now, but after they print all ending screens. 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 @@ -68,7 +68,7 @@ -> m (Maybe ActorId) addAnyActor actorFreq lid time mpos = do -- We bootstrap the actor by first creating the trunk of the actor's body - -- contains the constant properties. + -- that contains the constant properties. cops <- getsState scops lvl <- getLevel lid factionD <- getsState sfactionD @@ -76,7 +76,7 @@ m4 <- rollItem lvlSpawned lid actorFreq case m4 of Nothing -> return Nothing - Just (itemKnown, trunkFull, itemDisco, seed, _) -> do + Just (itemKnownRaw, itemFullRaw, itemDisco, seed, _) -> do let ik = itemKind itemDisco freqNames = map fst $ IK.ifreq ik f fact = fgroups (gplayer fact) @@ -100,21 +100,28 @@ Nothing -> do rollPos <- getsState $ rollSpawnPos cops allPers mobile lid lvl fid rndToAction rollPos - let container = CTrunk fid lid pos - trunkId <- registerItem trunkFull itemKnown seed container False - addActorIid trunkId trunkFull False fid pos lid id time + registerActor itemKnownRaw itemFullRaw itemDisco seed + fid pos lid id time rollSpawnPos :: Kind.COps -> ES.EnumSet Point -> Bool -> LevelId -> Level -> FactionId -> State -> Rnd Point rollSpawnPos Kind.COps{coTileSpeedup} visible - mobile lid lvl@Level{ltile, lxsize, lysize} fid s = do - let inhabitants = warActorRegularList fid lid s - distantSo df p _ = all (\b -> df $ chessDist (bpos b) p) inhabitants + mobile lid lvl@Level{ltile, lxsize, lysize, lstair} fid s = do + let -- Monsters try to harass enemies ASAP, instead of catching up from afar. + inhabitants = warActorRegularList fid lid s + nearInh df p = all (\b -> df $ chessDist (bpos b) p) inhabitants + -- Monsters often appear from deeper levels or at least we try + -- to suggest that. + deeperStairs = (if fromEnum lid > 0 then fst else snd) lstair + nearStairs df p = any (\pstair -> df $ chessDist pstair p) deeperStairs + -- I actors near deep stairs, risk if close enemy spawns is higher. + -- Also, spawns are common midway between actors and stairs. + distantSo df p _ = nearInh df p && nearStairs df p middlePos = Point (lxsize `div` 2) (lysize `div` 2) distantMiddle d p _ = chessDist p middlePos < d condList | mobile = - [ distantSo (<= 10) -- try hard to harass enemies + [ distantSo (<= 10) , distantSo (<= 15) , distantSo (<= 20) ] 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 @@ -29,7 +29,7 @@ import System.IO.Unsafe (unsafePerformIO) import Game.LambdaHack.Atomic -import Game.LambdaHack.Client.UI (Config, SessionUI, emptySessionUI) +import Game.LambdaHack.Client (Config, SessionUI, emptySessionUI) import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ClientOptions import Game.LambdaHack.Common.Faction @@ -76,7 +76,7 @@ if bench then return Nothing else do let prefix = ssavePrefixSer sdebugSer - fileName = prefix <.> Save.saveNameSer + fileName = prefix <> Save.saveNameSer cops res <- liftIO $ Save.restoreGame cops fileName let stdRuleset = Kind.stdRuleset corule cfgUIName = rcfgUIName stdRuleset @@ -160,12 +160,10 @@ -- Connect to clients in old or newly spawned threads -- that read and write directly to the channels. updateConn :: (MonadAtomic m, MonadServerReadRequest m) - => Kind.COps - -> Config - -> (Maybe SessionUI -> Kind.COps -> FactionId -> ChanServer - -> IO ()) + => Config + -> (Maybe SessionUI -> FactionId -> ChanServer -> IO ()) -> m () -updateConn cops sconfig executorClient = do +updateConn sconfig executorClient = do -- Prepare connections based on factions. oldD <- getDict let sess = emptySessionUI sconfig @@ -188,9 +186,9 @@ -- Spawn client threads. let toSpawn = newD EM.\\ oldD forkUI fid connS = - forkChild childrenServer $ executorClient (Just sess) cops fid connS + forkChild childrenServer $ executorClient (Just sess) fid connS forkAI fid connS = - forkChild childrenServer $ executorClient Nothing cops fid connS + forkChild childrenServer $ executorClient Nothing fid connS forkClient fid conn@ChanServer{requestUIS=Nothing} = -- When a connection is reused, clients are not respawned, -- even if UI usage changes, but it works OK thanks to UI faction 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 @@ -146,7 +146,7 @@ lUI <- mapM rawCreate $ filter (fhasUI . fst) $ rosterList players let !_A = assert (length lUI <= 1 `blame` "currently, at most one faction may have a UI" - `twith` lUI) () + `swith` lUI) () lnoUI <- mapM rawCreate $ filter (not . fhasUI . fst) $ rosterList players let lFs = reverse (zip [toEnum (-1), toEnum (-2)..] lnoUI) -- sorted ++ zip [toEnum 1..] lUI @@ -155,8 +155,8 @@ f (name1, name2) = case (findPlayerName name1 lFs, findPlayerName name2 lFs) of (Just (ix1, _), Just (ix2, _)) -> (ix1, ix2) - _ -> assert `failure` "unknown faction" - `twith` ((name1, name2), lFs) + _ -> error $ "unknown faction" + `showFailure` ((name1, name2), lFs) ixs = map f l -- Only symmetry is ensured, everything else is permitted, e.g., -- a faction in alliance with two others that are at war. @@ -200,7 +200,7 @@ rnd :: Rnd (FactionDict, FlavourMap, DiscoveryKind, DiscoveryKindRev, DungeonGen.FreshDungeon, Kind.Id ModeKind) rnd = do - modeKindId <- fromMaybe (assert `failure` gameMode) + modeKindId <- fromMaybe (error $ "" `showFailure` gameMode) <$> opick gameMode (const True) let mode = okind modeKindId automatePS ps = ps {rosterList = @@ -245,7 +245,7 @@ (minD, maxD) = case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of (Just ((s, _), _), Just ((e, _), _)) -> (s, e) - _ -> assert `failure` "empty dungeon" `twith` dungeon + _ -> error $ "empty dungeon" `showFailure` dungeon -- Players that escape go first to be started over stairs, if possible. valuePlayer pl = (not $ fcanEscape pl, fname pl) -- Sorting, to keep games from similar game modes mutually reproducible. @@ -290,8 +290,8 @@ forM_ ps $ \ (actorGroup, p) -> do maid <- addActor actorGroup fid3 p lid id ntime case maid of - Nothing -> assert `failure` "can't spawn initial actors" - `twith` (lid, (fid3, fact3)) + Nothing -> error $ "can't spawn initial actors" + `showFailure` (lid, (fid3, fact3)) Just aid -> do mleader <- getsState $ _gleader . (EM.! fid3) . sfactionD when (isNothing mleader) $ supplantLeader fid3 aid @@ -323,15 +323,13 @@ ds nps <- tryFind (np : ps) (n - 1) return $! np : nps - -- Prefer deeper stairs to avoid spawners ambushing explorers. - (deeperStairs, shallowerStairs) = - (if fromEnum lid > 0 then id else swap) lstair - stairPoss = if length deeperStairs > length shallowerStairs - then deeperStairs - else shallowerStairs + -- Only consider deeper stairs to avoid leaderless spawners that lurk near + -- their starting stairs ambushing explorers that enter the level, + -- unless the staircase has both sets of stairs. + deeperStairs = (if fromEnum lid > 0 then fst else snd) lstair middlePos = Point (lxsize `div` 2) (lysize `div` 2) let !_A = assert (k > 0 && factionDist > 0) () - onStairs = reverse $ take k $ lescape ++ stairPoss + onStairs = reverse $ take k $ lescape ++ deeperStairs nk = k - length onStairs -- Starting in the middle is too easy. found <- tryFind (middlePos : onStairs) nk 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 @@ -31,64 +31,64 @@ -- | Global, server state. data StateServer = StateServer - { sactorTime :: !ActorTime -- ^ absolute times of next actions - , sdiscoKind :: !DiscoveryKind -- ^ full item kind discoveries data - , sdiscoKindRev :: !DiscoveryKindRev -- ^ reverse map, used for item creation - , suniqueSet :: !UniqueSet -- ^ already generated unique items - , sdiscoAspect :: !DiscoveryAspect -- ^ full item aspect data - , 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 - , sicounter :: !ItemId -- ^ stores next item index - , snumSpawned :: !(EM.EnumMap LevelId Int) - , sundo :: ![CmdAtomic] -- ^ atomic commands performed to date - , sperFid :: !PerFid -- ^ perception of all factions - , sperValidFid :: !PerValidFid -- ^ perception validity for all factions - , sperCacheFid :: !PerCacheFid -- ^ perception cache of all factions - , sactorAspect :: !ActorAspect -- ^ full actor aspect data - , sfovLucidLid :: !FovLucidLid -- ^ ambient or shining light positions - , sfovClearLid :: !FovClearLid -- ^ clear tiles positions - , sfovLitLid :: !FovLitLid -- ^ ambient light positions - , sarenas :: ![LevelId] -- ^ active arenas - , svalidArenas :: !Bool -- ^ whether active arenas valid - , srandom :: !R.StdGen -- ^ current random generator - , srngs :: !RNGs -- ^ initial random generators - , squit :: !Bool -- ^ exit the game loop - , swriteSave :: !Bool -- ^ write savegame to a file now - , sdebugSer :: !DebugModeSer -- ^ current debugging mode - , sdebugNxt :: !DebugModeSer -- ^ debugging mode for the next game + { sactorTime :: ActorTime -- ^ absolute times of next actions + , sdiscoKind :: DiscoveryKind -- ^ full item kind discoveries data + , sdiscoKindRev :: DiscoveryKindRev -- ^ reverse map, used for item creation + , suniqueSet :: UniqueSet -- ^ already generated unique items + , sdiscoAspect :: DiscoveryAspect -- ^ full item aspect data + , 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 + , sicounter :: ItemId -- ^ stores next item index + , snumSpawned :: EM.EnumMap LevelId Int + , sundo :: [CmdAtomic] -- ^ atomic commands performed to date + , sperFid :: PerFid -- ^ perception of all factions + , sperValidFid :: PerValidFid -- ^ perception validity for all factions + , sperCacheFid :: PerCacheFid -- ^ perception cache of all factions + , sactorAspect :: ActorAspect -- ^ full actor aspect data + , sfovLucidLid :: FovLucidLid -- ^ ambient or shining light positions + , sfovClearLid :: FovClearLid -- ^ clear tiles positions + , sfovLitLid :: FovLitLid -- ^ ambient light positions + , sarenas :: [LevelId] -- ^ active arenas + , svalidArenas :: Bool -- ^ whether active arenas valid + , srandom :: R.StdGen -- ^ current random generator + , srngs :: RNGs -- ^ initial random generators + , squit :: Bool -- ^ exit the game loop + , swriteSave :: Bool -- ^ write savegame to a file now + , sdebugSer :: DebugModeSer -- ^ current debugging mode + , sdebugNxt :: DebugModeSer -- ^ debugging mode for the next game } deriving (Show) -- | Debug commands. See 'Server.debugArgs' for the descriptions. data DebugModeSer = DebugModeSer - { sknowMap :: !Bool - , sknowEvents :: !Bool - , sknowItems :: !Bool - , sniffIn :: !Bool - , sniffOut :: !Bool - , sallClear :: !Bool - , sboostRandomItem :: !Bool - , sgameMode :: !(Maybe (GroupName ModeKind)) - , sautomateAll :: !Bool - , skeepAutomated :: !Bool - , sdungeonRng :: !(Maybe R.StdGen) - , smainRng :: !(Maybe R.StdGen) - , snewGameSer :: !Bool - , scurChalSer :: !Challenge - , sdumpInitRngs :: !Bool - , ssavePrefixSer :: !String - , sdbgMsgSer :: !Bool - , sdebugCli :: !DebugModeCli + { sknowMap :: Bool + , sknowEvents :: Bool + , sknowItems :: Bool + , sniffIn :: Bool + , sniffOut :: Bool + , sallClear :: Bool + , sboostRandomItem :: Bool + , sgameMode :: Maybe (GroupName ModeKind) + , sautomateAll :: Bool + , skeepAutomated :: Bool + , sdungeonRng :: Maybe R.StdGen + , smainRng :: Maybe R.StdGen + , snewGameSer :: Bool + , scurChalSer :: Challenge + , sdumpInitRngs :: Bool + , ssavePrefixSer :: String + , sdbgMsgSer :: Bool + , sdebugCli :: DebugModeCli -- The client debug inside server debug only holds the client commandline -- options and is never updated with config options, etc. } deriving Show data RNGs = RNGs - { dungeonRandomGenerator :: !(Maybe R.StdGen) - , startingRandomGenerator :: !(Maybe R.StdGen) + { dungeonRandomGenerator :: Maybe R.StdGen + , startingRandomGenerator :: Maybe R.StdGen } instance Show RNGs where @@ -167,7 +167,7 @@ #else , sdumpInitRngs = False #endif - , ssavePrefixSer = "save" + , ssavePrefixSer = "" , sdbgMsgSer = False , sdebugCli = defDebugModeCli } diff --git a/GameDefinition/Content/CaveKind.hs b/GameDefinition/Content/CaveKind.hs --- a/GameDefinition/Content/CaveKind.hs +++ b/GameDefinition/Content/CaveKind.hs @@ -47,8 +47,8 @@ , chidden = 7 , cactorCoeff = 130 -- the maze requires time to explore , cactorFreq = [("monster", 60), ("animal", 40)] - , citemNum = 5 * d 5 - , citemFreq = [("useful", 50), ("treasure", 50)] + , citemNum = 6 * d 5 + , citemFreq = [("useful", 40), ("treasure", 60)] , cplaceFreq = [("rogue", 100)] , cpassable = False , cdefTile = "fillerWall" @@ -79,11 +79,12 @@ , chidden = 0 , cactorCoeff = 100 , cactorFreq = [("monster", 30), ("animal", 70)] - , citemNum = 4 * d 5 -- few rooms - , citemFreq = [("useful", 20), ("treasure", 30), ("any scroll", 50)] + , citemNum = 5 * d 5 -- few rooms + , citemFreq = [("useful", 20), ("treasure", 40), ("any scroll", 40)] , cplaceFreq = [("arena", 100)] , cpassable = True , cdefTile = "arenaSetLit" + , cdarkCorTile = "trailLit" -- let trails give off light , clitCorTile = "trailLit" } arena2 = arena @@ -92,10 +93,9 @@ , cdarkChance = 41 + d 10 -- almost all rooms lit (1 in 10 dark) -- Trails provide enough light for fun stealth. , cnightChance = 51 -- always night - , citemNum = 6 * d 5 -- rare, so make it exciting - , citemFreq = [("useful", 20), ("treasure", 30), ("any vial", 50)] + , citemNum = 7 * d 5 -- rare, so make it exciting + , citemFreq = [("useful", 20), ("treasure", 40), ("any vial", 40)] , cdefTile = "arenaSetDark" - , cdarkCorTile = "trailLit" -- let trails give off light } laboratory = arena2 { csymbol = 'L' @@ -111,11 +111,12 @@ , cdoorChance = 1 , copenChance = 1%2 , chidden = 7 - , citemNum = 6 * d 5 -- reward difficulty - , citemFreq = [("useful", 20), ("treasure", 30), ("any vial", 50)] + , citemNum = 7 * d 5 -- reward difficulty + , citemFreq = [("useful", 20), ("treasure", 40), ("any vial", 40)] , cplaceFreq = [("laboratory", 100)] , cpassable = False , cdefTile = "fillerWall" + , cdarkCorTile = "labTrailLit" -- let lab smoke give off light always , clitCorTile = "labTrailLit" } empty = rogue @@ -134,15 +135,15 @@ , cdoorChance = 0 , copenChance = 0 , chidden = 0 - , cactorCoeff = 10 - , cactorFreq = [("animal", 5), ("immobile animal", 95)] + , cactorCoeff = 8 + , cactorFreq = [("animal", 10), ("immobile animal", 90)] -- The healing geysers on lvl 3 act like HP resets. Needed to avoid -- cascading failure, if the particular starting conditions were -- very hard. Items are not reset, even if they are bad, which provides -- enough of a continuity. Gyesers on lvl 3 are not OP and can't be -- abused, because they spawn less and less often and also HP doesn't -- effectively accumulate over max. - , citemNum = 3 * d 5 -- few rooms and geysers are the boon + , citemNum = 4 * d 5 -- few rooms and geysers are the boon , cplaceFreq = [("empty", 100)] , cpassable = True , cdefTile = "emptySet" @@ -167,7 +168,7 @@ , chidden = 0 , cactorCoeff = 160 -- the maze requires time to explore , cactorFreq = [("monster", 80), ("animal", 20)] - , citemNum = 6 * d 5 -- an incentive to explore the labyrinth + , citemNum = 7 * d 5 -- an incentive to explore the labyrinth , cpassable = True , cplaceFreq = [("noise", 100)] , cdefTile = "noiseSet" @@ -179,7 +180,7 @@ { cname = "Frozen derelict mine" , cfreq = [("caveNoise2", 1)] , cnightChance = 51 -- easier variant, but looks sinister - , citemNum = 12 * d 5 -- an incentive to explore the final labyrinth + , citemNum = 13 * d 5 -- an incentive to explore the final labyrinth , cplaceFreq = [("noise", 1), ("mine", 99)] , cstairFreq = [("gated staircase", 100)] } @@ -204,7 +205,7 @@ , cfreq = [("caveRaid", 1)] , cdarkChance = 0 -- all rooms lit, for a gentle start , cmaxVoid = 1%10 - , cactorCoeff = 1000 -- deep level with no kit, so slow spawning + , cactorCoeff = 500 -- deep level with no kit, so slow spawning , cactorFreq = [("animal", 100)] , citemNum = 6 * d 8 -- just one level, hard enemies, treasure , citemFreq = [("useful", 33), ("gem", 33), ("currency", 33)] @@ -285,7 +286,7 @@ , cextraStairs = 1 , chidden = 0 , cactorFreq = [] - , citemNum = 5 * d 8 + , citemNum = 6 * d 8 , citemFreq = [ ("useful", 30), ("treasure", 30), ("gem", 100) , ("weak arrow", 500), ("harpoon", 400) ] , cplaceFreq = [("park", 100)] -- the same rooms as in ambush diff --git a/GameDefinition/Content/ItemKind.hs b/GameDefinition/Content/ItemKind.hs --- a/GameDefinition/Content/ItemKind.hs +++ b/GameDefinition/Content/ItemKind.hs @@ -43,14 +43,14 @@ -- * Item group symbols, partially from Nethack -symbolProjectile, _symbolLauncher, symbolLight, symbolTool, symbolGem, symbolGold, symbolNecklace, symbolRing, symbolPotion, symbolFlask, symbolScroll, symbolTorsoArmor, symbolMiscArmor, _symbolClothes, symbolShield, symbolPolearm, symbolEdged, symbolHafted, symbolWand, _symbolStaff, _symbolFood :: Char +symbolProjectile, _symbolLauncher, symbolLight, symbolTool, symbolSpecial, symbolGold, symbolNecklace, symbolRing, symbolPotion, symbolFlask, symbolScroll, symbolTorsoArmor, symbolMiscArmor, _symbolClothes, symbolShield, symbolPolearm, symbolEdged, symbolHafted, symbolWand, _symbolStaff, symbolFood :: Char symbolProjectile = '|' _symbolLauncher = '}' symbolLight = '(' symbolTool = '(' -symbolGem = '*' -symbolGold = '$' +symbolSpecial = '*' -- don't overuse, because it clashes with projectiles +symbolGold = '$' -- also gems symbolNecklace = '"' symbolRing = '=' symbolPotion = '!' -- concoction, bottle, jar, vial, canister @@ -65,7 +65,7 @@ symbolHafted = ')' symbolWand = '/' -- magical rod, transmitter, pistol, rifle _symbolStaff = '_' -- scanner -_symbolFood = ',' -- distinct from floor, because middle dots used +symbolFood = ',' -- also body part; distinct from floor: not middle dot -- * Thrown weapons @@ -368,7 +368,7 @@ { irarity = [(10, 2)] , ieffects = [ ELabel "of smelly concoction" , toOrganActorTurn "keen-smelling" (40 + d 10) - , DetectActor 5 + , DetectActor 10 , OnSmash (Explode "smelly droplet") ] } flask11 = flask @@ -479,8 +479,9 @@ , ieffects = [ RefillHP 10, DropItem 1 maxBound COrgan "poisoned" , OnSmash (Explode "healing mist 2") ] } -potion5 = potion - { ieffects = [ OneOf [ RefillHP 10, RefillHP 5, Burn 5 +potion5 = potion -- needs to be common to show at least a portion of effects + { irarity = [(1, 30), (10, 15)] + , ieffects = [ OneOf [ RefillHP 10, RefillHP 5, Burn 5 , toOrganActorTurn "strengthened" (20 + d 5) ] , OnSmash (OneOf [ Explode "dense shower" , Explode "sparse shower" @@ -489,8 +490,8 @@ , Explode "PhD defense question" , Explode "blast 10" ]) ] } -potion6 = potion - { irarity = [(3, 2), (10, 5)] +potion6 = potion -- needs to be common to show at least a portion of effects + { irarity = [(1, 5), (10, 20)] , ieffects = [ Impress , OneOf [ RefillCalm (-60) , RefillHP 20, RefillHP 10, Burn 10 @@ -554,23 +555,24 @@ } scroll2 = scroll { irarity = [(1, 2)] - , ieffects = [ ELabel "of greed", Teleport 20, DetectItem 10 + , ieffects = [ ELabel "of greed", Teleport 20, DetectItem 20 , RefillCalm (-100) ] } scroll3 = scroll { irarity = [(1, 4), (10, 2)] , ieffects = [Ascend False] } -scroll4 = scroll - { ieffects = [OneOf [ Teleport 5, RefillCalm 5, InsertMove 5 - , DetectActor 10, DetectItem 10 ]] +scroll4 = scroll -- needs to be common to show at least a portion of effects + { irarity = [(1, 40), (10, 20)] + , ieffects = [OneOf [ Teleport 5, RefillCalm 5, InsertMove 5 + , DetectActor 20, DetectItem 20 ]] } -scroll5 = scroll - { irarity = [(10, 14)] +scroll5 = scroll -- needs to be common to show at least a portion of effects + { irarity = [(10, 30)] , ieffects = [ Impress , OneOf [ Teleport 20, Ascend False, Ascend True , Summon "hero" 1, Summon "mobile animal" 2 - , Detect 20, RefillCalm (-100) + , Detect 40, RefillCalm (-100) , CreateItem CGround "useful" TimerNone ] ] } scroll6 = scroll @@ -584,7 +586,8 @@ , ieffects = [InsertMove $ 1 + d 2 + dl 2] } scroll9 = scroll - { ieffects = [ELabel "of scientific explanation", Identify] + { irarity = [(1, 30)] + , ieffects = [ELabel "of scientific explanation", Identify] } scroll10 = scroll { irarity = [(10, 20)] @@ -598,10 +601,10 @@ } scroll12 = scroll { irarity = [(1, 9), (10, 4)] - , ieffects = [DetectHidden 10] + , ieffects = [DetectHidden 20] } scroll13 = scroll - { ieffects = [ELabel "of acute hearing", DetectActor 7] + { ieffects = [ELabel "of acute hearing", DetectActor 20] } -- * Assorted tools @@ -639,7 +642,7 @@ , ikit = [] } seeingItem = ItemKind - { isymbol = '%' + { isymbol = symbolFood , iname = "pupil" , ifreq = [("useful", 30)] -- spooky and wierd, so rare , iflavour = zipPlain [Red] @@ -1029,7 +1032,7 @@ , ifreq = [("useful", 100), ("starting weapon", 100)] , iflavour = zipPlain [BrCyan] , icount = 1 - , irarity = [(1, 40), (5, 1)] + , irarity = [(1, 50), (3, 1)] , iverbHit = "stab" , iweight = 800 , idamage = toDmg $ 6 * d 1 @@ -1115,7 +1118,7 @@ , irarity = [(5, 1), (10, 6)] , iaspects = [Timeout $ d 4 + 5 - dl 4 |*| 2] , ieffects = ieffects sword - ++ [Unique, Recharging Impress, Recharging (DetectActor 3)] + ++ [Unique, Recharging Impress, Recharging (DetectActor 5)] , idesc = "A particularly well-balance blade, lending itself to impressive shows of fencing skill. Master sees enemies reflected on its mirror-like surface." } swordNullify = sword @@ -1188,7 +1191,7 @@ -- * Treasure gem = ItemKind - { isymbol = symbolGem + { isymbol = symbolGold , iname = "gem" , ifreq = [("treasure", 100), ("gem", 100)] , iflavour = zipPlain $ delete BrYellow brightCol -- natural, so not fancy @@ -1206,19 +1209,20 @@ , ikit = [] } gem1 = gem - { irarity = [(3, 0), (10, 12)] + { irarity = [(3, 0), (10, 24)] } gem2 = gem - { irarity = [(5, 0), (10, 14)] + { irarity = [(5, 0), (10, 28)] } gem3 = gem - { irarity = [(7, 0), (10, 16)] + { irarity = [(7, 0), (10, 32)] } gem4 = gem - { irarity = [(9, 0), (10, 50)] + { irarity = [(9, 0), (10, 100)] } gem5 = gem - { iname = "elixir" + { isymbol = symbolSpecial + , iname = "elixir" , iflavour = zipPlain [BrYellow] , irarity = [(1, 40), (10, 40)] , iaspects = [] diff --git a/GameDefinition/Content/ItemKindActor.hs b/GameDefinition/Content/ItemKindActor.hs --- a/GameDefinition/Content/ItemKindActor.hs +++ b/GameDefinition/Content/ItemKindActor.hs @@ -330,7 +330,7 @@ , ifreq = [("animal", 100), ("mobile", 1), ("mobile animal", 100)] , iflavour = zipPlain [Brown] , icount = 1 - , irarity = [(4, 1), (10, 7)] + , irarity = [(5, 1), (10, 12)] , iverbHit = "thud" , iweight = 80000 , idamage = toDmg 0 @@ -463,10 +463,10 @@ thornbush = ItemKind { isymbol = 't' , iname = "thornbush" - , ifreq = [("animal", 50), ("immobile animal", 100)] + , ifreq = [("animal", 20), ("immobile animal", 30)] , iflavour = zipPlain [Brown] , icount = 1 - , irarity = [(1, 2)] + , irarity = [(1, 10)] , iverbHit = "thud" , iweight = 80000 , idamage = toDmg 0 @@ -480,10 +480,10 @@ geyserBoiling = ItemKind { isymbol = 'g' , iname = "geyser" - , ifreq = [("animal", 50), ("immobile animal", 90)] + , ifreq = [("animal", 30), ("immobile animal", 60)] , iflavour = zipPlain [Blue] , icount = 1 - , irarity = [(5, 2)] + , irarity = [(1, 3), (5, 3)] , iverbHit = "thud" , iweight = 80000 , idamage = toDmg 0 @@ -498,10 +498,10 @@ geyserArsenic = ItemKind { isymbol = 'g' , iname = "arsenic geyser" - , ifreq = [("animal", 50), ("immobile animal", 120)] + , ifreq = [("animal", 10), ("immobile animal", 40)] , iflavour = zipPlain [Cyan] , icount = 1 - , irarity = [(5, 2)] + , irarity = [(1, 10), (5, 10)] , iverbHit = "thud" , iweight = 80000 , idamage = toDmg 0 @@ -516,10 +516,10 @@ geyserSulfur = ItemKind { isymbol = 'g' , iname = "sulfur geyser" - , ifreq = [("animal", 50), ("immobile animal", 270)] + , ifreq = [("animal", 10), ("immobile animal", 100)] , iflavour = zipPlain [BrYellow] -- exception, animal with bright color , icount = 1 - , irarity = [(5, 2)] + , irarity = [(1, 10), (5, 10)] , iverbHit = "thud" , iweight = 80000 , idamage = toDmg 0 diff --git a/GameDefinition/Content/ItemKindBlast.hs b/GameDefinition/Content/ItemKindBlast.hs --- a/GameDefinition/Content/ItemKindBlast.hs +++ b/GameDefinition/Content/ItemKindBlast.hs @@ -83,11 +83,10 @@ , iaspects = [AddShine $ intToDice $ n `div` 2] , ieffects = [ RefillCalm (-1) | n >= 5 ] ++ [ DropBestWeapon | n >= 5] - ++ [ OnSmash (Explode $ toGroupName - $ "firecracker" <+> tshow (n - 1)) + ++ [ OnSmash $ Explode + $ toGroupName $ "firecracker" <+> tshow (n - 1) | n > 2 ] - , ifeature = [ ToThrow $ ThrowMod (5 + 3 * n) (10 + 100 `div` n) - , Fragile, Identified ] + , ifeature = [toVelocity 5, Fragile, Identified] , idesc = "" , ikit = [] } @@ -138,7 +137,7 @@ { isymbol = '`' , iname = "mist" , ifreq = [("calming mist", 1)] - , iflavour = zipFancy [White] + , iflavour = zipFancy [BrGreen] , icount = 8 , irarity = [(1, 1)] , iverbHit = "sooth" @@ -170,7 +169,7 @@ { isymbol = '`' , iname = "mist" -- powerful, so slow and narrow , ifreq = [("healing mist", 1)] - , iflavour = zipFancy [White] + , iflavour = zipFancy [BrGreen] , icount = 8 , irarity = [(1, 1)] , iverbHit = "revitalize" @@ -186,7 +185,7 @@ { isymbol = '`' , iname = "mist" , ifreq = [("healing mist 2", 1)] - , iflavour = zipFancy [White] + , iflavour = zipFancy [BrGreen] , icount = 8 , irarity = [(1, 1)] , iverbHit = "revitalize" @@ -202,7 +201,7 @@ { isymbol = '`' , iname = "mist" , ifreq = [("wounding mist", 1)] - , iflavour = zipFancy [White] + , iflavour = zipFancy [BrRed] , icount = 8 , irarity = [(1, 1)] , iverbHit = "devitalize" @@ -282,7 +281,7 @@ { isymbol = '*' , iname = "hoof glue" , ifreq = [("glue", 1)] - , iflavour = zipPlain [BrYellow] + , iflavour = zipPlain [Cyan] , icount = 16 , irarity = [(1, 1)] , iverbHit = "glue" @@ -298,7 +297,7 @@ { isymbol = '`' , iname = "single spark" , ifreq = [("single spark", 1)] - , iflavour = zipPlain [BrYellow] + , iflavour = zipPlain [BrWhite] , icount = 1 , irarity = [(1, 1)] , iverbHit = "spark" @@ -314,7 +313,7 @@ { isymbol = '`' , iname = "spark" , ifreq = [("spark", 1)] - , iflavour = zipPlain [BrYellow] + , iflavour = zipPlain [BrWhite] , icount = 16 , irarity = [(1, 1)] , iverbHit = "scorch" @@ -337,7 +336,7 @@ { isymbol = '`' , iname = "dense shower" , ifreq = [("dense shower", 1)] - , iflavour = zipFancy [Red] + , iflavour = zipFancy [Green] , icount = 16 , irarity = [(1, 1)] , iverbHit = "strengthen" @@ -353,7 +352,7 @@ { isymbol = '`' , iname = "sparse shower" , ifreq = [("sparse shower", 1)] - , iflavour = zipFancy [Blue] + , iflavour = zipFancy [Red] , icount = 16 , irarity = [(1, 1)] , iverbHit = "weaken" @@ -434,7 +433,7 @@ { isymbol = '`' , iname = "haste spray" , ifreq = [("haste spray", 1)] - , iflavour = zipPlain [BrRed] + , iflavour = zipPlain [BrYellow] , icount = 16 , irarity = [(1, 1)] , iverbHit = "haste" @@ -466,7 +465,7 @@ { isymbol = '`' , iname = "eye drop" , ifreq = [("eye drop", 1)] - , iflavour = zipPlain [BrGreen] + , iflavour = zipPlain [BrCyan] , icount = 16 , irarity = [(1, 1)] , iverbHit = "cleanse" @@ -514,7 +513,7 @@ { isymbol = '`' , iname = "eye shine" , ifreq = [("eye shine", 1)] - , iflavour = zipPlain [BrRed] + , iflavour = zipPlain [Cyan] , icount = 16 , irarity = [(1, 1)] , iverbHit = "smear" @@ -581,7 +580,7 @@ { isymbol = '`' , iname = "poison cloud" , ifreq = [("poison cloud", 1)] - , iflavour = zipPlain [Green] + , iflavour = zipPlain [BrMagenta] , icount = 16 , irarity = [(1, 1)] , iverbHit = "poison" @@ -597,7 +596,7 @@ { isymbol = '`' , iname = "mist" , ifreq = [("anti-slow mist", 1)] - , iflavour = zipPlain [BrRed] + , iflavour = zipPlain [BrYellow] , icount = 8 , irarity = [(1, 1)] , iverbHit = "propel" diff --git a/GameDefinition/Content/ItemKindOrgan.hs b/GameDefinition/Content/ItemKindOrgan.hs --- a/GameDefinition/Content/ItemKindOrgan.hs +++ b/GameDefinition/Content/ItemKindOrgan.hs @@ -29,7 +29,7 @@ -- * Human weapon organs fist = ItemKind - { isymbol = '%' + { isymbol = ',' , iname = "fist" , ifreq = [("fist", 100)] , iflavour = zipPlain [Red] @@ -128,8 +128,7 @@ , ifreq = [("thorn", 100)] , icount = 2 + d 3 , iverbHit = "impale" - , idamage = toDmg $ 1 * d 1 - , ieffects = [RefillHP (-2)] + , idamage = toDmg $ 1 * d 3 , ifeature = [Identified, Meleeable] -- not Durable , idesc = "" } @@ -225,7 +224,7 @@ -- * Armor organs armoredSkin = ItemKind - { isymbol = '%' + { isymbol = ',' , iname = "armored skin" , ifreq = [("armored skin", 100)] , iflavour = zipPlain [Red] diff --git a/GameDefinition/Content/RuleKind.hs b/GameDefinition/Content/RuleKind.hs --- a/GameDefinition/Content/RuleKind.hs +++ b/GameDefinition/Content/RuleKind.hs @@ -63,6 +63,6 @@ , rfirstDeathEnds = False , rwriteSaveClips = 1000 , rleadLevelClips = 50 - , rscoresFile = "scores" + , rscoresFile = "LambdaHack.scores" , rnearby = 20 } diff --git a/GameDefinition/PLAYING.md b/GameDefinition/PLAYING.md --- a/GameDefinition/PLAYING.md +++ b/GameDefinition/PLAYING.md @@ -16,7 +16,12 @@ for this rudimentary example game, but it has its own quirky style and is playable and winnable. Contributions are welcome. +If the game window is too large for your screen or you experience +other technical issues, please consult +[README.md](https://github.com/LambdaHack/LambdaHack/blob/master/README.md) +or describe your problem on gitter or the issue tracker. + Heroes ------ @@ -191,8 +196,8 @@ as explained in section [Heroes](#heroes) above. Commands for saving and exiting the current game, starting a new game, -setting options for the current game and challenges for the next game, etc., -are listed in the Main Menu, brought up by the `ESC` key. +configuring convenience settings for the current game and challenges +for the next game are listed in the Main Menu, brought up by the `ESC` key. Game difficulty, from the challenges menu, determines hitpoints at birth for any actor of any UI-using faction. The "lone wolf" challenge mode reduces player's starting actors to exactly @@ -262,8 +267,11 @@ The displayed figures are rounded, but the game internally keeps track of minute fractions of HP. +The stress of combat drains Calm, gradually limiting the use of items and, +if Calm reaches zero and the actor is sufficiently impressed by his foes, +making him defect and surrender to their domination. Whenever the monster's or hero's hit points reach zero, the combatant dies. -When the last hero dies, the scenario ends in defeat. +When the last hero dies or is dominated, the scenario ends in defeat. On Winning and Dying diff --git a/GameDefinition/TieKnot.hs b/GameDefinition/TieKnot.hs --- a/GameDefinition/TieKnot.hs +++ b/GameDefinition/TieKnot.hs @@ -62,7 +62,7 @@ let (r, _) = R.randomR (0, length l - 1) initialGen in case splitAt r l of (pre, i : post) -> pre ++ boostItem i : post - _ -> assert `failure` l + _ -> error $ "" `showFailure` l boostedItems = boostList Content.ItemKind.items cdefsItem = Content.ItemKind.cdefs diff --git a/LambdaHack.cabal b/LambdaHack.cabal --- a/LambdaHack.cabal +++ b/LambdaHack.cabal @@ -5,7 +5,7 @@ -- PVP summary:+-+------- breaking API changes -- | | +----- minor or non-breaking API additions -- | | | +--- code changes with no API change -version: 0.6.1.0 +version: 0.6.2.0 synopsis: A game engine library for roguelike dungeon crawlers description: LambdaHack is a Haskell game engine library for roguelike games of arbitrary theme, size and complexity, @@ -60,7 +60,7 @@ bug-reports: http://github.com/LambdaHack/LambdaHack/issues license: BSD3 license-file: LICENSE -tested-with: GHC >= 7.10 && <= 8.2 +tested-with: GHC >= 8.0 && <= 8.2 data-files: GameDefinition/config.ui.default, GameDefinition/fonts/16x16x.fon, GameDefinition/fonts/8x8xb.fon, @@ -244,9 +244,9 @@ other-modules: Paths_LambdaHack build-depends: - assert-failure >= 0.1, + assert-failure >= 0.1.2 && < 0.2, async >= 2, - base >= 4 && < 99, + base >= 4.9 && < 99, base-compat >= 0.8.0, binary >= 0.8, bytestring >= 0.9.2 , @@ -267,23 +267,23 @@ text >= 0.11.2.3, transformers >= 0.4, unordered-containers >= 0.2.3, - vector >= 0.10, + vector >= 0.11, vector-binary-instances >= 0.2.3.1 default-language: Haskell2010 default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings BangPatterns, RecordWildCards, NamedFieldPuns, MultiWayIf, - CPP + StrictData, CPP other-extensions: TemplateHaskell, MultiParamTypeClasses, RankNTypes, TypeFamilies, FlexibleContexts, FlexibleInstances, DeriveFunctor, FunctionalDependencies, GeneralizedNewtypeDeriving, TupleSections, DeriveFoldable, DeriveTraversable, ExistentialQuantification, GADTs, StandaloneDeriving, - DataKinds, KindSignatures ---, DeriveGeneric - ghc-options: -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-unrecognised-pragmas - ghc-options: -fno-warn-implicit-prelude -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively + DataKinds, KindSignatures, DeriveGeneric + ghc-options: -Wall -Wcompat -Worphans -Wincomplete-uni-patterns -Wincomplete-record-updates -Wimplicit-prelude -Wmissing-home-modules -Widentities + ghc-options: -Wall-missed-specialisations + ghc-options: -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively if impl(ghcjs) { other-modules: Game.LambdaHack.Client.UI.Frontend.Dom @@ -349,9 +349,9 @@ build-depends: LambdaHack, template-haskell >= 2.6, - assert-failure >= 0.1, + assert-failure >= 0.1.2 && < 0.2, async >= 2, - base >= 4 && < 99, + base >= 4.9 && < 99, base-compat >= 0.8.0, binary >= 0.8, bytestring >= 0.9.2 , @@ -372,15 +372,17 @@ text >= 0.11.2.3, transformers >= 0.4, unordered-containers >= 0.2.3, - vector >= 0.10, + vector >= 0.11, vector-binary-instances >= 0.2.3.1 default-language: Haskell2010 default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings - BangPatterns, RecordWildCards, NamedFieldPuns, MultiWayIf + BangPatterns, RecordWildCards, NamedFieldPuns, MultiWayIf, + StrictData other-extensions: TemplateHaskell - ghc-options: -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-unrecognised-pragmas - ghc-options: -fno-warn-implicit-prelude -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively + ghc-options: -Wall -Wcompat -Worphans -Wincomplete-uni-patterns -Wincomplete-record-updates -Wimplicit-prelude -Wmissing-home-modules -Widentities + ghc-options: -Wall-missed-specialisations + ghc-options: -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively ghc-options: -threaded -rtsopts if impl(ghcjs) { @@ -395,7 +397,7 @@ build-depends: zlib >= 0.5.3.1 -- The -A options makes it slightly faster, especially with short sessions: ghc-options: "-with-rtsopts=-A99m -K1000K" --- TODO: get back to -K1K when I can use pretty-1.1.3.4 (TH depends on an old one) +-- TODO: get back to -K1K when I can use pretty-1.1.3.4 (TH depends on an old one), that is, when I can drop GHC 8.0.2 and older } test-suite test @@ -420,9 +422,9 @@ build-depends: LambdaHack, template-haskell >= 2.6, - assert-failure >= 0.1, + assert-failure >= 0.1.2 && < 0.2, async >= 2, - base >= 4 && < 99, + base >= 4.9 && < 99, base-compat >= 0.8.0, binary >= 0.8, bytestring >= 0.9.2 , @@ -443,15 +445,16 @@ text >= 0.11.2.3, transformers >= 0.4, unordered-containers >= 0.2.3, - vector >= 0.10, + vector >= 0.11, vector-binary-instances >= 0.2.3.1 default-language: Haskell2010 default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings - BangPatterns, RecordWildCards, NamedFieldPuns, MultiWayIf + BangPatterns, RecordWildCards, NamedFieldPuns, MultiWayIf, + StrictData other-extensions: TemplateHaskell - ghc-options: -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-unrecognised-pragmas - ghc-options: -fno-warn-implicit-prelude -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively + ghc-options: -Wall -Wcompat -Worphans -Wincomplete-uni-patterns -Wincomplete-record-updates -Wimplicit-prelude -Wmissing-home-modules -Widentities + ghc-options: -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively ghc-options: -threaded -rtsopts if impl(ghcjs) { @@ -462,5 +465,5 @@ } else { build-depends: zlib >= 0.5.3.1 ghc-options: "-with-rtsopts=-A99m -K1000K" --- get back to -K1K when I can use pretty-1.1.3.4 (TH depends on an old one) +-- TODO: get back to -K1K when I can use pretty-1.1.3.4 (TH depends on an old one), that is, when I can drop GHC 8.0.2 and older } diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -1,3 +1,7 @@ +import Prelude () + +import Game.LambdaHack.Common.Prelude + import TieKnot main :: IO ()