module Game.LambdaHack.Msg
( Msg, moreMsg, yesnoMsg, padMsg
, Report, emptyReport, nullReport, singletonReport, addMsg
, splitReport, renderReport
, History, emptyHistory, singletonHistory, addReport, renderHistory
, takeHistory
, Overlay, splitOverlay, stringByLocation
) where
import qualified Data.List as L
import Data.Char
import Data.Binary
import qualified Data.ByteString.Char8 as BS
import qualified Data.IntMap as IM
import Game.LambdaHack.Misc
import Game.LambdaHack.PointXY
type Msg = String
moreMsg :: Msg
moreMsg = "--more-- "
yesnoMsg :: Msg
yesnoMsg = "[yn]"
padMsg :: X -> String -> String
padMsg w xs =
let len = length xs
rev = reverse xs
in case compare w len of
LT -> reverse $ '$' : drop (len w + 1) rev
EQ -> xs
GT -> case rev of
[] -> xs
' ' : _ -> xs
_ -> reverse $ ' ' : rev
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 m = addMsg emptyReport m
addMsg :: Report -> Msg -> Report
addMsg r "" = r
addMsg (Report ((x, n) : xns)) y' | x == y =
Report $ (y, n + 1) : xns
where y = BS.pack y'
addMsg (Report xns) y = Report $ (BS.pack y, 1) : xns
splitReport :: Report -> [String]
splitReport r =
let w = fst normalLevelBound + 1
in splitString w $ renderReport r
renderReport ::Report -> String
renderReport (Report []) = ""
renderReport (Report [xn]) = renderRepetition xn
renderReport (Report (xn : xs)) =
renderReport (Report xs) ++ " " ++ renderRepetition xn
renderRepetition :: (BS.ByteString, Int) -> String
renderRepetition (s, 1) = BS.unpack s
renderRepetition (s, n) = BS.unpack s ++ "<x" ++ show n ++ ">"
splitString :: X -> String -> [String]
splitString w xs = splitString' w $ dropWhile isSpace xs
splitString' :: X -> String -> [String]
splitString' w xs
| w <= 0 = [xs]
| w >= length xs = [xs]
| otherwise =
let (pre, post) = splitAt w xs
(ppre, ppost) = break (`elem` " .,:;!?") $ reverse pre
testPost = dropWhile isSpace ppost
in if L.null testPost
then pre : splitString w post
else reverse ppost : splitString w (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
renderHistory :: History -> Overlay
renderHistory (History h) = L.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 = [String]
splitOverlay :: Y -> Overlay -> [Overlay]
splitOverlay _ [] = []
splitOverlay lysize ls | length ls <= lysize = [ls]
splitOverlay lysize ls = let (pre, post) = splitAt (lysize 1) ls
in pre : splitOverlay lysize post
stringByLocation :: X -> Y -> Overlay
-> (String, PointXY -> Maybe Char, Maybe String)
stringByLocation _ _ [] = ("", const Nothing, Nothing)
stringByLocation lxsize lysize (msgTop : ls) =
let over = map (padMsg lxsize) $ take lysize ls
m = IM.fromDistinctAscList $
zip [0..] (L.map (IM.fromList . zip [0..]) over)
msgBottom = case drop lysize ls of
[] -> Nothing
s : _ -> Just s
in (msgTop,
\ (PointXY (x, y)) -> IM.lookup y m >>= \ n -> IM.lookup x n,
msgBottom)