module Game.LambdaHack.Common.EffectDescription
( effectToSuffix, aspectToSuffix, featureToSuff
, kindEffectToSuffix, kindAspectToSuffix
) where
import Control.Exception.Assert.Sugar
import qualified Control.Monad.State as St
import qualified Data.EnumMap.Strict as EM
import Data.Text (Text)
import qualified Data.Text as T
import qualified NLP.Miniutter.English as MU
import qualified Game.LambdaHack.Common.Dice as Dice
import Game.LambdaHack.Common.Effect
import Game.LambdaHack.Common.Msg
import Game.LambdaHack.Common.Time
effectToSuff :: (Show a, Ord a, Num a)
=> Effect a -> (a -> Text) -> (a -> Maybe Int) -> Text
effectToSuff effect f g =
case ( St.evalState (effectTrav effect $ return . f) ()
, St.evalState (effectTrav effect $ return . g) () ) of
(NoEffect t, _) -> t
(RefillHP p, _) | p > 0 -> "of healing" <+> wrapInParens (affixBonus p)
(RefillHP 0, _) -> assert `failure` effect
(RefillHP p, _) -> "of wounding" <+> wrapInParens (affixBonus p)
(Hurt dice, _) -> wrapInParens (tshow dice)
(RefillCalm p, _) | p > 0 -> "of soothing" <+> wrapInParens (affixBonus p)
(RefillCalm 0, _) -> assert `failure` effect
(RefillCalm p, _) -> "of dismaying" <+> wrapInParens (affixBonus p)
(Dominate, _) -> "of domination"
(Impress, _) -> "of impression"
(_, CallFriend (Just 1)) -> "of aid calling"
(CallFriend t, _) -> "of aid calling"
<+> wrapInParens (dropPlus t <+> "friends")
(_, Summon _freqs (Just 1)) -> "of summoning"
(Summon _freqs t, _) -> "of summoning"
<+> wrapInParens (dropPlus t <+> "actors")
(_, CreateItem (Just 1)) -> "of uncovering"
(CreateItem t, _) -> "of uncovering"
<+> wrapInParens (dropPlus t <+> "items")
(ApplyPerfume, _) -> "of smell removal"
(Burn p, _) | p <= 0 -> assert `failure` effect
(Burn p, _) -> wrapInParens (makePhrase [MU.CarWs p "burn"])
(Ascend 1, _) -> "of ascending"
(Ascend p, _) | p > 0 ->
"of ascending" <+> wrapInParens (tshow p <+> "levels")
(Ascend 0, _) -> assert `failure` effect
(Ascend (1), _) -> "of descending"
(Ascend p, _) ->
"of descending" <+> wrapInParens (tshow (p) <+> "levels")
(Escape{}, _) -> "of escaping"
(_, Paralyze Nothing) -> "of paralysis (? clips)"
(_, Paralyze (Just p)) ->
let clipInTurn = timeTurn `timeFit` timeClip
seconds = 0.5 * fromIntegral p / fromIntegral clipInTurn :: Double
in "of paralysis" <+> wrapInParens (tshow seconds <> "s")
(_, InsertMove Nothing) ->
"of speed surge (? moves)"
(_, InsertMove (Just p)) ->
"of speed surge" <+> wrapInParens (makePhrase [MU.CarWs p "move"])
(DropBestWeapon, _) -> "of disarming"
(DropEqp ' ' False, _) -> "of equipment drop"
(DropEqp symbol False, _) -> "of drop '" <> T.singleton symbol <> "'"
(DropEqp ' ' True, _) -> "of equipment smash"
(DropEqp symbol True, _) -> "of smash '" <> T.singleton symbol <> "'"
(SendFlying tmod, _) -> "of impact" <+> tmodToSuff "" tmod
(PushActor tmod, _) -> "of pushing" <+> tmodToSuff "" tmod
(PullActor tmod, _) -> "of pulling" <+> tmodToSuff "" tmod
(_, Teleport (Just p)) | p <= 1 -> assert `failure` effect
(Teleport t, Teleport (Just p)) | p <= 9 ->
"of blinking" <+> wrapInParens (dropPlus t <+> "steps")
(Teleport t, _)->
"of teleport" <+> wrapInParens (dropPlus t <+> "steps")
(PolyItem _cstore, _) -> "of repurpose"
(Identify _cstore, _) -> "of identify"
(ActivateInv ' ', _) -> "of inventory burst"
(ActivateInv symbol, _) -> "of burst '" <> T.singleton symbol <> "'"
(Explode _, _) -> "of explosion"
(OneOf l, _) ->
let subject = if length l <= 5 then "marvel" else "wonder"
in makePhrase ["of", MU.CardinalWs (length l) subject]
(OnSmash _, _) -> ""
(TimedAspect _ aspect, _) -> "keep (" <> rawAspectToSuff aspect <> ")"
(effectF, effectG) -> assert `failure` (effect, effectF, effectG)
tmodToSuff :: Text -> ThrowMod -> Text
tmodToSuff verb ThrowMod{..} =
let vSuff | throwVelocity == 100 = ""
| otherwise = "v=" <> tshow throwVelocity <> "%"
tSuff | throwLinger == 100 = ""
| otherwise = "t=" <> tshow throwLinger <> "%"
in if vSuff == "" && tSuff == "" then ""
else verb <+> "with" <+> vSuff <+> tSuff
aspectToSuff :: Show a => Aspect a -> (a -> Text) -> Text
aspectToSuff aspect f =
rawAspectToSuff $ St.evalState (aspectTrav aspect $ return . f) ()
rawAspectToSuff :: Aspect Text -> Text
rawAspectToSuff aspect =
case aspect of
Periodic t -> wrapInParens $ dropPlus t <+> "in 100"
AddMaxHP t -> wrapInParens $ t <+> "HP"
AddMaxCalm t -> wrapInParens $ t <+> "Calm"
AddSpeed t -> wrapInParens $ t <+> "speed"
AddSkills p -> wrapInParens $ "+" <+> tshow (EM.toList p)
AddHurtMelee t -> wrapInParens $ t <> "% melee"
AddHurtRanged t -> wrapInParens $ t <> "% ranged"
AddArmorMelee t -> "[" <> t <> "%]"
AddArmorRanged t -> "{" <> t <> "%}"
AddSight t -> wrapInParens $ t <+> "sight"
AddSmell t -> wrapInParens $ t <+> "smell"
AddLight t -> wrapInParens $ t <+> "light"
featureToSuff :: Feature -> Text
featureToSuff feat =
case feat of
ChangeTo t -> wrapInChevrons $ "changes to" <+> tshow t
Fragile -> wrapInChevrons $ "fragile"
Durable -> wrapInChevrons $ "durable"
ToThrow tmod -> wrapInChevrons $ tmodToSuff "flies" tmod
Identified -> ""
Applicable -> ""
EqpSlot{} -> ""
Precious -> ""
Tactic tactics -> "overrides tactics to" <+> tshow tactics
dropPlus :: Text -> Text
dropPlus = T.dropWhile (`elem` ['+', '-'])
effectToSuffix :: Effect Int -> Text
effectToSuffix effect = effectToSuff effect affixBonus Just
aspectToSuffix :: Aspect Int -> Text
aspectToSuffix aspect = aspectToSuff aspect affixBonus
affixBonus :: Int -> Text
affixBonus p = case compare p 0 of
EQ -> ""
LT -> tshow p
GT -> "+" <> tshow p
wrapInParens :: Text -> Text
wrapInParens "" = ""
wrapInParens t = "(" <> t <> ")"
wrapInChevrons :: Text -> Text
wrapInChevrons "" = ""
wrapInChevrons t = "<" <> t <> ">"
affixDice :: Dice.Dice -> Text
affixDice d = maybe "+?" affixBonus $ Dice.reduceDice d
kindEffectToSuffix :: Effect Dice.Dice -> Text
kindEffectToSuffix effect = effectToSuff effect affixDice Dice.reduceDice
kindAspectToSuffix :: Aspect Dice.Dice -> Text
kindAspectToSuffix aspect = aspectToSuff aspect affixDice