{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}
module Game.LambdaHack.Client.UI.Msg
(
Msg, toMsg
, MsgClass(..), interruptsRunning, disturbsResting
, Report, nullReport, consReport, renderReport, anyInReport
, History, newReport, emptyHistory, addToReport, archiveReport, lengthHistory
, renderHistory
#ifdef EXPOSE_INTERNAL
, isSavedToHistory, isDisplayed, bindsPronouns, msgColor
, UAttrLine, RepMsgN, uToAttrLine, attrLineToU
, emptyReport, snocReport, renderWholeReport, renderRepetition
, scrapRepetition, renderTimeReport
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import Control.DeepSeq
import Data.Binary
import qualified Data.EnumMap.Strict as EM
import Data.Vector.Binary ()
import qualified Data.Vector.Unboxed as U
import Data.Word (Word32)
import GHC.Generics (Generic)
import Game.LambdaHack.Client.UI.Overlay
import qualified Game.LambdaHack.Common.RingBuffer as RB
import Game.LambdaHack.Common.Time
import qualified Game.LambdaHack.Definition.Color as Color
type UAttrLine = U.Vector Word32
uToAttrLine :: UAttrLine -> AttrLine
uToAttrLine v = map Color.AttrCharW32 $ U.toList v
attrLineToU :: AttrLine -> UAttrLine
attrLineToU l = U.fromList $ map Color.attrCharW32 l
data Msg = Msg
{ msgLine :: AttrLine
, msgClass :: MsgClass
}
deriving (Show, Eq, Generic)
instance Binary Msg
toMsg :: Maybe (EM.EnumMap MsgClass Color.Color) -> MsgClass -> Text -> Msg
toMsg mem msgClass l =
let findColorInConfig = EM.findWithDefault Color.White msgClass
color = maybe (msgColor msgClass) findColorInConfig mem
msgLine = textFgToAL color l
in Msg {..}
data MsgClass =
MsgAdmin
| MsgBecome
| MsgNoLonger
| MsgLongerUs
| MsgLonger
| MsgItemCreation
| MsgItemDestruction
| MsgDeathGood
| MsgDeathBad
| MsgDeath
| MsgDeathThreat
| MsgLeader
| MsgDiplomacy
| MsgOutcome
| MsgPlot
| MsgLandscape
| MsgTileDisco
| MsgItemDisco
| MsgActorSpot
| MsgFirstEnemySpot
| MsgItemSpot
| MsgItemMove
| MsgAction
| MsgActionMinor
| MsgEffectMajor
| MsgEffect
| MsgEffectMinor
| MsgMisc
| MsgHeardClose
| MsgHeard
| MsgFocus
| MsgWarning
| MsgRangedPowerfulWe
| MsgRangedPowerfulUs
| MsgRanged
| MsgRangedUs
| MsgRare
| MsgVeryRare
| MsgMeleePowerfulWe
| MsgMeleePowerfulUs
| MsgMeleeInterestingWe
| MsgMeleeInterestingUs
| MsgMelee
| MsgMeleeUs
| MsgDone
| MsgAtFeetMajor
| MsgAtFeet
| MsgNumeric
| MsgSpam
| MsgMacro
| MsgRunStop
| MsgPrompt
| MsgPromptFocus
| MsgAlert
| MsgStopPlayback
deriving (Show, Read, Eq, Enum, Generic)
instance NFData MsgClass
instance Binary MsgClass
isSavedToHistory :: MsgClass -> Bool
isSavedToHistory MsgNumeric = False
isSavedToHistory MsgSpam = False
isSavedToHistory MsgMacro = False
isSavedToHistory MsgRunStop = False
isSavedToHistory MsgPrompt = False
isSavedToHistory MsgPromptFocus = False
isSavedToHistory MsgAlert = False
isSavedToHistory MsgStopPlayback = False
isSavedToHistory _ = True
isDisplayed :: MsgClass -> Bool
isDisplayed MsgRunStop = False
isDisplayed MsgNumeric = False
isDisplayed MsgSpam = False
isDisplayed MsgMacro = False
isDisplayed MsgStopPlayback = False
isDisplayed _ = True
interruptsRunning :: MsgClass -> Bool
interruptsRunning MsgHeard = False
interruptsRunning MsgEffectMinor = False
interruptsRunning MsgItemDisco = False
interruptsRunning MsgItemMove = False
interruptsRunning MsgActionMinor = False
interruptsRunning MsgAtFeet = False
interruptsRunning MsgNumeric = False
interruptsRunning MsgSpam = False
interruptsRunning MsgMacro = False
interruptsRunning MsgRunStop = False
interruptsRunning MsgPrompt = False
interruptsRunning MsgPromptFocus = False
interruptsRunning _ = True
disturbsResting :: MsgClass -> Bool
disturbsResting MsgHeard = False
disturbsResting MsgHeardClose = False
disturbsResting MsgLeader = False
disturbsResting MsgEffectMinor = False
disturbsResting MsgItemDisco = False
disturbsResting MsgItemMove = False
disturbsResting MsgActionMinor = False
disturbsResting MsgAtFeet = False
disturbsResting MsgNumeric = False
disturbsResting MsgSpam = False
disturbsResting MsgMacro = False
disturbsResting MsgRunStop = False
disturbsResting MsgPrompt = False
disturbsResting MsgPromptFocus = False
disturbsResting _ = True
bindsPronouns :: MsgClass -> Bool
bindsPronouns MsgRangedPowerfulUs = True
bindsPronouns MsgRangedUs = True
bindsPronouns MsgMeleePowerfulUs = True
bindsPronouns MsgMeleeInterestingUs = True
bindsPronouns MsgMeleeUs = True
bindsPronouns MsgLongerUs = True
bindsPronouns _ = False
msgColor :: MsgClass -> Color.Color
msgColor MsgAdmin = Color.White
msgColor MsgBecome = Color.BrBlue
msgColor MsgNoLonger = Color.Blue
msgColor MsgLongerUs = Color.White
msgColor MsgLonger = Color.White
msgColor MsgItemCreation = Color.BrBlue
msgColor MsgItemDestruction = Color.Blue
msgColor MsgDeathGood = Color.BrGreen
msgColor MsgDeathBad = Color.BrRed
msgColor MsgDeath = Color.White
msgColor MsgDeathThreat = Color.BrRed
msgColor MsgLeader = Color.White
msgColor MsgDiplomacy = Color.BrYellow
msgColor MsgOutcome = Color.BrWhite
msgColor MsgPlot = Color.White
msgColor MsgLandscape = Color.White
msgColor MsgTileDisco = Color.Magenta
msgColor MsgItemDisco = Color.BrMagenta
msgColor MsgActorSpot = Color.White
msgColor MsgFirstEnemySpot = Color.Red
msgColor MsgItemSpot = Color.White
msgColor MsgItemMove = Color.White
msgColor MsgAction = Color.White
msgColor MsgActionMinor = Color.White
msgColor MsgEffectMajor = Color.BrCyan
msgColor MsgEffect = Color.Cyan
msgColor MsgEffectMinor = Color.White
msgColor MsgMisc = Color.White
msgColor MsgHeardClose = Color.BrYellow
msgColor MsgHeard = Color.Brown
msgColor MsgFocus = Color.Green
msgColor MsgWarning = Color.BrYellow
msgColor MsgRangedPowerfulWe = Color.Green
msgColor MsgRangedPowerfulUs = Color.Red
msgColor MsgRanged = Color.White
msgColor MsgRangedUs = Color.White
msgColor MsgRare = Color.Cyan
msgColor MsgVeryRare = Color.BrCyan
msgColor MsgMeleePowerfulWe = Color.Green
msgColor MsgMeleePowerfulUs = Color.Red
msgColor MsgMeleeInterestingWe = Color.Green
msgColor MsgMeleeInterestingUs = Color.Red
msgColor MsgMelee = Color.White
msgColor MsgMeleeUs = Color.White
msgColor MsgDone = Color.White
msgColor MsgAtFeetMajor = Color.White
msgColor MsgAtFeet = Color.White
msgColor MsgNumeric = Color.White
msgColor MsgSpam = Color.White
msgColor MsgMacro = Color.White
msgColor MsgRunStop = Color.White
msgColor MsgPrompt = Color.White
msgColor MsgPromptFocus = Color.Green
msgColor MsgAlert = Color.BrYellow
msgColor MsgStopPlayback = Color.BrYellow
data RepMsgN = RepMsgN {repMsg :: Msg, _repN :: Int}
deriving (Show, Generic)
instance Binary RepMsgN
newtype Report = Report [RepMsgN]
deriving (Show, Binary)
emptyReport :: Report
emptyReport = Report []
nullReport :: Report -> Bool
nullReport (Report l) = null l
snocReport :: Report -> Msg -> Int -> Report
snocReport (Report !r) y n =
if null $ msgLine y then Report r else Report $ RepMsgN y n : r
consReport :: Msg -> Report -> Report
consReport Msg{msgLine=[]} rep = rep
consReport y (Report r) = Report $ r ++ [RepMsgN y 1]
renderReport :: Report -> AttrLine
renderReport (Report r) =
let rep = Report $ filter (isDisplayed . msgClass . repMsg) r
in renderWholeReport rep
renderWholeReport :: Report -> AttrLine
renderWholeReport (Report []) = []
renderWholeReport (Report (x : xs)) =
renderWholeReport (Report xs) <+:> renderRepetition x
renderRepetition :: RepMsgN -> AttrLine
renderRepetition (RepMsgN s 0) = msgLine s
renderRepetition (RepMsgN s 1) = msgLine s
renderRepetition (RepMsgN s n) = msgLine s ++ stringToAL ("<x" ++ show n ++ ">")
anyInReport :: (MsgClass -> Bool) -> Report -> Bool
anyInReport f (Report xns) = any (f . msgClass . repMsg) xns
data History = History
{ newReport :: Report
, newTime :: Time
, oldReport :: Report
, oldTime :: Time
, archivedHistory :: RB.RingBuffer UAttrLine }
deriving (Show, Generic)
instance Binary History
emptyHistory :: Int -> History
emptyHistory size =
let ringBufferSize = size - 1
in History emptyReport timeZero emptyReport timeZero
(RB.empty ringBufferSize U.empty)
scrapRepetition :: History -> Maybe History
scrapRepetition History{ newReport = Report newMsgs
, oldReport = Report oldMsgs
, .. } =
case newMsgs of
RepMsgN s1 n1 : rest1 ->
let commutative s = not $ bindsPronouns $ msgClass s
f (RepMsgN s2 _) = msgLine s1 == msgLine s2
in case break f rest1 of
(_, []) | commutative s1 -> case break f oldMsgs of
(noDup, RepMsgN s2 n2 : rest2) ->
let newReport = Report $ RepMsgN s2 (n1 + n2) : rest1
oldReport = Report $ noDup ++ rest2
in Just History{..}
_ -> Nothing
(noDup, RepMsgN s2 n2 : rest2) | commutative s1
|| all (commutative . repMsg) noDup ->
let newReport = Report $ noDup ++ RepMsgN s2 (n1 + n2) : rest2
oldReport = Report oldMsgs
in Just History{..}
_ -> Nothing
_ -> Nothing
addToReport :: History -> Msg -> Int -> Time -> (History, Bool)
addToReport History{..} msg n time =
let newH = History{newReport = snocReport newReport msg n, newTime = time, ..}
in case scrapRepetition newH of
Just scrappedH -> (scrappedH, True)
Nothing -> (newH, False)
archiveReport :: History -> History
archiveReport History{newReport=Report newMsgs, ..} =
let f (RepMsgN _ n) = n > 0
newReportNon0 = Report $ filter f newMsgs
in if nullReport newReportNon0
then
History emptyReport timeZero oldReport oldTime archivedHistory
else let lU = map attrLineToU $ renderTimeReport oldTime oldReport
in History emptyReport timeZero newReportNon0 newTime
$ foldl' (\ !h !v -> RB.cons v h) archivedHistory (reverse lU)
renderTimeReport :: Time -> Report -> [AttrLine]
renderTimeReport !t (Report r) =
let turns = t `timeFitUp` timeTurn
rep = Report $ filter (isSavedToHistory . msgClass . repMsg) r
in if nullReport rep
then []
else [stringToAL (show turns ++ ": ") ++ renderReport rep]
lengthHistory :: History -> Int
lengthHistory History{oldReport, archivedHistory} =
RB.length archivedHistory
+ length (renderTimeReport timeZero oldReport)
renderHistory :: History -> [AttrLine]
renderHistory History{..} = map uToAttrLine (RB.toList archivedHistory)
++ renderTimeReport oldTime oldReport