{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}
-- | Game messages displayed on top of the screen for the player to read
-- and then saved to player history.
module Game.LambdaHack.Client.UI.Msg
  ( -- * Msg
    Msg, toMsg
  , MsgClass(..), interruptsRunning, disturbsResting
    -- * Report
  , Report, nullReport, consReport, renderReport, anyInReport
    -- * History
  , History, newReport, emptyHistory, addToReport, archiveReport, lengthHistory
  , renderHistory
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , 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

-- * UAttrLine

type UAttrLine = U.Vector Word32

uToAttrLine :: UAttrLine -> AttrLine
uToAttrLine :: UAttrLine -> AttrLine
uToAttrLine v :: UAttrLine
v = (Word32 -> AttrCharW32) -> [Word32] -> AttrLine
forall a b. (a -> b) -> [a] -> [b]
map Word32 -> AttrCharW32
Color.AttrCharW32 ([Word32] -> AttrLine) -> [Word32] -> AttrLine
forall a b. (a -> b) -> a -> b
$ UAttrLine -> [Word32]
forall a. Unbox a => Vector a -> [a]
U.toList UAttrLine
v

attrLineToU :: AttrLine -> UAttrLine
attrLineToU :: AttrLine -> UAttrLine
attrLineToU l :: AttrLine
l = [Word32] -> UAttrLine
forall a. Unbox a => [a] -> Vector a
U.fromList ([Word32] -> UAttrLine) -> [Word32] -> UAttrLine
forall a b. (a -> b) -> a -> b
$ (AttrCharW32 -> Word32) -> AttrLine -> [Word32]
forall a b. (a -> b) -> [a] -> [b]
map AttrCharW32 -> Word32
Color.attrCharW32 AttrLine
l

-- * Msg

-- | The type of a single game message.
data Msg = Msg
  { Msg -> AttrLine
msgLine  :: AttrLine  -- ^ the colours and characters of the message;
                          --   not just text, in case there was some colour
                          --   unrelated to msg class
  , Msg -> MsgClass
msgClass :: MsgClass  -- ^ whether message should be displayed,
                          --   recorded in history, with what color, etc.
  }
  deriving (Int -> Msg -> ShowS
[Msg] -> ShowS
Msg -> String
(Int -> Msg -> ShowS)
-> (Msg -> String) -> ([Msg] -> ShowS) -> Show Msg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Msg] -> ShowS
$cshowList :: [Msg] -> ShowS
show :: Msg -> String
$cshow :: Msg -> String
showsPrec :: Int -> Msg -> ShowS
$cshowsPrec :: Int -> Msg -> ShowS
Show, Msg -> Msg -> Bool
(Msg -> Msg -> Bool) -> (Msg -> Msg -> Bool) -> Eq Msg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Msg -> Msg -> Bool
$c/= :: Msg -> Msg -> Bool
== :: Msg -> Msg -> Bool
$c== :: Msg -> Msg -> Bool
Eq, (forall x. Msg -> Rep Msg x)
-> (forall x. Rep Msg x -> Msg) -> Generic Msg
forall x. Rep Msg x -> Msg
forall x. Msg -> Rep Msg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Msg x -> Msg
$cfrom :: forall x. Msg -> Rep Msg x
Generic)

instance Binary Msg

toMsg :: Maybe (EM.EnumMap MsgClass Color.Color) -> MsgClass -> Text -> Msg
toMsg :: Maybe (EnumMap MsgClass Color) -> MsgClass -> Text -> Msg
toMsg mem :: Maybe (EnumMap MsgClass Color)
mem msgClass :: MsgClass
msgClass l :: Text
l =
  let findColorInConfig :: EnumMap MsgClass Color -> Color
findColorInConfig = Color -> MsgClass -> EnumMap MsgClass Color -> Color
forall k a. Enum k => a -> k -> EnumMap k a -> a
EM.findWithDefault Color
Color.White MsgClass
msgClass
      color :: Color
color = Color
-> (EnumMap MsgClass Color -> Color)
-> Maybe (EnumMap MsgClass Color)
-> Color
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (MsgClass -> Color
msgColor MsgClass
msgClass) EnumMap MsgClass Color -> Color
findColorInConfig Maybe (EnumMap MsgClass Color)
mem
      msgLine :: AttrLine
msgLine = Color -> Text -> AttrLine
textFgToAL Color
color Text
l
  in $WMsg :: AttrLine -> MsgClass -> Msg
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  -- our non-projectile actors are not hit
  | MsgRangedUs
  | MsgRare
  | MsgVeryRare
  | MsgMeleePowerfulWe
  | MsgMeleePowerfulUs
  | MsgMeleeInterestingWe
  | MsgMeleeInterestingUs
  | MsgMelee  -- our non-projectile actors are not hit
  | MsgMeleeUs
  | MsgDone
  | MsgAtFeetMajor
  | MsgAtFeet
  | MsgNumeric
  | MsgSpam
  | MsgMacro
  | MsgRunStop
  | MsgPrompt
  | MsgPromptFocus
  | MsgAlert
  | MsgStopPlayback
 deriving (Int -> MsgClass -> ShowS
[MsgClass] -> ShowS
MsgClass -> String
(Int -> MsgClass -> ShowS)
-> (MsgClass -> String) -> ([MsgClass] -> ShowS) -> Show MsgClass
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MsgClass] -> ShowS
$cshowList :: [MsgClass] -> ShowS
show :: MsgClass -> String
$cshow :: MsgClass -> String
showsPrec :: Int -> MsgClass -> ShowS
$cshowsPrec :: Int -> MsgClass -> ShowS
Show, ReadPrec [MsgClass]
ReadPrec MsgClass
Int -> ReadS MsgClass
ReadS [MsgClass]
(Int -> ReadS MsgClass)
-> ReadS [MsgClass]
-> ReadPrec MsgClass
-> ReadPrec [MsgClass]
-> Read MsgClass
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [MsgClass]
$creadListPrec :: ReadPrec [MsgClass]
readPrec :: ReadPrec MsgClass
$creadPrec :: ReadPrec MsgClass
readList :: ReadS [MsgClass]
$creadList :: ReadS [MsgClass]
readsPrec :: Int -> ReadS MsgClass
$creadsPrec :: Int -> ReadS MsgClass
Read, MsgClass -> MsgClass -> Bool
(MsgClass -> MsgClass -> Bool)
-> (MsgClass -> MsgClass -> Bool) -> Eq MsgClass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MsgClass -> MsgClass -> Bool
$c/= :: MsgClass -> MsgClass -> Bool
== :: MsgClass -> MsgClass -> Bool
$c== :: MsgClass -> MsgClass -> Bool
Eq, Int -> MsgClass
MsgClass -> Int
MsgClass -> [MsgClass]
MsgClass -> MsgClass
MsgClass -> MsgClass -> [MsgClass]
MsgClass -> MsgClass -> MsgClass -> [MsgClass]
(MsgClass -> MsgClass)
-> (MsgClass -> MsgClass)
-> (Int -> MsgClass)
-> (MsgClass -> Int)
-> (MsgClass -> [MsgClass])
-> (MsgClass -> MsgClass -> [MsgClass])
-> (MsgClass -> MsgClass -> [MsgClass])
-> (MsgClass -> MsgClass -> MsgClass -> [MsgClass])
-> Enum MsgClass
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: MsgClass -> MsgClass -> MsgClass -> [MsgClass]
$cenumFromThenTo :: MsgClass -> MsgClass -> MsgClass -> [MsgClass]
enumFromTo :: MsgClass -> MsgClass -> [MsgClass]
$cenumFromTo :: MsgClass -> MsgClass -> [MsgClass]
enumFromThen :: MsgClass -> MsgClass -> [MsgClass]
$cenumFromThen :: MsgClass -> MsgClass -> [MsgClass]
enumFrom :: MsgClass -> [MsgClass]
$cenumFrom :: MsgClass -> [MsgClass]
fromEnum :: MsgClass -> Int
$cfromEnum :: MsgClass -> Int
toEnum :: Int -> MsgClass
$ctoEnum :: Int -> MsgClass
pred :: MsgClass -> MsgClass
$cpred :: MsgClass -> MsgClass
succ :: MsgClass -> MsgClass
$csucc :: MsgClass -> MsgClass
Enum, (forall x. MsgClass -> Rep MsgClass x)
-> (forall x. Rep MsgClass x -> MsgClass) -> Generic MsgClass
forall x. Rep MsgClass x -> MsgClass
forall x. MsgClass -> Rep MsgClass x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MsgClass x -> MsgClass
$cfrom :: forall x. MsgClass -> Rep MsgClass x
Generic)

instance NFData MsgClass

instance Binary MsgClass

isSavedToHistory :: MsgClass -> Bool
isSavedToHistory :: MsgClass -> Bool
isSavedToHistory MsgNumeric = Bool
False
isSavedToHistory MsgSpam = Bool
False
isSavedToHistory MsgMacro = Bool
False
isSavedToHistory MsgRunStop = Bool
False
isSavedToHistory MsgPrompt = Bool
False
isSavedToHistory MsgPromptFocus = Bool
False
isSavedToHistory MsgAlert = Bool
False
isSavedToHistory MsgStopPlayback = Bool
False
isSavedToHistory _ = Bool
True

isDisplayed :: MsgClass -> Bool
isDisplayed :: MsgClass -> Bool
isDisplayed MsgRunStop = Bool
False
isDisplayed MsgNumeric = Bool
False
isDisplayed MsgSpam = Bool
False
isDisplayed MsgMacro = Bool
False
isDisplayed MsgStopPlayback = Bool
False
isDisplayed _ = Bool
True

interruptsRunning :: MsgClass -> Bool
interruptsRunning :: MsgClass -> Bool
interruptsRunning MsgHeard = Bool
False
  -- MsgHeardClose interrupts, even if running started while hearing close
interruptsRunning MsgEffectMinor = Bool
False
interruptsRunning MsgItemDisco = Bool
False
interruptsRunning MsgItemMove = Bool
False
interruptsRunning MsgActionMinor = Bool
False
interruptsRunning MsgAtFeet = Bool
False
interruptsRunning MsgNumeric = Bool
False
interruptsRunning MsgSpam = Bool
False
interruptsRunning MsgMacro = Bool
False
interruptsRunning MsgRunStop = Bool
False
interruptsRunning MsgPrompt = Bool
False
interruptsRunning MsgPromptFocus = Bool
False
  -- MsgAlert means something went wrong, so alarm
interruptsRunning _ = Bool
True

disturbsResting :: MsgClass -> Bool
disturbsResting :: MsgClass -> Bool
disturbsResting MsgHeard = Bool
False
disturbsResting MsgHeardClose = Bool
False -- handled separately
disturbsResting MsgLeader = Bool
False -- handled separately
disturbsResting MsgEffectMinor = Bool
False
disturbsResting MsgItemDisco = Bool
False
disturbsResting MsgItemMove = Bool
False
disturbsResting MsgActionMinor = Bool
False
disturbsResting MsgAtFeet = Bool
False
disturbsResting MsgNumeric = Bool
False
disturbsResting MsgSpam = Bool
False
disturbsResting MsgMacro = Bool
False
disturbsResting MsgRunStop = Bool
False
disturbsResting MsgPrompt = Bool
False
disturbsResting MsgPromptFocus = Bool
False
  -- MsgAlert means something went wrong, so alarm
disturbsResting _ = Bool
True

-- Only player's non-projectile actors getting hit introduce subjects,
-- because only such hits are guaranteed to be perceived.
-- Here we also mark friends being hit, but that's a safe approximation.
-- We also mark the messages that use the introduced subjects
-- by referring to them via pronouns. They can't be moved freely either.
bindsPronouns :: MsgClass -> Bool
bindsPronouns :: MsgClass -> Bool
bindsPronouns MsgRangedPowerfulUs = Bool
True
bindsPronouns MsgRangedUs = Bool
True
bindsPronouns MsgMeleePowerfulUs = Bool
True
bindsPronouns MsgMeleeInterestingUs = Bool
True
bindsPronouns MsgMeleeUs = Bool
True
bindsPronouns MsgLongerUs = Bool
True
bindsPronouns _ = Bool
False

-- Only @White@ color gets replaced by this one.
msgColor :: MsgClass -> Color.Color
msgColor :: MsgClass -> Color
msgColor MsgAdmin = Color
Color.White
msgColor MsgBecome = Color
Color.BrBlue  -- similar color to cyan and role to Effect
msgColor MsgNoLonger = Color
Color.Blue
msgColor MsgLongerUs = Color
Color.White  -- not important enough
msgColor MsgLonger = Color
Color.White  -- not important enough
msgColor MsgItemCreation = Color
Color.BrBlue
msgColor MsgItemDestruction = Color
Color.Blue
msgColor MsgDeathGood = Color
Color.BrGreen
msgColor MsgDeathBad = Color
Color.BrRed
msgColor MsgDeath = Color
Color.White
msgColor MsgDeathThreat = Color
Color.BrRed
msgColor MsgLeader = Color
Color.White
msgColor MsgDiplomacy = Color
Color.BrYellow
msgColor MsgOutcome = Color
Color.BrWhite
msgColor MsgPlot = Color
Color.White
msgColor MsgLandscape = Color
Color.White
msgColor MsgTileDisco = Color
Color.Magenta
msgColor MsgItemDisco = Color
Color.BrMagenta
msgColor MsgActorSpot = Color
Color.White  -- too common
msgColor MsgFirstEnemySpot = Color
Color.Red
msgColor MsgItemSpot = Color
Color.White
msgColor MsgItemMove = Color
Color.White
msgColor MsgAction = Color
Color.White
msgColor MsgActionMinor = Color
Color.White
msgColor MsgEffectMajor = Color
Color.BrCyan
msgColor MsgEffect = Color
Color.Cyan
msgColor MsgEffectMinor = Color
Color.White
msgColor MsgMisc = Color
Color.White
msgColor MsgHeardClose = Color
Color.BrYellow
msgColor MsgHeard = Color
Color.Brown
msgColor MsgFocus = Color
Color.Green
msgColor MsgWarning = Color
Color.BrYellow
msgColor MsgRangedPowerfulWe = Color
Color.Green
msgColor MsgRangedPowerfulUs = Color
Color.Red
msgColor MsgRanged = Color
Color.White
msgColor MsgRangedUs = Color
Color.White
msgColor MsgRare = Color
Color.Cyan
msgColor MsgVeryRare = Color
Color.BrCyan
msgColor MsgMeleePowerfulWe = Color
Color.Green
msgColor MsgMeleePowerfulUs = Color
Color.Red
msgColor MsgMeleeInterestingWe = Color
Color.Green
msgColor MsgMeleeInterestingUs = Color
Color.Red
msgColor MsgMelee = Color
Color.White
msgColor MsgMeleeUs = Color
Color.White
msgColor MsgDone = Color
Color.White
msgColor MsgAtFeetMajor = Color
Color.White
msgColor MsgAtFeet = Color
Color.White
msgColor MsgNumeric = Color
Color.White
msgColor MsgSpam = Color
Color.White
msgColor MsgMacro = Color
Color.White
msgColor MsgRunStop = Color
Color.White
msgColor MsgPrompt = Color
Color.White
msgColor MsgPromptFocus = Color
Color.Green
msgColor MsgAlert = Color
Color.BrYellow
msgColor MsgStopPlayback = Color
Color.BrYellow

-- * Report

data RepMsgN = RepMsgN {RepMsgN -> Msg
repMsg :: Msg, RepMsgN -> Int
_repN :: Int}
  deriving (Int -> RepMsgN -> ShowS
[RepMsgN] -> ShowS
RepMsgN -> String
(Int -> RepMsgN -> ShowS)
-> (RepMsgN -> String) -> ([RepMsgN] -> ShowS) -> Show RepMsgN
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RepMsgN] -> ShowS
$cshowList :: [RepMsgN] -> ShowS
show :: RepMsgN -> String
$cshow :: RepMsgN -> String
showsPrec :: Int -> RepMsgN -> ShowS
$cshowsPrec :: Int -> RepMsgN -> ShowS
Show, (forall x. RepMsgN -> Rep RepMsgN x)
-> (forall x. Rep RepMsgN x -> RepMsgN) -> Generic RepMsgN
forall x. Rep RepMsgN x -> RepMsgN
forall x. RepMsgN -> Rep RepMsgN x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RepMsgN x -> RepMsgN
$cfrom :: forall x. RepMsgN -> Rep RepMsgN x
Generic)

instance Binary RepMsgN

-- | The set of messages, with repetitions, to show at the screen at once.
newtype Report = Report [RepMsgN]
  deriving (Int -> Report -> ShowS
[Report] -> ShowS
Report -> String
(Int -> Report -> ShowS)
-> (Report -> String) -> ([Report] -> ShowS) -> Show Report
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Report] -> ShowS
$cshowList :: [Report] -> ShowS
show :: Report -> String
$cshow :: Report -> String
showsPrec :: Int -> Report -> ShowS
$cshowsPrec :: Int -> Report -> ShowS
Show, Get Report
[Report] -> Put
Report -> Put
(Report -> Put) -> Get Report -> ([Report] -> Put) -> Binary Report
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Report] -> Put
$cputList :: [Report] -> Put
get :: Get Report
$cget :: Get Report
put :: Report -> Put
$cput :: Report -> Put
Binary)

-- | Empty set of messages.
emptyReport :: Report
emptyReport :: Report
emptyReport = [RepMsgN] -> Report
Report []

-- | Test if the set of messages is empty.
nullReport :: Report -> Bool
nullReport :: Report -> Bool
nullReport (Report l :: [RepMsgN]
l) = [RepMsgN] -> Bool
forall a. [a] -> Bool
null [RepMsgN]
l

-- | Add a message to the end of the report.
snocReport :: Report -> Msg -> Int -> Report
snocReport :: Report -> Msg -> Int -> Report
snocReport (Report ![RepMsgN]
r) y :: Msg
y n :: Int
n =
  if AttrLine -> Bool
forall a. [a] -> Bool
null (AttrLine -> Bool) -> AttrLine -> Bool
forall a b. (a -> b) -> a -> b
$ Msg -> AttrLine
msgLine Msg
y then [RepMsgN] -> Report
Report [RepMsgN]
r else [RepMsgN] -> Report
Report ([RepMsgN] -> Report) -> [RepMsgN] -> Report
forall a b. (a -> b) -> a -> b
$ Msg -> Int -> RepMsgN
RepMsgN Msg
y Int
n RepMsgN -> [RepMsgN] -> [RepMsgN]
forall a. a -> [a] -> [a]
: [RepMsgN]
r

-- | Add a message to the start of report.
consReport :: Msg -> Report -> Report
consReport :: Msg -> Report -> Report
consReport Msg{msgLine :: Msg -> AttrLine
msgLine=[]} rep :: Report
rep = Report
rep
consReport y :: Msg
y (Report r :: [RepMsgN]
r) = [RepMsgN] -> Report
Report ([RepMsgN] -> Report) -> [RepMsgN] -> Report
forall a b. (a -> b) -> a -> b
$ [RepMsgN]
r [RepMsgN] -> [RepMsgN] -> [RepMsgN]
forall a. [a] -> [a] -> [a]
++ [Msg -> Int -> RepMsgN
RepMsgN Msg
y 1]

-- | Render a report as a (possibly very long) 'AttrLine'. Filter out
-- messages not meant for display.
renderReport :: Report -> AttrLine
renderReport :: Report -> AttrLine
renderReport (Report r :: [RepMsgN]
r) =
  let rep :: Report
rep = [RepMsgN] -> Report
Report ([RepMsgN] -> Report) -> [RepMsgN] -> Report
forall a b. (a -> b) -> a -> b
$ (RepMsgN -> Bool) -> [RepMsgN] -> [RepMsgN]
forall a. (a -> Bool) -> [a] -> [a]
filter (MsgClass -> Bool
isDisplayed (MsgClass -> Bool) -> (RepMsgN -> MsgClass) -> RepMsgN -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> MsgClass
msgClass (Msg -> MsgClass) -> (RepMsgN -> Msg) -> RepMsgN -> MsgClass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepMsgN -> Msg
repMsg) [RepMsgN]
r
  in Report -> AttrLine
renderWholeReport Report
rep

-- | Render a report as a (possibly very long) 'AttrLine'.
renderWholeReport :: Report -> AttrLine
renderWholeReport :: Report -> AttrLine
renderWholeReport (Report []) = []
renderWholeReport (Report (x :: RepMsgN
x : xs :: [RepMsgN]
xs)) =
  Report -> AttrLine
renderWholeReport ([RepMsgN] -> Report
Report [RepMsgN]
xs) AttrLine -> AttrLine -> AttrLine
<+:> RepMsgN -> AttrLine
renderRepetition RepMsgN
x

renderRepetition :: RepMsgN -> AttrLine
renderRepetition :: RepMsgN -> AttrLine
renderRepetition (RepMsgN s :: Msg
s 0) = Msg -> AttrLine
msgLine Msg
s
renderRepetition (RepMsgN s :: Msg
s 1) = Msg -> AttrLine
msgLine Msg
s
renderRepetition (RepMsgN s :: Msg
s n :: Int
n) = Msg -> AttrLine
msgLine Msg
s AttrLine -> AttrLine -> AttrLine
forall a. [a] -> [a] -> [a]
++ String -> AttrLine
stringToAL ("<x" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ ">")

anyInReport :: (MsgClass -> Bool) -> Report -> Bool
anyInReport :: (MsgClass -> Bool) -> Report -> Bool
anyInReport f :: MsgClass -> Bool
f (Report xns :: [RepMsgN]
xns) = (RepMsgN -> Bool) -> [RepMsgN] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (MsgClass -> Bool
f (MsgClass -> Bool) -> (RepMsgN -> MsgClass) -> RepMsgN -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> MsgClass
msgClass (Msg -> MsgClass) -> (RepMsgN -> Msg) -> RepMsgN -> MsgClass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepMsgN -> Msg
repMsg) [RepMsgN]
xns

-- * History

-- | The history of reports. This is a ring buffer of the given length
-- containing old archived history and two most recent reports stored
-- separately.
data History = History
  { History -> Report
newReport       :: Report
  , History -> Time
newTime         :: Time
  , History -> Report
oldReport       :: Report
  , History -> Time
oldTime         :: Time
  , History -> RingBuffer UAttrLine
archivedHistory :: RB.RingBuffer UAttrLine }
  deriving (Int -> History -> ShowS
[History] -> ShowS
History -> String
(Int -> History -> ShowS)
-> (History -> String) -> ([History] -> ShowS) -> Show History
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [History] -> ShowS
$cshowList :: [History] -> ShowS
show :: History -> String
$cshow :: History -> String
showsPrec :: Int -> History -> ShowS
$cshowsPrec :: Int -> History -> ShowS
Show, (forall x. History -> Rep History x)
-> (forall x. Rep History x -> History) -> Generic History
forall x. Rep History x -> History
forall x. History -> Rep History x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep History x -> History
$cfrom :: forall x. History -> Rep History x
Generic)

instance Binary History

-- | Empty history of the given maximal length.
emptyHistory :: Int -> History
emptyHistory :: Int -> History
emptyHistory size :: Int
size =
  let ringBufferSize :: Int
ringBufferSize = Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1  -- a report resides outside the buffer
  in Report -> Time -> Report -> Time -> RingBuffer UAttrLine -> History
History Report
emptyReport Time
timeZero Report
emptyReport Time
timeZero
             (Int -> UAttrLine -> RingBuffer UAttrLine
forall a. Int -> a -> RingBuffer a
RB.empty Int
ringBufferSize UAttrLine
forall a. Unbox a => Vector a
U.empty)

scrapRepetition :: History -> Maybe History
scrapRepetition :: History -> Maybe History
scrapRepetition History{ newReport :: History -> Report
newReport = Report newMsgs :: [RepMsgN]
newMsgs
                       , oldReport :: History -> Report
oldReport = Report oldMsgs :: [RepMsgN]
oldMsgs
                       , .. } =
  case [RepMsgN]
newMsgs of
    -- We take into account only first message of the new report,
    -- because others were deduplicated as they were added.
    -- We keep the message in the new report, because it should not
    -- vanish from the screen. In this way the message may be passed
    -- along many reports.
    RepMsgN s1 :: Msg
s1 n1 :: Int
n1 : rest1 :: [RepMsgN]
rest1 ->
      let commutative :: Msg -> Bool
commutative s :: Msg
s = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ MsgClass -> Bool
bindsPronouns (MsgClass -> Bool) -> MsgClass -> Bool
forall a b. (a -> b) -> a -> b
$ Msg -> MsgClass
msgClass Msg
s
          f :: RepMsgN -> Bool
f (RepMsgN s2 :: Msg
s2 _) = Msg -> AttrLine
msgLine Msg
s1 AttrLine -> AttrLine -> Bool
forall a. Eq a => a -> a -> Bool
== Msg -> AttrLine
msgLine Msg
s2
      in case (RepMsgN -> Bool) -> [RepMsgN] -> ([RepMsgN], [RepMsgN])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break RepMsgN -> Bool
f [RepMsgN]
rest1 of
        (_, []) | Msg -> Bool
commutative Msg
s1 -> case (RepMsgN -> Bool) -> [RepMsgN] -> ([RepMsgN], [RepMsgN])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break RepMsgN -> Bool
f [RepMsgN]
oldMsgs of
          (noDup :: [RepMsgN]
noDup, RepMsgN s2 :: Msg
s2 n2 :: Int
n2 : rest2 :: [RepMsgN]
rest2) ->
            -- We keep the occurence of the message in the new report only.
            let newReport :: Report
newReport = [RepMsgN] -> Report
Report ([RepMsgN] -> Report) -> [RepMsgN] -> Report
forall a b. (a -> b) -> a -> b
$ Msg -> Int -> RepMsgN
RepMsgN Msg
s2 (Int
n1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n2) RepMsgN -> [RepMsgN] -> [RepMsgN]
forall a. a -> [a] -> [a]
: [RepMsgN]
rest1
                oldReport :: Report
oldReport = [RepMsgN] -> Report
Report ([RepMsgN] -> Report) -> [RepMsgN] -> Report
forall a b. (a -> b) -> a -> b
$ [RepMsgN]
noDup [RepMsgN] -> [RepMsgN] -> [RepMsgN]
forall a. [a] -> [a] -> [a]
++ [RepMsgN]
rest2
            in History -> Maybe History
forall a. a -> Maybe a
Just $WHistory :: Report -> Time -> Report -> Time -> RingBuffer UAttrLine -> History
History{..}
          _ -> Maybe History
forall a. Maybe a
Nothing
        (noDup :: [RepMsgN]
noDup, RepMsgN s2 :: Msg
s2 n2 :: Int
n2 : rest2 :: [RepMsgN]
rest2) | Msg -> Bool
commutative Msg
s1
                                         Bool -> Bool -> Bool
|| (RepMsgN -> Bool) -> [RepMsgN] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Msg -> Bool
commutative (Msg -> Bool) -> (RepMsgN -> Msg) -> RepMsgN -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepMsgN -> Msg
repMsg) [RepMsgN]
noDup ->
          -- We keep the older (and so, oldest) occurence of the message,
          -- to avoid visual disruption by moving the message around.
          let newReport :: Report
newReport = [RepMsgN] -> Report
Report ([RepMsgN] -> Report) -> [RepMsgN] -> Report
forall a b. (a -> b) -> a -> b
$ [RepMsgN]
noDup [RepMsgN] -> [RepMsgN] -> [RepMsgN]
forall a. [a] -> [a] -> [a]
++ Msg -> Int -> RepMsgN
RepMsgN Msg
s2 (Int
n1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n2) RepMsgN -> [RepMsgN] -> [RepMsgN]
forall a. a -> [a] -> [a]
: [RepMsgN]
rest2
              oldReport :: Report
oldReport = [RepMsgN] -> Report
Report [RepMsgN]
oldMsgs
          in History -> Maybe History
forall a. a -> Maybe a
Just $WHistory :: Report -> Time -> Report -> Time -> RingBuffer UAttrLine -> History
History{..}
        _ -> Maybe History
forall a. Maybe a
Nothing
    _ -> Maybe History
forall a. Maybe a
Nothing  -- empty new report

-- | Add a message to the new report of history, eliminating a possible
-- duplicate and noting its existence in the result.
addToReport :: History -> Msg -> Int -> Time -> (History, Bool)
addToReport :: History -> Msg -> Int -> Time -> (History, Bool)
addToReport History{..} msg :: Msg
msg n :: Int
n time :: Time
time =
  let newH :: History
newH = $WHistory :: Report -> Time -> Report -> Time -> RingBuffer UAttrLine -> History
History{newReport :: Report
newReport = Report -> Msg -> Int -> Report
snocReport Report
newReport Msg
msg Int
n, newTime :: Time
newTime = Time
time, ..}
  in case History -> Maybe History
scrapRepetition History
newH of
    Just scrappedH :: History
scrappedH -> (History
scrappedH, Bool
True)
    Nothing -> (History
newH, Bool
False)

-- | Archive old report to history, filtering out messages with 0 duplicates
-- and prompts. Set up new report with a new timestamp.
archiveReport :: History -> History
archiveReport :: History -> History
archiveReport History{newReport :: History -> Report
newReport=Report newMsgs :: [RepMsgN]
newMsgs, ..} =
  let f :: RepMsgN -> Bool
f (RepMsgN _ n :: Int
n) = Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
      newReportNon0 :: Report
newReportNon0 = [RepMsgN] -> Report
Report ([RepMsgN] -> Report) -> [RepMsgN] -> Report
forall a b. (a -> b) -> a -> b
$ (RepMsgN -> Bool) -> [RepMsgN] -> [RepMsgN]
forall a. (a -> Bool) -> [a] -> [a]
filter RepMsgN -> Bool
f [RepMsgN]
newMsgs
  in if Report -> Bool
nullReport Report
newReportNon0
     then -- Drop empty new report.
          Report -> Time -> Report -> Time -> RingBuffer UAttrLine -> History
History Report
emptyReport Time
timeZero Report
oldReport Time
oldTime RingBuffer UAttrLine
archivedHistory
     else let lU :: [UAttrLine]
lU = (AttrLine -> UAttrLine) -> [AttrLine] -> [UAttrLine]
forall a b. (a -> b) -> [a] -> [b]
map AttrLine -> UAttrLine
attrLineToU ([AttrLine] -> [UAttrLine]) -> [AttrLine] -> [UAttrLine]
forall a b. (a -> b) -> a -> b
$ Time -> Report -> [AttrLine]
renderTimeReport Time
oldTime Report
oldReport
          in Report -> Time -> Report -> Time -> RingBuffer UAttrLine -> History
History Report
emptyReport Time
timeZero Report
newReportNon0 Time
newTime
             (RingBuffer UAttrLine -> History)
-> RingBuffer UAttrLine -> History
forall a b. (a -> b) -> a -> b
$ (RingBuffer UAttrLine -> UAttrLine -> RingBuffer UAttrLine)
-> RingBuffer UAttrLine -> [UAttrLine] -> RingBuffer UAttrLine
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\ !RingBuffer UAttrLine
h !UAttrLine
v -> UAttrLine -> RingBuffer UAttrLine -> RingBuffer UAttrLine
forall a. a -> RingBuffer a -> RingBuffer a
RB.cons UAttrLine
v RingBuffer UAttrLine
h) RingBuffer UAttrLine
archivedHistory ([UAttrLine] -> [UAttrLine]
forall a. [a] -> [a]
reverse [UAttrLine]
lU)

renderTimeReport :: Time -> Report -> [AttrLine]
renderTimeReport :: Time -> Report -> [AttrLine]
renderTimeReport !Time
t (Report r :: [RepMsgN]
r) =
  let turns :: Int
turns = Time
t Time -> Time -> Int
`timeFitUp` Time
timeTurn
      rep :: Report
rep = [RepMsgN] -> Report
Report ([RepMsgN] -> Report) -> [RepMsgN] -> Report
forall a b. (a -> b) -> a -> b
$ (RepMsgN -> Bool) -> [RepMsgN] -> [RepMsgN]
forall a. (a -> Bool) -> [a] -> [a]
filter (MsgClass -> Bool
isSavedToHistory (MsgClass -> Bool) -> (RepMsgN -> MsgClass) -> RepMsgN -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> MsgClass
msgClass (Msg -> MsgClass) -> (RepMsgN -> Msg) -> RepMsgN -> MsgClass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepMsgN -> Msg
repMsg) [RepMsgN]
r
  in if Report -> Bool
nullReport Report
rep
     then []
     else [String -> AttrLine
stringToAL (Int -> String
forall a. Show a => a -> String
show Int
turns String -> ShowS
forall a. [a] -> [a] -> [a]
++ ": ") AttrLine -> AttrLine -> AttrLine
forall a. [a] -> [a] -> [a]
++ Report -> AttrLine
renderReport Report
rep]

lengthHistory :: History -> Int
lengthHistory :: History -> Int
lengthHistory History{Report
oldReport :: Report
oldReport :: History -> Report
oldReport, RingBuffer UAttrLine
archivedHistory :: RingBuffer UAttrLine
archivedHistory :: History -> RingBuffer UAttrLine
archivedHistory} =
  RingBuffer UAttrLine -> Int
forall a. RingBuffer a -> Int
RB.length RingBuffer UAttrLine
archivedHistory
  Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [AttrLine] -> Int
forall a. [a] -> Int
length (Time -> Report -> [AttrLine]
renderTimeReport Time
timeZero Report
oldReport)
      -- matches @renderHistory@

-- | Render history as many lines of text. New report is not rendered.
-- It's expected to be empty when history is shown.
renderHistory :: History -> [AttrLine]
renderHistory :: History -> [AttrLine]
renderHistory History{..} = (UAttrLine -> AttrLine) -> [UAttrLine] -> [AttrLine]
forall a b. (a -> b) -> [a] -> [b]
map UAttrLine -> AttrLine
uToAttrLine (RingBuffer UAttrLine -> [UAttrLine]
forall a. RingBuffer a -> [a]
RB.toList RingBuffer UAttrLine
archivedHistory)
                            [AttrLine] -> [AttrLine] -> [AttrLine]
forall a. [a] -> [a] -> [a]
++ Time -> Report -> [AttrLine]
renderTimeReport Time
oldTime Report
oldReport