module GTK.Score
( newScore_
) where
import Preferences
import Table (luckFunction)
import Configuration (showConfiguration)
import State
import State.Functions
import Graphics.UI.Gtk hiding (Size, on)
import Graphics.UI.Gtk.Glade
import Control.Concurrent.MVar
import Control.Monad
import Data.List
--import Data.Maybe
--import Data.Function
import Numeric
-------------------------------------------
attrs_ = [SA_Alive, SA_Time, SA_Success]
setIndex i s = show i ++ ". " ++ f s where
f (_:'.':' ':s) = s
f s = s
newScore_ :: GladeXML -> IO (Preferences -> Maybe Int -> [ScoreEntry] -> [ScoreAttr] -> IO (Maybe String, [ScoreAttr]))
newScore_ xml = do
dialog <- xmlGetWidget xml castToDialog "scoredialog"
table <- xmlGetWidget xml castToTable "scoretable"
configLabel <- xmlGetWidget xml castToLabel "configurationlabel"
buttons <- mapM (xmlGetWidget xml castToButton) ["sortbyluckiness", "sortbytime", "sortbysuccess"]
scoreState <- newEmptyMVar :: IO (MVar ([ScoreAttr], Maybe Int, [ScoreEntry]))
entry <- entryNew
set entry [ entryHasFrame := False, entryMaxLength := 15, entryWidthChars := 10 ]
widgetShow entry
-- create entry labels
lss <- replicateM maxEntries $ do
labs@(l:ls) <- replicateM 4 (labelNew Nothing)
set l [miscXalign := 0]
sequence_ [set x [miscXalign := 1] | x<- ls]
mapM_ widgetShow labs
return labs
let
attachLabels n = do
tableResize table (1 + n) 4
sequence_ [tableAttachDefaults table x j (j+1) i (i+1) | (i,labs) <- zip [1..n] lss, (j,x) <- zip [0..] labs]
removeLabels n =
mapM_ (containerRemove table) $ concat $ take n lss
showEntry ls e
= zipWithM_ labelSetText ls
[ se_name e
, show_ 2 $ luckFunction $ se_alive e
, showTime $ se_time e
, show_ 2 $ realToFrac $ successFunction (se_time e) (se_alive e)
]
addEntry i = do
containerRemove table (head $ lss !! i)
tableAttachDefaults table entry 0 1 (i+1) (i+2)
removeEntry i = do
containerRemove table entry
tableAttachDefaults table (head $ lss !! i) 0 1 (i+1) (i+2)
showEntries = do
(sl, e, es) <- takeMVar scoreState
let es' = sortByAttr sl es
e' = join $ fmap (\i -> elemIndex (es !! i) es') e
putMVar scoreState (sl, e', es')
sequence_ [set b [buttonLabel :~ setIndex i] | (a, b) <- zip attrs_ buttons, (i, a') <- zip [1::Int ..] sl, a == a']
ff removeEntry e
ff addEntry e'
zipWithM_ showEntry lss es'
sortScoresBy sa = do
(sl_old, e, es) <- takeMVar scoreState
let sl = sa: filter (/=sa) sl_old
putMVar scoreState (sl, e, es)
when (sl /= sl_old) showEntries
initSort b sa = do
_ <- onButtonActivate b $ sortScoresBy sa
onPressed b $ sortScoresBy sa
zipWithM_ initSort buttons attrs_
return $ \c i es attrs -> do
labelSetText configLabel $ showConfiguration $ configuration c
maybe (return ()) (entrySetText entry . se_name . (es!!)) i
putMVar scoreState (attrs, i, es)
attachLabels $ length es
ff addEntry i
showEntries
r <- dialogRun dialog
(attrs', i', _) <- takeMVar scoreState
widgetHide dialog
ff removeEntry i'
removeLabels $ length es
case r of
ResponseOk -> do
n <- entryGetText entry
return (fmap (const n) i', attrs')
_ -> return (Nothing, attrs)
ff f (Just i) = f i
ff _ Nothing = return ()
showTime :: Int -> String
showTime x = "" .++ day .+ 'd' .++ h .+ 'h' .++ dm .++ m .+ 'm' .++ ds ++ s ++ "s" where
(day: h: dm: m: ds: s: _) = map show (d:l)
(d, l) = mapAccumR divMod x [24,6,10,6,10]
infixl 6 .++, .+
"" .+ _ = ""
s .+ c = s ++ [c]
"" .++ "0" = ""
a .++ b = a ++ b
--show_ :: RealFloat a => Int -> a -> String
show_ :: Int -> Double -> String
show_ i x = showFFloat (Just i) x ""