module Game.LambdaHack.HighScore
( Status(..), ScoreRecord(..), ScoreTable, restore, register, slideshow
) where
import System.Directory
import Control.Monad
import Text.Printf
import System.Time
import Data.Binary
import qualified Data.List as L
import Game.LambdaHack.Utils.File
import qualified Game.LambdaHack.Config as Config
import Game.LambdaHack.Dungeon
import Game.LambdaHack.Misc
data ScoreRecord = ScoreRecord
{ points :: !Int
, negTurn :: !Int
, date :: !ClockTime
, status :: !Status
}
deriving (Eq, Ord)
data Status =
Killed !LevelId
| Camping
| Victor
deriving (Eq, Ord)
instance Binary Status where
put (Killed ln) = putWord8 0 >> put ln
put Camping = putWord8 1
put Victor = putWord8 2
get = do
tag <- getWord8
case tag of
0 -> liftM Killed get
1 -> return Camping
2 -> return Victor
_ -> fail "no parse (Status)"
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)
showScore :: (Int, ScoreRecord) -> String
showScore (pos, score) =
let died = case status score of
Killed lvl -> "perished on level " ++ show (levelNumber lvl) ++ ","
Camping -> "is camping somewhere,"
Victor -> "emerged victorious"
time = calendarTimeToString . toUTCTime . date $ score
big = " "
lil = " "
steps = negTurn score `div` (10)
in printf
"%s\n%4d. %6d This adventuring party %s after %d steps \n%son %s. \n"
big pos (points score) died steps lil time
type ScoreTable = [ScoreRecord]
empty :: ScoreTable
empty = []
scoresFile :: Config.CP -> IO String
scoresFile config = Config.getFile config "files" "scoresFile"
save :: Config.CP -> ScoreTable -> IO ()
save config scores = do
f <- scoresFile config
encodeEOF f scores
restore :: Config.CP -> IO ScoreTable
restore config = do
f <- scoresFile config
b <- doesFileExist f
if not b
then return empty
else strictDecodeEOF f
insertPos :: ScoreRecord -> ScoreTable -> (ScoreTable, Int)
insertPos s h =
let (prefix, suffix) = L.span (> s) h
in (prefix ++ [s] ++ suffix, L.length prefix + 1)
showTable :: ScoreTable -> Int -> Int -> String
showTable h start height =
let zipped = zip [1..] h
screenful = take height . drop (start 1) $ zipped
in L.concatMap showScore screenful
slideshow :: Int -> ScoreTable -> Int -> [String]
slideshow 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]
register :: Config.CP -> Bool -> ScoreRecord -> IO (String, [String])
register config write s = do
h <- restore config
let (h', pos) = insertPos s h
(_, nlines) = normalLevelBound
height = nlines `div` 3
(msgCurrent, msgUnless) =
case status s of
Killed _ -> (" short-lived", " (score halved)")
Camping -> (" current", " (unless you are slain)")
Victor -> (" glorious",
if pos <= height
then " among the greatest heroes"
else "")
msg = printf "Your%s exploits award you place >> %d <<%s."
msgCurrent pos msgUnless
when write $ save config h'
return (msg, slideshow pos h' height)