{-# 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 :: 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
data Msg = Msg
{ Msg -> AttrLine
msgLine :: AttrLine
, Msg -> MsgClass
msgClass :: MsgClass
}
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
| MsgRangedUs
| MsgRare
| MsgVeryRare
| MsgMeleePowerfulWe
| MsgMeleePowerfulUs
| MsgMeleeInterestingWe
| MsgMeleeInterestingUs
| MsgMelee
| 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
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
interruptsRunning _ = Bool
True
disturbsResting :: MsgClass -> Bool
disturbsResting :: MsgClass -> Bool
disturbsResting MsgHeard = Bool
False
disturbsResting MsgHeardClose = Bool
False
disturbsResting MsgLeader = Bool
False
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
disturbsResting _ = Bool
True
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
msgColor :: MsgClass -> Color.Color
msgColor :: MsgClass -> Color
msgColor MsgAdmin = Color
Color.White
msgColor MsgBecome = Color
Color.BrBlue
msgColor MsgNoLonger = Color
Color.Blue
msgColor MsgLongerUs = Color
Color.White
msgColor MsgLonger = Color
Color.White
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
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
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
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)
emptyReport :: Report
emptyReport :: Report
emptyReport = [RepMsgN] -> Report
Report []
nullReport :: Report -> Bool
nullReport :: Report -> Bool
nullReport (Report l :: [RepMsgN]
l) = [RepMsgN] -> Bool
forall a. [a] -> Bool
null [RepMsgN]
l
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
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]
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
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
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
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
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
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) ->
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 ->
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
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)
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
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)
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