module Game.LambdaHack.Common.Msg
( makePhrase, makeSentence
, Msg, (<>), (<+>), tshow, toWidth, moreMsg, endMsg, yesnoMsg, truncateMsg
, Report, emptyReport, nullReport, singletonReport, addMsg, prependMsg
, splitReport, renderReport, findInReport, lastMsgOfReport
, History, emptyHistory, lengthHistory
, addReport, renderHistory, lastReportOfHistory
, Overlay(overlay), emptyOverlay, truncateToOverlay, toOverlay
, Slideshow(slideshow), splitOverlay, toSlideshow
, encodeLine, encodeOverlay, ScreenLine, toScreenLine, splitText
)
where
import Control.Applicative
import Control.Exception.Assert.Sugar
import Data.Binary
import qualified Data.ByteString.Char8 as BS
import Data.Int (Int32)
import Data.List
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Vector.Binary ()
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U
import qualified NLP.Miniutter.English as MU
import Game.LambdaHack.Common.Color
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.RingBuffer as RB
import Game.LambdaHack.Common.Time
infixr 6 <+>
(<+>) :: Text -> Text -> Text
(<+>) = (MU.<+>)
tshow :: Show a => a -> Text
tshow x = T.pack $ show x
toWidth :: Int -> Text -> Text
toWidth n x = T.take n (T.justifyLeft n ' ' x)
makePhrase, makeSentence :: [MU.Part] -> Text
makePhrase = MU.makePhrase MU.defIrregular
makeSentence = MU.makeSentence MU.defIrregular
type Msg = Text
moreMsg :: Msg
moreMsg = "--more-- "
endMsg :: Msg
endMsg = "--end-- "
yesnoMsg :: Msg
yesnoMsg = "[yn]"
truncateMsg :: X -> Text -> Text
truncateMsg w xsRaw =
let xs = case T.lines xsRaw of
[] -> xsRaw
[line] -> line
line : _ -> T.justifyLeft (w + 1) ' ' line
len = T.length xs
in case compare w len of
LT -> T.snoc (T.take (w 1) xs) '$'
EQ -> xs
GT -> if T.null xs || T.last xs == ' '
then xs
else T.snoc xs ' '
newtype Report = Report [(BS.ByteString, Int)]
deriving (Show, Binary)
emptyReport :: Report
emptyReport = Report []
nullReport :: Report -> Bool
nullReport (Report l) = null l
singletonReport :: Msg -> Report
singletonReport = addMsg emptyReport
addMsg :: Report -> Msg -> Report
addMsg r m | T.null m = r
addMsg (Report ((x, n) : xns)) y' | x == y =
Report $ (y, n + 1) : xns
where y = encodeUtf8 y'
addMsg (Report xns) y = Report $ (encodeUtf8 y, 1) : xns
prependMsg :: Msg -> Report -> Report
prependMsg m r | T.null m = r
prependMsg y (Report xns) = Report $ xns ++ [(encodeUtf8 y, 1)]
splitReport :: X -> Report -> Overlay
splitReport w r = toOverlay $ splitReportList w r
splitReportList :: X -> Report -> [Text]
splitReportList w r = splitText w $ renderReport r
renderReport :: Report -> Text
renderReport (Report []) = T.empty
renderReport (Report (xn : xs)) =
renderReport (Report xs) <+> renderRepetition xn
renderRepetition :: (BS.ByteString, Int) -> Text
renderRepetition (s, 1) = decodeUtf8 s
renderRepetition (s, n) = decodeUtf8 s <> "<x" <> tshow n <> ">"
findInReport :: (BS.ByteString -> Bool) -> Report -> Maybe BS.ByteString
findInReport f (Report xns) = find f $ map fst xns
lastMsgOfReport :: Report -> (BS.ByteString, Report)
lastMsgOfReport (Report rep) = case rep of
[] -> assert `failure` rep
(lmsg, 1) : repRest -> (lmsg, Report repRest)
(lmsg, n) : repRest -> (lmsg, Report $ (lmsg, n 1) : repRest)
splitText :: X -> Text -> [Text]
splitText w xs = concatMap (splitText' w . T.stripStart) $ T.lines xs
splitText' :: X -> Text -> [Text]
splitText' w xs
| w >= T.length xs = [xs]
| otherwise =
let (pre, post) = T.splitAt w xs
(ppre, ppost) = T.break (== ' ') $ T.reverse pre
testPost = T.stripEnd ppost
in if T.null testPost
then pre : splitText w post
else T.reverse ppost : splitText w (T.reverse ppre <> post)
newtype History = History (RB.RingBuffer (Time, Report))
deriving (Show, Binary)
emptyHistory :: Int -> History
emptyHistory size = History $ RB.empty size (timeZero, Report [])
addReport :: History -> Time -> Report -> History
addReport h _ (Report []) = h
addReport !(History rb) !time !rep@(Report m) =
case RB.uncons rb of
Nothing -> History $ RB.cons (time, rep) rb
Just ((oldTime, Report h), hRest) ->
case (reverse m, h) of
((s1, n1) : rs, (s2, n2) : hhs) | s1 == s2 ->
let hist = RB.cons (oldTime, Report ((s2, n1 + n2) : hhs)) hRest
in History $ if null rs
then hist
else RB.cons (time, Report (reverse rs)) hist
_ -> History $ RB.cons (time, rep) rb
lengthHistory :: History -> Int
lengthHistory (History rs) = RB.rbLength rs
renderHistory :: History -> Overlay
renderHistory (History rb) =
let l = RB.toList rb
(x, y) = normalLevelBound
screenLength = y + 2
reportLines = concatMap (splitReportForHistory (x + 1)) l
padding = screenLength length reportLines `mod` screenLength
in toOverlay $ replicate padding "" ++ reportLines
splitReportForHistory :: X -> (Time, Report) -> [Text]
splitReportForHistory w (time, r) =
let turns = time `timeFitUp` timeTurn
ts = splitText (w 1) $ tshow turns <> ":" <+> renderReport r
in case ts of
[] -> []
hd : tl -> hd : map (T.cons ' ') tl
lastReportOfHistory :: History -> Maybe Report
lastReportOfHistory (History rb) = snd . fst <$> RB.uncons rb
type ScreenLine = U.Vector Int32
toScreenLine :: Text -> ScreenLine
toScreenLine t = let f = AttrChar defAttr
in encodeLine $ map f $ T.unpack t
encodeLine :: [AttrChar] -> ScreenLine
encodeLine l = G.fromList $ map (fromIntegral . fromEnum) l
encodeOverlay :: [[AttrChar]] -> Overlay
encodeOverlay = Overlay . map encodeLine
newtype Overlay = Overlay {overlay :: [ScreenLine]}
deriving (Show, Eq, Binary)
emptyOverlay :: Overlay
emptyOverlay = Overlay []
truncateToOverlay :: Text -> Overlay
truncateToOverlay msg = toOverlay [msg]
toOverlay :: [Text] -> Overlay
toOverlay = let lxsize = fst normalLevelBound + 1
in Overlay . map (toScreenLine . truncateMsg lxsize)
splitOverlay :: Maybe Bool -> Y -> Overlay -> Overlay -> Slideshow
splitOverlay onBlank yspace (Overlay msg) (Overlay ls) =
let len = length msg
endB = [ toScreenLine
$ endMsg <> "[press PGUP to see previous, ESC to cancel]"
| onBlank == Just False ]
in if len >= yspace
then
Slideshow (onBlank, [Overlay $ take (yspace 1) msg
++ [toScreenLine moreMsg]])
else let splitO over =
let (pre, post) = splitAt (yspace 1) $ msg ++ over
in if null (drop 1 post)
then [Overlay $ msg ++ over ++ endB]
else let rest = splitO post
in Overlay (pre ++ [toScreenLine moreMsg]) : rest
in Slideshow (onBlank, splitO ls)
newtype Slideshow = Slideshow {slideshow :: (Maybe Bool, [Overlay])}
deriving (Show, Eq)
instance Monoid Slideshow where
mempty = Slideshow (Nothing, [])
mappend (Slideshow (b1, l1)) (Slideshow (_, l2)) = Slideshow (b1, l1 ++ l2)
toSlideshow :: Maybe Bool -> [[Text]] -> Slideshow
toSlideshow onBlank l = Slideshow (onBlank, map toOverlay l)