module GTK
    ( GUIState
    , guiState
    , startGUI
    , handleResponses
    ) where

import Configuration
import State
import Event
import Core.Square
import GTK.Square
import GTK.Preferences
import GTK.Score
import Paths_minesweeper

import Graphics.UI.Gtk hiding (event)
import Graphics.UI.Gtk.Glade 
import Graphics.UI.Gtk.Gdk.EventM 
import Graphics.Rendering.Cairo (liftIO)        -- ???

import Data.Char
import Data.Maybe
import Data.Time.Clock
import Control.Concurrent


------------------------------------------------------

data GUIState = GUIState
    { infoLabel :: Label         
    , timeLabel :: Label
    , frame     :: AspectFrame
    , table     :: DrawingArea 
    , window    :: Window
    , event     :: Event -> IO ()
    , tSize     :: MVar Board

    , setPref    :: Configuration -> IO (Maybe Configuration)
    , newScore   :: Configuration -> Maybe Int -> [ScoreEntry] -> [ScoreAttr] -> IO (Maybe String, [ScoreAttr])
    }

------------------------------------------------------

guiState :: (Event -> IO ()) -> IO () -> IO GUIState
guiState event saveState = do
    unsafeInitGUIForThreadedRTS

    xml         <- msglade
    window      <- xmlGetWidget xml castToWindow      "window"
    infoLabel   <- xmlGetWidget xml castToLabel       "infolabel"
    timeLabel   <- xmlGetWidget xml castToLabel       "timelabel"
    frame       <- xmlGetWidget xml castToAspectFrame "frame"
    table       <- xmlGetWidget xml castToDrawingArea "drawingarea"
    tSize       <- newMVar $ board 1 1 -- $ error "module GTK: tSize was not defined"
    setPref     <- setPreferences xml
    newScore    <- newScore_ xml
--    showScores  <- showScores_ xml

    let gst = GUIState
            { timeLabel = timeLabel
            , infoLabel = infoLabel
            , frame     = frame
            , table     = table
            , event     = event
            , window    = window
            , tSize     = tSize
            , setPref   = setPref 
            , newScore  = newScore
--            , showScores= showScores
            }

    table `on` leaveNotifyEvent  $ alwaysTrue $ eventCrossing gst
    table `on` motionNotifyEvent $ alwaysTrue $ eventMotion   gst
    table `on` buttonPressEvent  $ alwaysTrue $ eventButt     gst
    table `on` keyPressEvent     $              eventKey      gst
    table `on` exposeEvent       $ alwaysTrue $ redrawCanvas  gst

    onDestroy  window $ saveState >> mainQuit
    onFocusOut window $ const $ alwaysTrue $ event FocusOut
    onFocusIn  window $ const $ alwaysTrue $ eventFocusIn' gst

    mapM_ (addMenuItem xml)
        [ ("quit",    widgetDestroy  window)
        , ("new",     event   NewEvent)
        , ("pref",    event   OpenPreferences)
        , ("scores",  event   ShowScores)
        , ("reveal",  event $ RevealEvent Nothing)
        , ("mark",    event $ MarkEvent   Nothing)
        , ("undo",    event   UndoEvent)
        , ("redo",    event   RedoEvent)
        , ("hint",    event   HintEvent)
        , ("fullhint",event   FullHintEvent)
        , ("help",    popUpHelp)
        , ("about",   popUpAbout)
        ]

    return gst

startGUI :: GUIState -> IO ()
startGUI gst = do
    widgetShowAll $ window gst
    mainGUI


------------------- input -------------------------

eventFocusIn' gst = do
    pos <- getPosition gst
    event gst $ FocusIn pos

getPosition g = do
    (x, y) <- widgetGetPointer (table g)
    calculatePosition (realToFrac x, realToFrac y) g
    
eventKey :: GUIState -> EventM EKey Bool
eventKey gst = do
    k <- eventKeyName
    liftIO $ case k of
        "Right" -> alwaysTrue $ event gst RightEvent  
        "Left"  -> alwaysTrue $ event gst LeftEvent   
        "Up"    -> alwaysTrue $ event gst UpEvent     
        "Down"  -> alwaysTrue $ event gst DownEvent   
        _       -> return False

eventMotion :: GUIState -> EventM EMotion ()
eventMotion gst = do
    pos <- eventCoordinates
    liftIO $ do
        n <- calculatePosition pos gst
        event gst $ MouseMotion n

eventCrossing :: GUIState -> EventM ECrossing ()
eventCrossing gst = 
    liftIO $ event gst $ MouseMotion Nothing

eventButt :: GUIState -> EventM EButton ()
eventButt gst = do
    pos <- eventCoordinates
    b <- eventButton
    liftIO $ do
        n <- calculatePosition pos gst
        case (n, b) of
            (Just _, LeftButton)    -> event gst $ RevealEvent n
            (Just _, RightButton)   -> event gst $ MarkEvent n
            _                       -> return ()

redrawCanvas :: GUIState -> EventM EExpose ()
redrawCanvas gst 
    = liftIO $ event gst UpdateTable 


calculatePosition :: (Double, Double) -> GUIState -> IO (Maybe Square)
calculatePosition (x, y) g = do
    win <- widgetGetDrawWindow $ table g
    (width, height) <- drawableGetSize win
    let (a, b) = (x / fromIntegral width, y / fromIntegral height)
    s <- readMVar $ tSize g
    return $ square s (ceiling (a * fromIntegral (xSize s))) (ceiling (b * fromIntegral (ySize s)))


----------------------- output --------------------

handleResponses :: GUIState -> UTCTime -> Responses -> IO ()
handleResponses gui t 
    = mapM_ (forkIO . handleResponse gui t)

handleResponse :: GUIState -> UTCTime -> Response -> IO ()
handleResponse gst time e = case e of
    DrawSquares size sl -> do
        swapMVar (tSize gst) size       -- ha megváltozott törölni a képernyőt!!
        postGUISync $ redrawSigns gst size sl
        waitTill (addUTCTime 0.02 time)
        event gst DrawingDone

    ShowTime s -> do
        postGUISync $ labelSetText (timeLabel gst) s

    ShowInfo s -> do
        postGUISync $ labelSetText (infoLabel gst) s
        waitTill (addUTCTime 0.02 time)
        event gst InfoDrawingDone
{-
    PopUpScores c es attrs -> do
        attrs' <- postGUISync $ showScores gst c es attrs
        event gst $ ScoresClosed attrs'
-}
    PopUpNewScore c e es attrs -> do
        (name, attrs') <- postGUISync $ newScore gst c e es attrs
        event gst $ NewScoreClosed name attrs'

    PopUpPreferences c -> do
        mc <- postGUISync $ setPref gst c
        event gst $ PreferencesClosed mc


popUpHelp = do
    xml <- msglade
    a   <- xmlGetWidget xml castToDialog "helpdialog"
    dialogRun a
    widgetDestroy a

popUpAbout = do
    xml <- msglade
    a   <- xmlGetWidget xml castToDialog "aboutdialog"
    dialogRun a
    widgetDestroy a


redrawSigns :: GUIState -> Board -> [(Square, SquareState)] -> IO ()
redrawSigns _ _ [] = return ()
redrawSigns gst s l = do
    win <- widgetGetDrawWindow $ table gst
    style <- widgetGetStyle $ table gst
    backgroundColor <- styleGetBackground style StateNormal
    (width, height) <- drawableGetSize win
    let ss =  (fromIntegral width / fromIntegral (xSize s), fromIntegral height / fromIntegral (ySize s))
    mapM_ (drawSquare win (backgroundColor, blue, green, dangerColor, black, white, between 0.5 black blue, color 1 0.9 0.7) ss) l


drawSquare win style (a, b) (p, xx) = do
    let (x, y) = coords p
    drawWindowBeginPaintRect win $ Rectangle (round $ a*fromIntegral (x-1)) (round $ b*fromIntegral (y-1)) (ceiling a) (ceiling b)
    renderWithDrawable win $ renderSquare style (a, b) (x, y) xx
    drawWindowEndPaint win

------------------------

dangerColor dangerousness = between (realToFrac dangerousness / 100) backgroundColor red

backgroundColor, blue, black, white :: Color
blue        = color 0.65 0.8  1
green       = color 0.65 0.8  0.6
black       = color 0    0    0
white       = color 1    1    1
backgroundColor  = white -- between 0.9 black white       -- TODO: get real background
red         = color 1    0.3  0

between :: Double -> Color -> Color -> Color
between pr (Color a b c) (Color a' b' c') = color (f a a') (f b b') (f c c') where

    f i j = max 0 $ min 1 $ i' + pr * (j' - i')  where
        i' = ff i
        j' = ff j


color :: Double -> Double -> Double -> Color
color r g b = Color (f r) (f g) (f b)  where

    f x = round (65535*x)

ff i = fromIntegral i / 65535

-------------------------------------------------- helper

msglade :: IO GladeXML
msglade = do
    f <- getDataFileName "ms.glade"
    Just xml <- xmlNew f
    return xml

addMenuItem :: GladeXML -> (String, IO ()) -> IO (ConnectId MenuItem)
addMenuItem xml (str, response) = do
    m <- xmlGetWidget xml castToMenuItem str
    onActivateLeaf m response

waitTill :: UTCTime -> IO ()
waitTill time = do
    time' <- getCurrentTime
    case round $ 1000000 * (time `diffUTCTime` time') of
        n | n > 0   -> threadDelay n
        _           -> return ()

alwaysTrue :: Functor m => m a -> m Bool
alwaysTrue = fmap (const True)