module Game.LambdaHack.Client.AtomicSemCli
( cmdAtomicSem, cmdAtomicSemCli, cmdAtomicFilterCli
, drawCmdAtomicUI, drawSfxAtomicUI
) where
import Control.Monad
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Data.Maybe
import qualified Data.Monoid as Monoid
import qualified NLP.Miniutter.English as MU
import Game.LambdaHack.Client.Action
import Game.LambdaHack.Client.Draw
import Game.LambdaHack.Client.HumanLocal
import Game.LambdaHack.Client.State
import Game.LambdaHack.Common.Action
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Animation
import Game.LambdaHack.Common.AtomicCmd
import Game.LambdaHack.Common.AtomicPos
import Game.LambdaHack.Common.AtomicSem
import qualified Game.LambdaHack.Common.Color as Color
import qualified Game.LambdaHack.Common.Effect as Effect
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Msg
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.State
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Content.ItemKind
import Game.LambdaHack.Content.TileKind
import Control.Exception.Assert.Sugar
cmdAtomicFilterCli :: MonadClient m => CmdAtomic -> m [CmdAtomic]
cmdAtomicFilterCli cmd = case cmd of
AlterTileA lid p fromTile toTile -> do
Kind.COps{cotile = Kind.Ops{okind}} <- getsState scops
lvl@Level{lxsize} <- getLevel lid
let t = lvl `at` p
if t == fromTile
then return [cmd]
else do
let subject = ""
verb = "turn into"
msg = makeSentence [ "the", MU.Text $ tname $ okind t
, "at position", MU.Text $ showPoint lxsize p
, "suddenly"
, MU.SubjectVerbSg subject verb
, MU.AW $ MU.Text $ tname $ okind toTile ]
return [ cmd
, MsgAllA msg
]
SearchTileA aid p fromTile toTile -> do
b <- getsState $ getActorBody aid
lvl <- getLevel $ blid b
let t = lvl `at` p
if t == toTile
then
return []
else if t == fromTile
then
return [ AlterTileA (blid b) p fromTile toTile
, cmd
]
else
assert `failure` "LoseTile fails to reset memory"
`twith` (aid, p, fromTile, toTile, b, t, cmd)
DiscoverA _ _ iid _ -> do
disco <- getsClient sdisco
item <- getsState $ getItemBody iid
if jkindIx item `EM.member` disco
then return []
else return [cmd]
CoverA _ _ iid _ -> do
disco <- getsClient sdisco
item <- getsState $ getItemBody iid
if jkindIx item `EM.notMember` disco
then return []
else return [cmd]
PerceptionA lid outPA inPA -> do
perOld <- getPerFid lid
perceptionA lid outPA inPA
perNew <- getPerFid lid
s <- getState
fid <- getsClient sside
let outFov = totalVisible perOld ES.\\ totalVisible perNew
outPrio = mapMaybe (\p -> posToActor p lid s) $ ES.elems outFov
fActor aid =
let b = getActorBody aid s
in if bfid b == fid
then Nothing
else Just $ LoseActorA aid b (getActorItem aid s)
outActor = mapMaybe fActor outPrio
Level{lfloor, lsmell} <- getLevel lid
let inFov = totalVisible perNew ES.\\ totalVisible perOld
pMaybe p = maybe Nothing (\x -> Just (p, x))
inFloor = mapMaybe (\p -> pMaybe p $ EM.lookup p lfloor)
(ES.elems inFov)
fItem p (iid, k) = LoseItemA iid (getItemBody iid s) k (CFloor lid p)
fBag (p, bag) = map (fItem p) $ EM.assocs bag
inItem = concatMap fBag inFloor
let inSmellFov = smellVisible perNew ES.\\ smellVisible perOld
inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p lsmell)
(ES.elems inSmellFov)
inSmell = if null inSm then [] else [LoseSmellA lid inSm]
let seenNew = seenAtomicCli False fid perNew
seenOld = seenAtomicCli False fid perOld
psActor <- mapM posCmdAtomic outActor
assert (allB seenOld psActor) skip
assert (allB (not . seenNew) psActor) skip
psItemSmell <- mapM posCmdAtomic $ inItem ++ inSmell
assert (allB (not . seenOld) psItemSmell) skip
assert (allB seenNew psItemSmell) skip
return $ cmd : outActor ++ inItem ++ inSmell
_ -> return [cmd]
cmdAtomicSemCli :: MonadClient m => CmdAtomic -> m ()
cmdAtomicSemCli cmd = case cmd of
DestroyActorA aid _ _ -> destroyActorA aid
LoseActorA aid _ _ -> destroyActorA aid
LeadFactionA fid source target -> do
side <- getsClient sside
when (side == fid) $ do
mleader <- getsClient _sleader
assert (mleader == source
|| mleader == target
`blame` "unexpected leader" `twith` (cmd, mleader)) skip
modifyClient $ \cli -> cli {_sleader = target}
DiscoverA lid p iid ik -> discoverA lid p iid ik
CoverA lid p iid ik -> coverA lid p iid ik
PerceptionA lid outPA inPA -> perceptionA lid outPA inPA
RestartA _ sdisco sfper s sdebugCli _ -> do
side <- getsClient sside
let fact = sfactionD s EM.! side
shistory <- getsClient shistory
sconfigUI <- getsClient sconfigUI
isAI <- getsClient sisAI
let cli = defStateClient shistory sconfigUI side isAI
putClient cli { sdisco
, sfper
, _sleader = gleader fact
, sundo = [CmdAtomic cmd]
, sdebugCli}
ResumeA _fid sfper -> modifyClient $ \cli -> cli {sfper}
KillExitA _fid -> killExitA
SaveBkpA -> saveClient
_ -> return ()
destroyActorA :: MonadClient m => ActorId -> m ()
destroyActorA aid =
modifyClient $ \cli -> cli {stargetD = EM.delete aid $ stargetD cli}
perceptionA :: MonadClient m => LevelId -> PerActor -> PerActor -> m ()
perceptionA lid outPA inPA = do
cops <- getsState scops
s <- getState
perOld <- getPerFid lid
let interHead [] = Nothing
interHead ((aid, vis) : _) =
Just $ pvisible vis `ES.intersection`
maybe ES.empty pvisible (EM.lookup aid (perActor perOld))
unset = maybe False ES.null (interHead (EM.assocs inPA))
|| maybe False (not . ES.null) (interHead (EM.assocs outPA))
when unset $ do
let dummyToPer Perception{perActor} = Perception
{ perActor
, ptotal = PerceptionVisible
$ ES.unions $ map pvisible $ EM.elems perActor
, psmell = smellFromActors cops s perActor }
paToDummy perActor = Perception
{ perActor
, ptotal = PerceptionVisible ES.empty
, psmell = PerceptionVisible ES.empty }
outPer = paToDummy outPA
inPer = paToDummy inPA
adj Nothing = assert `failure` "no perception to alter" `twith` lid
adj (Just per) = Just $ dummyToPer $ addPer (diffPer per outPer) inPer
f = EM.alter adj lid
modifyClient $ \cli -> cli {sfper = f (sfper cli)}
discoverA :: MonadClient m
=> LevelId -> Point -> ItemId -> Kind.Id ItemKind -> m ()
discoverA lid p iid ik = do
item <- getsState $ getItemBody iid
let f Nothing = Just ik
f (Just ik2) = assert `failure` "already discovered"
`twith` (lid, p, iid, ik, ik2)
modifyClient $ \cli -> cli {sdisco = EM.alter f (jkindIx item) (sdisco cli)}
coverA :: MonadClient m
=> LevelId -> Point -> ItemId -> Kind.Id ItemKind -> m ()
coverA lid p iid ik = do
item <- getsState $ getItemBody iid
let f Nothing = assert `failure` "already covered" `twith` (lid, p, iid, ik)
f (Just ik2) = assert (ik == ik2 `blame` "unexpected covered item kind"
`twith` (ik, ik2)) Nothing
modifyClient $ \cli -> cli {sdisco = EM.alter f (jkindIx item) (sdisco cli)}
killExitA :: MonadClient m => m ()
killExitA = modifyClient $ \cli -> cli {squit = True}
drawCmdAtomicUI :: MonadClientUI m => Bool -> CmdAtomic -> m ()
drawCmdAtomicUI verbose cmd = case cmd of
CreateActorA aid body _ -> do
when verbose $ actorVerbMU aid body "appear"
lookAtMove aid
DestroyActorA aid body _ ->
destroyActorUI aid body "die" "be destroyed" verbose
CreateItemA _ item k _ -> itemVerbMU item k "drop to the ground"
DestroyItemA _ item k _ -> itemVerbMU item k "disappear"
LoseActorA aid body _ ->
destroyActorUI aid body "be missing in action" "be lost" verbose
MoveActorA aid _ _ -> lookAtMove aid
WaitActorA aid _ _| verbose -> aVerbMU aid "wait"
DisplaceActorA source target -> displaceActorUI source target
MoveItemA iid k c1 c2 -> moveItemUI verbose iid k c1 c2
HealActorA aid n | verbose ->
aVerbMU aid $ MU.Text $ if n > 0
then "heal" <+> showT n <> "HP"
else "be about to lose" <+> showT n <> "HP"
HasteActorA aid delta ->
aVerbMU aid $ if delta > speedZero
then "speed up"
else "slow down"
LeadFactionA fid (Just source) (Just target) -> do
side <- getsClient sside
when (fid == side) $ do
actorD <- getsState sactorD
case EM.lookup source actorD of
Just sb | bhp sb <= 0 -> assert (not $ bproj sb) $ do
tb <- getsState $ getActorBody target
let subject = partActor tb
object = partActor sb
msgAdd $ makeSentence [ MU.SubjectVerbSg subject "take command"
, "from", object ]
_ -> skip
DiplFactionA fid1 fid2 _ toDipl -> do
name1 <- getsState $ gname . (EM.! fid1) . sfactionD
name2 <- getsState $ gname . (EM.! fid2) . sfactionD
let showDipl Unknown = "unknown to each other"
showDipl Neutral = "in neutral diplomatic relations"
showDipl Alliance = "allied"
showDipl War = "at war"
msgAdd $ name1 <+> "and" <+> name2 <+> "are now" <+> showDipl toDipl <> "."
QuitFactionA fid mbody _ toSt -> quitFactionUI fid mbody toSt
AlterTileA{} | verbose ->
return ()
SearchTileA aid _ fromTile toTile -> do
Kind.COps{cotile = Kind.Ops{okind}} <- getsState scops
subject <- partAidLeader aid
let verb = "reveal that the"
subject2 = MU.Text $ tname $ okind fromTile
verb2 = "be"
let msg = makeSentence [ MU.SubjectVerbSg subject verb
, MU.SubjectVerbSg subject2 verb2
, "a hidden"
, MU.Text $ tname $ okind toTile ]
msgAdd msg
AgeGameA t -> do
when (t > timeClip) $ displayFrames [Nothing]
displayPush
DiscoverA _ _ iid _ -> do
disco <- getsClient sdisco
item <- getsState $ getItemBody iid
let ix = jkindIx item
Kind.COps{coitem} <- getsState scops
let discoUnknown = EM.delete ix disco
(objUnkown1, objUnkown2) = partItem coitem discoUnknown item
msg = makeSentence
[ "the", MU.SubjectVerbSg (MU.Phrase [objUnkown1, objUnkown2])
"turn out to be"
, partItemAW coitem disco item ]
msgAdd msg
CoverA _ _ iid ik -> do
discoUnknown <- getsClient sdisco
item <- getsState $ getItemBody iid
let ix = jkindIx item
Kind.COps{coitem} <- getsState scops
let disco = EM.insert ix ik discoUnknown
(objUnkown1, objUnkown2) = partItem coitem discoUnknown item
(obj1, obj2) = partItem coitem disco item
msg = makeSentence
[ "the", MU.SubjectVerbSg (MU.Phrase [obj1, obj2])
"look like an ordinary"
, objUnkown1, objUnkown2 ]
msgAdd msg
RestartA _ _ _ _ _ t ->
msgAdd $ "New game started in" <+> t <+> "mode."
SaveBkpA | verbose -> msgAdd "Saving backup."
MsgAllA msg -> msgAdd msg
_ -> return ()
lookAtMove :: MonadClientUI m => ActorId -> m ()
lookAtMove aid = do
body <- getsState $ getActorBody aid
side <- getsClient sside
tgtMode <- getsClient stgtMode
when (not (bproj body)
&& bfid body == side
&& isNothing tgtMode) $ do
lookMsg <- lookAt False True (bpos body) aid ""
msgAdd lookMsg
actorVerbMU :: MonadClientUI m => ActorId -> Actor -> MU.Part -> m ()
actorVerbMU aid b verb = do
subject <- partActorLeader aid b
msgAdd $ makeSentence [MU.SubjectVerbSg subject verb]
aVerbMU :: MonadClientUI m => ActorId -> MU.Part -> m ()
aVerbMU aid verb = do
b <- getsState $ getActorBody aid
actorVerbMU aid b verb
itemVerbMU :: MonadClientUI m => Item -> Int -> MU.Part -> m ()
itemVerbMU item k verb = assert (k > 0) $ do
Kind.COps{coitem} <- getsState scops
disco <- getsClient sdisco
let subject = partItemWs coitem disco k item
msg | k > 1 = makeSentence [MU.SubjectVerb MU.PlEtc MU.Yes subject verb]
| otherwise = makeSentence [MU.SubjectVerbSg subject verb]
msgAdd msg
_iVerbMU :: MonadClientUI m => ItemId -> Int -> MU.Part -> m ()
_iVerbMU iid k verb = do
item <- getsState $ getItemBody iid
itemVerbMU item k verb
aiVerbMU :: MonadClientUI m => ActorId -> MU.Part -> ItemId -> Int -> m ()
aiVerbMU aid verb iid k = do
Kind.COps{coitem} <- getsState scops
disco <- getsClient sdisco
item <- getsState $ getItemBody iid
subject <- partAidLeader aid
let msg = makeSentence [ MU.SubjectVerbSg subject verb
, partItemWs coitem disco k item ]
msgAdd msg
destroyActorUI :: MonadClientUI m
=> ActorId -> Actor -> MU.Part -> MU.Part -> Bool -> m ()
destroyActorUI aid body verb verboseVerb verbose = do
side <- getsClient sside
if (bfid body == side && bhp body <= 0 && not (bproj body)) then do
actorVerbMU aid body verb
void $ displayMore ColorBW ""
else when verbose $ actorVerbMU aid body verboseVerb
moveItemUI :: MonadClientUI m
=> Bool -> ItemId -> Int -> Container -> Container -> m ()
moveItemUI verbose iid k c1 c2 = do
Kind.COps{coitem} <- getsState scops
item <- getsState $ getItemBody iid
disco <- getsClient sdisco
case (c1, c2) of
(CFloor _ _, CActor aid l) -> do
b <- getsState $ getActorBody aid
unless (bproj b) $ do
let n = bbag b EM.! iid
side <- getsClient sside
if bfid b == side then
msgAdd $ makePhrase [ letterLabel l
, partItemWs coitem disco n item
, "\n" ]
else aiVerbMU aid "pick up" iid k
(CActor aid _, CFloor _ _) | verbose ->
aiVerbMU aid "drop" iid k
_ -> return ()
displaceActorUI :: MonadClientUI m => ActorId -> ActorId -> m ()
displaceActorUI source target = do
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
spart <- partActorLeader source sb
tpart <- partActorLeader target tb
let msg = makeSentence [MU.SubjectVerbSg spart "displace", tpart]
msgAdd msg
when (bfid sb /= bfid tb) $ do
lookAtMove source
lookAtMove target
let ps = (bpos tb, bpos sb)
animFrs <- animate (blid sb) $ swapPlaces ps
displayFrames $ Nothing : animFrs
quitFactionUI :: MonadClientUI m
=> FactionId -> Maybe Actor -> Maybe Status -> m ()
quitFactionUI fid mbody toSt = do
Kind.COps{coitem=Kind.Ops{okind, ouniqGroup}} <- getsState scops
factionD <- getsState sfactionD
let fact = factionD EM.! fid
fidName = MU.Text $ gname fact
side <- getsClient sside
spawn <- getsState $ isSpawnFaction fid
summon <- getsState $ isSummonFaction fid
let msgIfSide _ | fid /= side = Nothing
msgIfSide s = Just s
(startingPart, partingPart) = case toSt of
_ | summon && not spawn ->
(Nothing, Nothing)
Just Status{stOutcome=Killed} ->
( Just "be eliminated"
, msgIfSide "Let's hope another party can save the day!" )
Just Status{stOutcome=Defeated} ->
( Just "be decisively defeated"
, msgIfSide "Let's hope your new overlords let you live." )
Just Status{stOutcome=Camping} ->
( Just "order save and exit"
, Just $ if fid == side
then "See you soon, stronger and braver!"
else "See you soon, stalwart warrior!" )
Just Status{stOutcome=Conquer} ->
( Just "vanquish all foes"
, msgIfSide "Can it be done in a better style, though?" )
Just Status{stOutcome=Escape} ->
( Just "achieve victory"
, msgIfSide "Can it be done better, though?" )
Just Status{stOutcome=Restart, stInfo} ->
( Just $ MU.Text $ "order mission restart in" <+> stInfo <+> "mode"
, Just $ if fid == side
then "This time for real."
else "Somebody couldn't stand the heat." )
Nothing ->
(Nothing, Nothing)
case startingPart of
Nothing -> return ()
Just sp -> do
let msg = makeSentence [MU.SubjectVerbSg fidName sp]
msgAdd msg
case (toSt, partingPart) of
(Just status, Just pp) -> do
(bag, total) <- case mbody of
Just body | fid == side -> getsState $ calculateTotal body
_ -> case gleader fact of
Nothing -> return (EM.empty, 0)
Just aid -> do
b <- getsState $ getActorBody aid
getsState $ calculateTotal b
let currencyName = MU.Text $ iname $ okind $ ouniqGroup "currency"
itemMsg = makeSentence [ "Your loot is worth"
, MU.CarWs total currencyName ]
<+> moreMsg
startingSlide <- promptToSlideshow moreMsg
recordHistory
itemSlides <-
if EM.null bag then return Monoid.mempty
else do
io <- floorItemOverlay bag
overlayToSlideshow itemMsg io
scoreSlides <- scoreToSlideshow total status
partingSlide <- promptToSlideshow $ pp <+> moreMsg
shutdownSlide <- promptToSlideshow pp
void $ getInitConfirms ColorFull []
$ startingSlide Monoid.<> itemSlides
Monoid.<> scoreSlides Monoid.<> partingSlide Monoid.<> shutdownSlide
_ -> return ()
drawSfxAtomicUI :: MonadClientUI m => Bool -> SfxAtomic -> m ()
drawSfxAtomicUI verbose sfx = case sfx of
StrikeD source target item b -> strikeD source target item b
RecoilD source target _ _ -> do
spart <- partAidLeader source
tpart <- partAidLeader target
msgAdd $ makeSentence [MU.SubjectVerbSg spart "shrink away from", tpart]
ProjectD aid iid -> aiVerbMU aid "aim" iid 1
CatchD aid iid -> aiVerbMU aid "catch" iid 1
ActivateD aid iid -> aiVerbMU aid "activate" iid 1
CheckD aid iid -> aiVerbMU aid "check" iid 1
TriggerD aid _p _feat | verbose ->
aVerbMU aid "trigger"
ShunD aid _p _ | verbose ->
aVerbMU aid "shun"
EffectD aid effect -> do
b <- getsState $ getActorBody aid
side <- getsClient sside
let fid = bfid b
if bhp b <= 0 && not (bproj b) || bhp b < 0 then do
let firstFall | fid == side && bproj b = "fall apart"
| fid == side = "fall down"
| bproj b = "break up"
| otherwise = "collapse"
hurtExtra | fid == side && bproj b = "be stomped flat"
| fid == side = "be ground into the floor"
| bproj b = "be shattered into little pieces"
| otherwise = "be reduced to a bloody pulp"
subject <- partActorLeader aid b
let deadPreviousTurn p = p < 0
&& (bhp b <= p && not (bproj b)
|| bhp b < p)
(deadBefore, verbDie) =
case effect of
Effect.Hurt _ p | deadPreviousTurn p -> (True, hurtExtra)
Effect.Heal p | deadPreviousTurn p -> (True, hurtExtra)
_ -> (False, firstFall)
msgDie = makeSentence [MU.SubjectVerbSg subject verbDie]
msgAdd msgDie
when (fid == side && not (bproj b)) $ do
animDie <- if deadBefore
then animate (blid b)
$ twirlSplash (bpos b, bpos b) Color.Red Color.Red
else animate (blid b) $ deathBody $ bpos b
displayFrames animDie
else case effect of
Effect.NoEffect -> msgAdd "Nothing happens."
Effect.Heal p | p > 0 -> do
if fid == side then
actorVerbMU aid b "feel healthier"
else
actorVerbMU aid b "look healthier"
let ps = (bpos b, bpos b)
animFrs <- animate (blid b) $ twirlSplash ps Color.BrBlue Color.Blue
displayFrames $ Nothing : animFrs
Effect.Heal _ -> do
if fid == side then
actorVerbMU aid b "feel wounded"
else
actorVerbMU aid b "look wounded"
let ps = (bpos b, bpos b)
animFrs <- animate (blid b) $ twirlSplash ps Color.BrRed Color.Red
displayFrames $ Nothing : animFrs
Effect.Mindprobe nEnemy -> do
let msg = makeSentence
[MU.CardinalWs nEnemy "howl", "of anger", "can be heard"]
msgAdd msg
Effect.Dominate -> do
if fid == side then do
aVerbMU aid $ MU.Text "black out, dominated by foes"
void $ displayMore ColorFull ""
else do
fidName <- getsState $ gname . (EM.! fid) . sfactionD
aVerbMU aid $ MU.Text $ "be no longer controlled by" <+> fidName
Effect.ApplyPerfume ->
msgAdd "The fragrance quells all scents in the vicinity."
Effect.Searching{} -> do
subject <- partActorLeader aid b
let msg = makeSentence
[ "It gets lost and"
, MU.SubjectVerbSg subject "search in vain" ]
msgAdd msg
Effect.Ascend k | k > 0 -> actorVerbMU aid b "find a way upstairs"
Effect.Ascend k | k < 0 -> actorVerbMU aid b "find a way downstairs"
Effect.Ascend{} -> assert `failure` sfx
_ -> return ()
MsgFidD _ msg -> msgAdd msg
MsgAllD msg -> msgAdd msg
DisplayPushD _ ->
displayPush
DisplayDelayD _ -> displayFrames [Nothing]
RecordHistoryD _ -> recordHistory
_ -> return ()
strikeD :: MonadClientUI m
=> ActorId -> ActorId -> Item -> HitAtomic -> m ()
strikeD source target item b = assert (source /= target) $ do
Kind.COps{coitem=coitem@Kind.Ops{okind}} <- getsState scops
disco <- getsClient sdisco
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
spart <- partActorLeader source sb
tpart <- partActorLeader target tb
let (verb, withWhat) | bproj sb = ("hit", False)
| otherwise =
case jkind disco item of
Nothing -> ("hit", False)
Just ik -> let kind = okind ik
in ( iverbApply kind
, isNothing $ lookup "hth" $ ifreq kind )
msg MissBlockD =
let (partBlock1, partBlock2) =
if withWhat
then ("swing", partItemAW coitem disco item)
else ("try to", verb)
in makeSentence
[ MU.SubjectVerbSg spart partBlock1
, partBlock2 MU.:> ", but"
, MU.SubjectVerbSg tpart "block"
]
msg _ = makeSentence $
[MU.SubjectVerbSg spart verb, tpart]
++ if withWhat
then ["with", partItemAW coitem disco item]
else []
msgAdd $ msg b
let ps = (bpos tb, bpos sb)
anim HitD = twirlSplash ps Color.BrRed Color.Red
anim HitBlockD = blockHit ps Color.BrRed Color.Red
anim MissBlockD = blockMiss ps
animFrs <- animate (blid sb) $ anim b
displayFrames $ Nothing : animFrs