-- Haskell Game Clock --
--
-- Features:
-- Two analogue clock styles
-- Per move time, and option to acumulate leftover move time
-- Gui for entering times and options
-- Command line arguments for times and config to bypass gui
import Graphics.UI.Gtk hiding (fill, background)
import Graphics.Rendering.Cairo
import Data.Time.Clock
import Data.Time (fromGregorian)
import Data.IORef
import System.Environment
import System.Exit
import Numeric
import Data.Maybe
import qualified Data.Map as M
import Control.Monad
import System.Console.GetOpt
data ClockStyle = StyleAbsolute | StyleRelative deriving (Eq, Show)
data Clock = Clock {
clockGameTime :: NominalDiffTime
,clockGameTimeLeft :: NominalDiffTime
,clockMoveTime :: NominalDiffTime
,clockMoveTimeLeft :: NominalDiffTime
,clockRefTime :: UTCTime
,clockCumulativeMoveTime :: Bool
,clockTicking :: Bool
,clockSelected :: Bool
,clockStyle :: ClockStyle
}
data DisplayMode = DisplayClocks | DisplaySet | DisplayHelp
data State = State {
clock1 :: Clock
,clock2 :: Clock
,displayMode :: DisplayMode
,canvasDims :: (Int, Int)
,backgrounds :: M.Map (Bool, Bool) Surface
}
newClock (gameTime, moveTime) cumulative style = Clock
(fromRational $ toRational gameTime)
(fromRational $ toRational gameTime)
(fromRational $ toRational moveTime)
0
(UTCTime (fromGregorian 2000 01 01) (fromIntegral 0)) -- bogus reference time
cumulative
False
False
style
-- Update Clock's game time, move time, and reference time given now
tick :: Clock -> UTCTime -> Clock
tick c now =
if clockTicking c then
let timePassed = diffUTCTime now (clockRefTime c) in (if timePassed > clockMoveTimeLeft c
then c { clockGameTimeLeft = clockGameTimeLeft c - timePassed + clockMoveTimeLeft c,
clockMoveTimeLeft = 0 }
else c { clockMoveTimeLeft = clockMoveTimeLeft c - timePassed })
{ clockRefTime = now }
else c
reset c = c {
clockGameTimeLeft = clockGameTime c
,clockMoveTimeLeft = 0
,clockTicking = False
,clockSelected = False
}
pause c now = (tick c now) { clockTicking = False }
unpause c now = if clockSelected c && not (clockTicking c)
then c { clockRefTime = now, clockTicking = True } else c
stop c now = if clockSelected c then (pause c now) { clockSelected = False } else c
start c now = if not $ clockSelected c
then let c' = c { clockRefTime = now, clockTicking = True, clockSelected = True } in
if clockCumulativeMoveTime c
then c' { clockGameTimeLeft = clockGameTimeLeft c + clockMoveTime c }
else c' { clockMoveTimeLeft = clockMoveTime c }
else c
-- OpitonPair behavior described in helpText
type OptionPair o = (o, Maybe o)
optionNew o = (o, Nothing)
optionSet o (_, Nothing) = (o, Just o)
optionSet o' (o, Just _) = (o, Just o')
optionLeft = fst
optionRight (l, r) = case r of { Just o -> o; Nothing -> l }
data Options = Options {
optionsStyle :: OptionPair ClockStyle
,optionsShowHelp :: Bool
,optionsCumulative :: OptionPair Bool
,optionsFrameRate :: Double
,optionsTime :: OptionPair (Double, Double)
}
optionsStyleU f = \os -> os { optionsStyle = f (optionsStyle os) }
optionsCumulativeU f = \os -> os { optionsCumulative = f (optionsCumulative os) }
optionsTimeU f = \os -> os { optionsTime = f (optionsTime os) }
defaultOptions = Options (optionNew StyleAbsolute) False (optionNew False) 30 (optionNew (5, 0))
optionsSpec = [
Option ['a'] ["absolute"] (NoArg (optionsStyleU $ optionSet StyleAbsolute)) "Absolute (default) clock style"
,Option ['r'] ["relative"] (NoArg (optionsStyleU $ optionSet StyleRelative)) "Relative clock style"
,Option ['h','?'] ["help"] (NoArg (\os -> os { optionsShowHelp = True })) "Help"
,Option ['d'] ["distinct"] (NoArg (optionsCumulativeU $ optionSet False)) "Move time is separate, and resets every move (default)"
,Option ['c'] ["cumulative"] (NoArg (optionsCumulativeU $ optionSet True)) "Move time acumulates on to game time (default off)"
,Option ['f'] ["frame-rate"] (ReqArg setFrameRate "30") "Clock refresh rate (default 30)"
]
where setFrameRate str opts = opts { optionsFrameRate =
(fst . (fromMaybe (30,"")) . listToMaybe . readFloat) str }
helpText self optionsHelp = "Usage: " ++ self ++ " [OPTIONS] [TIME1] [OPTIONS] [TIME2] [OPTIONS]\n"
++ "TIME arguments are in the form of GAMETIME[+MOVETIME], where\n"
++ "GAMETIME and MOVETIME are decimal numbers followed by\n"
++ "'h', 'm', or 's'. Example: " ++ self ++ " -r -a -f 10 20+3s 1h\n"
++ "\n"
++ "Options:"
++ optionsHelp
++ "\n"
++ "Keys:\n"
++ " <space> Begin right player's move\n"
++ " <enter> Begin left player's move\n"
++ " p Pause/unpause (<space> and <enter> also unpause)\n"
++ " <shift+r> Reset both clocks to original times\n"
++ " <shift+q> Exit\n"
++ "\n"
++ "Clock options (such as -a and -r, -d and -c, and times) can be\n"
++ "given once or twice. If given once, the same setting applies to\n"
++ "both clocks. If given twice, the first setting applies to the\n"
++ "left clock, and the second to the right clock.\n"
main :: IO ()
main = do
args <- getArgs
let (optFuncs, _, errors) = getOpt (ReturnInOrder getTime) optionsSpec args
opts = foldl (flip id) defaultOptions optFuncs
getTime s = case parseTimes s of { Nothing -> id; Just t -> optionsTimeU $ optionSet t }
when (optionsShowHelp opts) $ do
self <- getProgName
putStr $ helpText self $ usageInfo "" optionsSpec
exitFailure
let c1 = newClock (optionLeft $ optionsTime opts)
(optionLeft $ optionsCumulative opts)
(optionLeft $ optionsStyle opts)
let c2 = newClock (optionRight $ optionsTime opts)
(optionRight $ optionsCumulative opts)
(optionRight $ optionsStyle opts)
-- GTK initialization
initGUI
window <- windowNew
set window [windowTitle := "Game Clock" ]
--frame <- frameNew
--containerAdd window frame
canvas <- drawingAreaNew
containerAdd window canvas
widgetShowAll window
dims <- widgetGetSize canvas
let state = State c1 c2 DisplayClocks dims M.empty
stateRef <- newIORef state
drawin <- widgetGetDrawWindow canvas
onKeyPress window $ \e -> do keyDown stateRef e
timeoutAdd (draw stateRef drawin)
(ceiling $ 1000.0 / optionsFrameRate opts)
onExpose canvas (\x -> do dims <- widgetGetSize canvas
modifyIORef stateRef (\x -> x { canvasDims = dims, backgrounds = M.empty })
return True)
onDestroy window mainQuit
mainGUI
drawClocks :: State -> Bool -> Render ()
drawClocks state foreground = do
save
setAntialias AntialiasGray
when (not foreground) $ do setSourceRGB 0 0 0
paint
let s = (fromIntegral $ fst $ canvasDims state) / 4 :: Double
scale s s
translate 1 (2 * (fromIntegral $ snd $ canvasDims state) / (fromIntegral $ fst $ canvasDims state))
drawClock (clock1 state) foreground
translate 2 0
drawClock (clock2 state) foreground
restore
-- Failed optimization attempt, may be useful with fancy clock faces
--getBackground :: IORef State -> IO Surface
--getBackground sRef = do
-- s <- readIORef sRef
-- let bgKey = (clockSelected $ clock1 s, clockSelected $ clock2 s)
-- bg <- case M.lookup bgKey $ backgrounds s of
-- Nothing -> do
-- bg <- createImageSurface FormatARGB32 (fst $ canvasDims s) (snd $ canvasDims s)
-- renderWith bg $ drawClocks s False
-- writeIORef sRef $ s { backgrounds = M.insert bgKey bg $ backgrounds s }
-- return bg
-- Just bg -> return bg
-- return bg
draw :: IORef State -> DrawWindow -> IO Bool
draw sRef dw = do
s <- readIORef sRef
--background <- getBackground sRef
now <- getCurrentTime
let s' = s { clock1 = tick (clock1 s) now, clock2 = tick (clock2 s) now }
dims = canvasDims s'
regio <- regionRectangle $ Rectangle 0 0 (fst dims) (snd dims)
drawWindowBeginPaintRegion dw regio -- double buffering start
renderWithDrawable dw $ do
--setSourceSurface background 0 0
--paint
drawClocks s' False
drawClocks s' True
drawWindowEndPaint dw -- double buffering end
return True
keyDown stateRef Key { eventKeyVal = k } = do
kn <- keyvalName k
state <- readIORef stateRef
let c1 = clock1 state
c2 = clock2 state
now <- getCurrentTime
writeIORef stateRef $ (case kn of
"Return" -> if clockSelected c1
then state { clock1 = unpause c1 now }
else state { clock1 = start c1 now, clock2 = stop c2 now }
"space" -> if clockSelected c2
then state { clock2 = unpause c2 now }
else state { clock1 = stop c1 now, clock2 = start c2 now }
"p" -> if clockTicking c1 || clockTicking c2
then state { clock1 = pause c1 now, clock2 = pause c2 now }
else state { clock1 = unpause c1 now, clock2 = unpause c2 now }
"R" -> state { clock1 = reset c1, clock2 = reset c2 }
_ -> state
)
when (kn == "Q") $ exitWith ExitSuccess
return True
drawClock :: Clock -> Bool -> Render ()
drawClock c foreground = do
let drawMarks n l = do
save
let (c, e) = properFraction n
replicateM_ (floor n) (do
rotate $ 2 * (-pi) / n
moveTo 0 (-1)
lineTo 0 (l - 1)
)
restore
let totalTime = fromRational $ toRational $ clockGameTime c + clockMoveTime c
let drawFace = do
moveTo 1 0
arc 0 0 1 0 (2 * pi)
case clockStyle c of
StyleRelative -> do
drawMarks (totalTime / 60) 0.05
drawMarks 1 0.1
stroke
save
scale 0.33 0.33
setLineWidth 0.02
drawMarks 1 0.1
moveTo 1 0
arc 0 0 1 0 (2 * pi)
stroke
restore
_ -> do
drawMarks 4 0.1
drawMarks 12 0.05
drawMarks 60 0.025
stroke
let drawThinHand p = do
save
rotate $ p * (-pi) * 2
moveTo 0 (-0.025)
lineTo 0 (-0.88)
stroke
restore
let drawBigHand p f = do
save
rotate $ p * (-pi) * 2
moveTo 0 (negate f)
lineTo 0 (-0.5)
lineTo (-0.025) (-0.55)
lineTo 0 (-0.88)
lineTo (0.025) (-0.55)
lineTo 0 (-0.5)
stroke
restore
let drawHands t =
case clockStyle c of
StyleRelative -> do
save
drawBigHand (t / totalTime) 0.33
scale 0.33 0.33
setLineWidth 0.02
drawBigHand (t / 60) 0.025
moveTo 0.025 0
arc 0 0 0.025 0 (2 * pi)
restore
_ -> do
drawBigHand (t / 3600) 0.025
drawThinHand $ t / 60
moveTo 0.025 0
arc 0 0 0.025 0 (2 * pi)
let drawTwoTimes = do
let gameTime = fromRational $ toRational $ clockGameTimeLeft c
moveTime = fromRational $ toRational $ clockMoveTimeLeft c
when (gameTime < 0) $ setSourceRGB 1 0.3 0.3
when (moveTime > 0) $ do
save
setDash [0.008, 0.008] 0
setLineWidth 0.003
drawHands $ moveTime + gameTime
stroke
restore
drawHands gameTime
stroke
save
scale 0.9 0.9
setLineWidth 0.0075
if clockSelected c then setSourceRGB 1 1 1 else setSourceRGB 0.3 0.3 0.3
when (not foreground) drawFace
when ((foreground && clockTicking c) || ((not $ clockTicking c) && not foreground)) drawTwoTimes
--selectFontFace "Mono" FontSlantNormal FontWeightNormal
--setFontSize 0.1
--setSourceRGB 1 1 1
--moveTo (-0.5) 0.5
--textPath $ show moveTime
--fill
restore
parseTime :: String -> Maybe Double
parseTime str = case readFloat str of
[] -> Nothing
[(n, rest)] -> Just $ (fromMaybe 0 $ parseTime $ drop 1 rest) + (n *
case rest of
'h':_ -> 3600
's':_ -> 1
_ -> 60)
parseTimes :: String -> Maybe (Double, Double)
parseTimes str = let strs = break (=='+') str in
case (parseTime $ fst strs, parseTime $ drop 1 $ snd strs) of
(Nothing, _) -> Nothing
(Just t, Nothing) -> return (t, 0)
(Just t, Just t2) -> return (t, t2)