-- 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)