module Game.LambdaHack.Common.HighScore
( ScoreTable, empty, register, slideshow
) where
import Data.Binary
import qualified Data.List as L
import Data.Text (Text)
import qualified Data.Text as T
import qualified NLP.Miniutter.English as MU
import System.Time
import Text.Printf
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Msg
import Game.LambdaHack.Common.Time
data ScoreRecord = ScoreRecord
{ points :: !Int
, negTime :: !Time
, date :: !ClockTime
, status :: !Status
}
deriving (Eq, Ord)
showScore :: (Int, ScoreRecord) -> [Text]
showScore (pos, score) =
let Status{stOutcome, stDepth} = status score
died = case stOutcome of
Killed -> "perished on level " ++ show (abs stDepth) ++ ","
Defeated -> "was defeated"
Camping -> "is camping somewhere,"
Conquer -> "eliminated all opposition"
Escape -> "emerged victorious"
Restart -> "resigned prematurely"
curDate = calendarTimeToString . toUTCTime . date $ score
big, lil :: String
big = " "
lil = " "
turns = (negTime score `timeFit` timeTurn)
in map T.pack
[ big
, printf "%4d. %6d This adventuring party %s after %d turns "
pos (points score) died turns
, lil ++ printf "on %s. " curDate
]
newtype ScoreTable = ScoreTable [ScoreRecord]
deriving (Eq, Binary)
instance Show ScoreTable where
show _ = "a score table"
empty :: ScoreTable
empty = ScoreTable []
insertPos :: ScoreRecord -> ScoreTable -> (ScoreTable, Int)
insertPos s (ScoreTable table) =
let (prefix, suffix) = L.span (> s) table
pos = L.length prefix + 1
in (ScoreTable $ prefix ++ [s] ++ take (100 pos) suffix, pos)
register :: ScoreTable
-> Int
-> Time
-> Status
-> ClockTime
-> Maybe (ScoreTable, Int)
register table total time status@Status{stOutcome} date =
let points = if stOutcome `elem` [Killed, Defeated, Restart]
then (total + 1) `div` 2
else if stOutcome == Conquer
then let turnsSpent = timeFit time timeTurn
speedup = 10000 5 * turnsSpent
bonus = sqrt $ fromIntegral speedup :: Double
in 10 + floor bonus
else total
negTime = timeNegate time
score = ScoreRecord{..}
in if points > 0 then Just $ insertPos score table else Nothing
showTable :: ScoreTable -> Int -> Int -> Overlay
showTable (ScoreTable table) start height =
let zipped = zip [1..] table
screenful = take height . drop (start 1) $ zipped
in concatMap showScore screenful ++ [moreMsg]
showCloseScores :: Int -> ScoreTable -> Int -> [Overlay]
showCloseScores pos h height =
if pos <= height
then [showTable h 1 height]
else [showTable h 1 height,
showTable h (max (height + 1) (pos height `div` 2)) height]
slideshow :: ScoreTable
-> Int
-> Status
-> Slideshow
slideshow table pos status =
let (_, nlines) = normalLevelBound
height = nlines `div` 3
(subject, person, msgUnless) =
case stOutcome status of
Killed | stDepth status <= 1 ->
("your short-lived struggle", MU.Sg3rd, "(score halved)")
Killed ->
("your heroic deeds", MU.PlEtc, "(score halved)")
Defeated ->
("your futile efforts", MU.PlEtc, "(score halved)")
Camping ->
("your valiant exploits", MU.PlEtc, "(unless you are slain)")
Conquer ->
("your ruthless victory", MU.Sg3rd,
if pos <= height
then "among the greatest heroes"
else "(score based on time)")
Escape ->
("your dashing coup", MU.Sg3rd,
if pos <= height
then "among the greatest heroes"
else "")
Restart ->
("your abortive attempt", MU.Sg3rd, "(score halved)")
msg = makeSentence
[ MU.SubjectVerb person MU.Yes subject "award you"
, MU.Ordinal pos, "place"
, msgUnless ]
in toSlideshow $ map ([msg] ++) $ showCloseScores pos table height
instance Binary ScoreRecord where
put (ScoreRecord p n (TOD cs cp) s) = do
put p
put n
put cs
put cp
put s
get = do
p <- get
n <- get
cs <- get
cp <- get
s <- get
return (ScoreRecord p n (TOD cs cp) s)