1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
|
{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}
-- | High score table operations.
module Game.LambdaHack.Common.HighScore
( ScoreTable, ScoreDict
, empty, register, showScore, showAward
, getTable, unTable, getRecord, getStatus, getDate
#ifdef EXPOSE_INTERNAL
-- * Internal operations
, ScoreRecord, insertPos
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import Data.Binary
import qualified Data.EnumMap.Strict as EM
import qualified Data.Text as T
import Data.Time.Clock.POSIX
import Data.Time.LocalTime
import GHC.Generics (Generic)
import qualified NLP.Miniutter.English as MU
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Content.FactionKind
import Game.LambdaHack.Content.ItemKind (ItemKind)
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Definition.Defs
-- | A single score record. Records are ordered in the highscore table,
-- from the best to the worst, in lexicographic ordering wrt the fields below.
data ScoreRecord = ScoreRecord
{ points :: Int -- ^ the score
, negTime :: Time -- ^ game time spent (negated, so less better)
, date :: POSIXTime -- ^ date of the last game interruption
, status :: Status -- ^ reason of the game interruption
, challenge :: Challenge -- ^ challenge setup of the game
, gkindName :: Text -- ^ name of the faction's gkind
, ourVictims :: EM.EnumMap (ContentId ItemKind) Int -- ^ allies lost
, theirVictims :: EM.EnumMap (ContentId ItemKind) Int -- ^ foes killed
}
deriving (Eq, Ord, Generic)
instance Binary ScoreRecord
-- | The list of scores, in decreasing order.
newtype ScoreTable = ScoreTable {unTable :: [ScoreRecord]}
deriving (Eq, Binary)
instance Show ScoreTable where
show _ = "a score table"
-- | A dictionary from game mode IDs to scores tables.
type ScoreDict = EM.EnumMap (ContentId ModeKind) ScoreTable
-- | Empty score table
empty :: ScoreDict
empty = EM.empty
-- | Insert a new score into the table, Return new table and the ranking.
-- Make sure the table doesn't grow too large.
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 a new score in a score table.
register :: ScoreTable -- ^ old table
-> Int -- ^ the total value of faction items
-> Int -- ^ the total value of dungeon items
-> Time -- ^ game time spent
-> Status -- ^ reason of the game interruption
-> POSIXTime -- ^ current date
-> Challenge -- ^ challenge setup
-> Text -- ^ name of the faction's gkind
-> EM.EnumMap (ContentId ItemKind) Int -- ^ allies lost
-> EM.EnumMap (ContentId ItemKind) Int -- ^ foes killed
-> HiCondPoly
-> (Bool, (ScoreTable, Int))
register table total dungeonTotal time status@Status{stOutcome}
date challenge gkindName ourVictims theirVictims hiCondPoly =
let turnsSpent = intToDouble $ timeFitUp time timeTurn
hiInValue (hi, c) = assert (total <= dungeonTotal) $ case hi of
HiConst -> c
HiLoot | dungeonTotal == 0 -> c -- a fluke; no gold generated
HiLoot -> c * intToDouble total / intToDouble dungeonTotal
HiSprint -> -- Up to -c turns matter.
let speedup = max 0 (-c - turnsSpent)
in if c >= -10000
then speedup -- every turn matters
else 10000 * speedup / (-c) -- prevent exploit speedruns
HiBlitz -> -- Up to 1000000/-c turns matter.
sqrt $ max 0 (1000000 + c * turnsSpent)
HiSurvival -> -- Up to 1000000/c turns matter.
sqrt $ max 0 (min 1000000 $ c * turnsSpent)
HiKill -> c * intToDouble (sum (EM.elems theirVictims))
HiLoss -> c * intToDouble (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
-- Other challenges than HP difficulty are not reflected in score.
points = ceiling
$ hiCondValue hiCondPoly
* 1.5 ^^ (- (difficultyCoeff (cdiff challenge)))
negTime = absoluteTimeNegate time
score = ScoreRecord{..}
in (points > 0 || turnsSpent > 100, insertPos score table)
-- even if stash looted and all gold lost, count highscore if long game
-- | Show a single high score, from the given ranking in the high score table.
showScore :: TimeZone -> Int -> ScoreRecord -> [Text]
showScore tz pos score =
let Status{stOutcome, stDepth} = status score
died = nameOutcomePast stOutcome <+> case stOutcome of
Killed -> "on level" <+> tshow (abs stDepth)
_ -> ""
curDate = T.take 19 . tshow . utcToLocalTime tz
. posixSecondsToUTCTime . 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
-- This may overfill the screen line, but with default fonts
-- it's very unlikely and not a big problem in any case.
chalText | challenge score == defaultChallenge = ""
| otherwise = tshowChallenge (challenge score)
tturns = makePhrase [MU.CarWs turns "turn"]
in [ tpos <> "." <+> tscore <+> gkindName score
<+> died <> "," <+> victims <> ","
, " "
<> "after" <+> tturns <+> chalText <+> "on" <+> curDate <> "."
]
getTable :: ContentId ModeKind -> ScoreDict -> ScoreTable
getTable = EM.findWithDefault (ScoreTable [])
getRecord :: Int -> ScoreTable -> ScoreRecord
getRecord pos (ScoreTable table) =
fromMaybe (error $ "" `showFailure` pos)
$ listToMaybe $ drop (pred pos) table
getStatus :: ScoreRecord -> Status
getStatus = status
getDate :: ScoreRecord -> POSIXTime
getDate = date
showAward :: Int -- ^ number of (3-line) scores to be shown
-> ScoreTable -- ^ current score table
-> Int -- ^ position of the current score in the table
-> Text -- ^ the name of the game mode
-> Text
showAward height table pos gameModeName =
let 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 ->
-- This is only according to the limited player knowledge;
-- the final score can be different, which is fine:
("your valiant exploits", MU.PlEtc, "")
Conquer ->
("your ruthless victory", MU.Sg3rd,
if pos <= height && length (unTable table) > 3
then "among the best" -- "greatest heroes" doesn't fit
else "(bonus included)")
Escape ->
("your dashing coup", MU.Sg3rd,
if pos <= height && length (unTable table) > 3
then "among the best"
else "(bonus included)")
Restart ->
("your abortive attempt", MU.Sg3rd, "(no bonus)")
subject = makePhrase [efforts, "in", MU.Text gameModeName]
in makeSentence
[ MU.SubjectVerb person MU.Yes (MU.Text subject) "award you"
, MU.Ordinal pos, "place", msgUnless ]
|
