module Game.LambdaHack.Common.Msg
( makePhrase, makeSentence
, Msg, (<>), (<+>), showT, moreMsg, yesnoMsg, truncateMsg
, Report, emptyReport, nullReport, singletonReport, addMsg
, splitReport, renderReport, findInReport
, History, emptyHistory, singletonHistory, mergeHistory
, addReport, renderHistory, takeHistory
, Overlay, stringByLocation
, Slideshow(runSlideshow), splitOverlay, toSlideshow)
where
import Data.Binary
import qualified Data.ByteString.Char8 as BS
import Data.Char
import qualified Data.EnumMap.Strict as EM
import Data.List
import Data.Monoid hiding ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import NLP.Miniutter.English ((<+>), (<>))
import qualified NLP.Miniutter.English as MU
import qualified Text.Show.Pretty as Show.Pretty
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.PointXY
showT :: Show a => a -> Text
showT x = T.pack $ Show.Pretty.ppShow x
makePhrase, makeSentence :: [MU.Part] -> Text
makePhrase = MU.makePhrase MU.defIrregular
makeSentence = MU.makeSentence MU.defIrregular
type Msg = Text
moreMsg :: Msg
moreMsg = "--more-- "
yesnoMsg :: Msg
yesnoMsg = "[yn]"
truncateMsg :: X -> Text -> Text
truncateMsg w xsRaw =
let xs = case T.lines xsRaw of
[] -> xsRaw
[line] -> line
line : _ -> line <> T.replicate (w + 1) " "
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)
instance Binary Report where
put (Report x) = put x
get = fmap Report get
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
splitReport :: Report -> [Text]
splitReport r =
let w = fst normalLevelBound + 1
in 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" <> showT n <> ">"
findInReport :: (BS.ByteString -> Bool) -> Report -> Maybe BS.ByteString
findInReport f (Report xns) = find f $ map fst xns
splitText :: X -> Text -> [Text]
splitText w xs = concatMap (splitText' w . T.dropWhile isSpace) $ T.lines xs
splitText' :: X -> Text -> [Text]
splitText' w xs
| w <= 0 = [xs]
| w >= T.length xs = [xs]
| otherwise =
let (pre, post) = T.splitAt w xs
(ppre, ppost) = T.break (== ' ') $ T.reverse pre
testPost = T.dropWhile isSpace ppost
in if T.null testPost
then pre : splitText w post
else T.reverse ppost : splitText w (T.reverse ppre <> post)
newtype History = History [Report]
deriving Show
instance Binary History where
put (History x) = put x
get = fmap History get
emptyHistory :: History
emptyHistory = History []
singletonHistory :: Report -> History
singletonHistory r = addReport r emptyHistory
mergeHistory :: [(Msg, History)] -> History
mergeHistory l =
let unhist (History x) = x
f (msg, h) = singletonReport msg : unhist h
in History $ concatMap f l
renderHistory :: History -> Overlay
renderHistory (History h) = concatMap splitReport h
addReport :: Report -> History -> History
addReport (Report []) h = h
addReport m (History []) = History [m]
addReport (Report m) (History (Report h : hs)) =
case (reverse m, h) of
((s1, n1) : rs, (s2, n2) : hhs) | s1 == s2 ->
let hist = Report ((s2, n1 + n2) : hhs) : hs
in History $ if null rs then hist else Report (reverse rs) : hist
_ -> History $ Report m : Report h : hs
takeHistory :: Int -> History -> History
takeHistory k (History h) = History $ take k h
type Overlay = [Text]
stringByLocation :: X -> Y -> Overlay
-> (Text, PointXY -> Maybe Char, Maybe Text)
stringByLocation _ _ [] = (T.empty, const Nothing, Nothing)
stringByLocation lxsize lysize (msgTop : ls) =
let (over, bottom) = splitAt lysize $ map (truncateMsg lxsize) ls
m = EM.fromDistinctAscList
$ zip [0..]
(map (EM.fromDistinctAscList . zip [0..] . T.unpack) over)
msgBottom = case bottom of
[] -> Nothing
[s] -> Just s
_ -> Just "--a portion of the text trimmed--"
in (truncateMsg lxsize msgTop,
\ (PointXY (x, y)) -> EM.lookup y m >>= \ n -> EM.lookup x n,
msgBottom)
splitOverlay :: Y -> Overlay -> Overlay -> Slideshow
splitOverlay lysize msg ls =
let over = msg ++ ls
in if length over <= lysize + 2
then Slideshow [over]
else let (pre, post) = splitAt (lysize + 1) over
Slideshow slides = splitOverlay lysize msg post
in Slideshow $ (pre ++ [moreMsg]) : slides
newtype Slideshow = Slideshow {runSlideshow :: [Overlay]}
deriving (Monoid, Show)
toSlideshow :: [Overlay] -> Slideshow
toSlideshow = Slideshow