module Game.LambdaHack.Common.HighScore
( ScoreDict, ScoreTable
, empty, register, showScore, getTable, getRecord, highSlideshow
#ifdef EXPOSE_INTERNAL
, ScoreRecord
#endif
) where
import Control.Exception.Assert.Sugar
import Data.Binary
import qualified Data.EnumMap.Strict as EM
import Data.List
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import qualified NLP.Miniutter.English as MU
import System.Time
import Game.LambdaHack.Common.Faction
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Msg
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Content.ItemKind (ItemKind)
import Game.LambdaHack.Content.ModeKind (HiCondPoly, HiIndeterminant (..),
ModeKind, Outcome (..))
data ScoreRecord = ScoreRecord
{ points :: !Int
, negTime :: !Time
, date :: !ClockTime
, status :: !Status
, difficulty :: !Int
, gplayerName :: !Text
, ourVictims :: !(EM.EnumMap (Kind.Id ItemKind) Int)
, theirVictims :: !(EM.EnumMap (Kind.Id ItemKind) Int)
}
deriving (Eq, Ord, Show, Generic)
instance Binary ClockTime where
put (TOD cs cp) = do
put cs
put cp
get = do
cs <- get
cp <- get
return $! TOD cs cp
instance Binary ScoreRecord
newtype ScoreTable = ScoreTable [ScoreRecord]
deriving (Eq, Binary)
instance Show ScoreTable where
show _ = "a score table"
type ScoreDict = EM.EnumMap (Kind.Id ModeKind) ScoreTable
showScore :: (Int, ScoreRecord) -> [Text]
showScore (pos, score) =
let Status{stOutcome, stDepth} = status score
died = case stOutcome of
Killed -> "perished on level" <+> tshow (abs stDepth)
Defeated -> "was defeated"
Camping -> "camps somewhere"
Conquer -> "slew all opposition"
Escape -> "emerged victorious"
Restart -> "resigned prematurely"
curDate = T.pack $ calendarTimeToString . toUTCTime . date $ score
turns = absoluteTimeNegate (negTime score) `timeFitUp` timeTurn
tpos = T.justifyRight 3 ' ' $ tshow pos
tscore = T.justifyRight 6 ' ' $ tshow $ points score
victims = let nkilled = sum $ EM.elems $ theirVictims score
nlost = sum $ EM.elems $ ourVictims score
in "killed" <+> tshow nkilled <> ", lost" <+> tshow nlost
diff = difficulty score
diffText | diff == difficultyDefault = ""
| otherwise = "difficulty" <+> tshow diff <> ", "
tturns = makePhrase [MU.CarWs turns "turn"]
in [ tpos <> "." <+> tscore <+> gplayerName score
<+> died <> "," <+> victims <> ","
, " "
<> diffText <> "after" <+> tturns <+> "on" <+> curDate <> "."
]
getTable :: Kind.Id ModeKind -> ScoreDict -> ScoreTable
getTable = EM.findWithDefault (ScoreTable [])
getRecord :: Int -> ScoreTable -> ScoreRecord
getRecord pos (ScoreTable table) =
fromMaybe (assert `failure` (pos, table))
$ listToMaybe $ drop (pred pos) table
empty :: ScoreDict
empty = EM.empty
insertPos :: ScoreRecord -> ScoreTable -> (ScoreTable, Int)
insertPos s (ScoreTable table) =
let (prefix, suffix) = span (> s) table
pos = length prefix + 1
in (ScoreTable $ prefix ++ [s] ++ take (100 pos) suffix, pos)
register :: ScoreTable
-> Int
-> Time
-> Status
-> ClockTime
-> Int
-> Text
-> EM.EnumMap (Kind.Id ItemKind) Int
-> EM.EnumMap (Kind.Id ItemKind) Int
-> HiCondPoly
-> (Bool, (ScoreTable, Int))
register table total time status@Status{stOutcome} date difficulty gplayerName
ourVictims theirVictims hiCondPoly =
let turnsSpent = fromIntegral $ timeFitUp time timeTurn
hiInValue (hi, c) = case hi of
HiConst -> c
HiLoot -> c * fromIntegral total
HiBlitz ->
sqrt $ max 0 (1000000 + c * turnsSpent)
HiSurvival ->
sqrt $ max 0 (min 1000000 $ c * turnsSpent)
HiKill -> c * fromIntegral (sum (EM.elems theirVictims))
HiLoss -> c * fromIntegral (sum (EM.elems ourVictims))
hiPolynomialValue = sum . map hiInValue
hiSummandValue (hiPoly, outcomes) =
if stOutcome `elem` outcomes
then max 0 (hiPolynomialValue hiPoly)
else 0
hiCondValue = sum . map hiSummandValue
points = (ceiling :: Double -> Int)
$ hiCondValue hiCondPoly
* 1.5 ^^ ( (difficultyCoeff difficulty))
negTime = absoluteTimeNegate time
score = ScoreRecord{..}
in (points > 0, insertPos score table)
tshowable :: ScoreTable -> Int -> Int -> [Text]
tshowable (ScoreTable table) start height =
let zipped = zip [1..] table
screenful = take height . drop (start 1) $ zipped
in intercalate ["\n"] (map showScore screenful) ++ [moreMsg]
showCloseScores :: Int -> ScoreTable -> Int -> [[Text]]
showCloseScores pos h height =
if pos <= height
then [tshowable h 1 height]
else [tshowable h 1 height,
tshowable h (max (height + 1) (pos height `div` 2)) height]
highSlideshow :: ScoreTable
-> Int
-> Text
-> Slideshow
highSlideshow table pos gameModeName =
let (_, nlines) = normalLevelBound
height = nlines `div` 3
posStatus = status $ getRecord pos table
(efforts, person, msgUnless) =
case stOutcome posStatus of
Killed | stDepth posStatus <= 1 ->
("your short-lived struggle", MU.Sg3rd, "(no bonus)")
Killed ->
("your heroic deeds", MU.PlEtc, "(no bonus)")
Defeated ->
("your futile efforts", MU.PlEtc, "(no bonus)")
Camping ->
("your valiant exploits", MU.PlEtc, "")
Conquer ->
("your ruthless victory", MU.Sg3rd,
if pos <= height
then "among the best"
else "(bonus included)")
Escape ->
("your dashing coup", MU.Sg3rd,
if pos <= height
then "among the best"
else "(bonus included)")
Restart ->
("your abortive attempt", MU.Sg3rd, "(no bonus)")
subject =
makePhrase [efforts, "in", MU.Capitalize $ MU.Text gameModeName]
msg = makeSentence
[ MU.SubjectVerb person MU.Yes (MU.Text subject) "award you"
, MU.Ordinal pos, "place", msgUnless ]
in toSlideshow Nothing $ map ([msg, "\n"] ++) $ showCloseScores pos table height