import Table
import Delay
import Timer
import Game
import Place

import Paths_minesweeper

import Graphics.UI.Gtk hiding (Clear)
import Graphics.UI.Gtk.Glade

import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad (when)

import System.Random

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

type UGState = ([GState], [GState]) 

-- | Program state
data ProgramState = ProgramState
    { timer  :: Tim             -- ^ timer state
    , label  :: Label           -- ^ label component (constant)
    , gstate :: MVar UGState    -- ^ game state (model)
    , table  :: GameTable       -- ^ table state (view)
    , seed   :: MVar StdGen
    }


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

main :: IO ()
main = mdo
    initGUI
    timeoutAddFull (yield >> return True) priorityDefaultIdle 50

    xml <- msglade
    window      <- xmlGetWidget xml castToWindow "window1"
    lab         <- xmlGetWidget xml castToLabel "label1"
    timeLabel   <- xmlGetWidget xml castToLabel "label7"
    asp_        <- xmlGetWidget xml castToAspectFrame "aspectframe1"

    asp     <- newTable asp_ (checkWin pst . flag') (checkWin pst . revealRec)

    se <- newStdGen
    ss <- newMVar se

    let pst = ProgramState tim lab gst asp ss

    mapM_ (addMenuItem xml)
        [ ("imagemenuitem5",  widgetDestroy window)
        , ("imagemenuitem1",  newGame pst)
        , ("imagemenuitem6",  preferences pst)
        , ("imagemenuitem3",  helpDialog)
        , ("imagemenuitem10", aboutDialog)
        , ("imagemenuitem9",  clear pst $ checkWin pst . revealRec)
        , ("imagemenuitem11", clear pst $ checkWin pst . flag')
        , ("imagemenuitem12", undo pst)
        , ("imagemenuitem15", redo pst)
        , ("menuitem2",  reveal False pst)
        , ("menuitem6",  reveal True pst)
        ]

    onDestroy window mainQuit

    gst     <- newMVar ([initGState (10,10) 20], [])
    tim     <- newTimer (labelSetText timeLabel) 

    hideTableVar <- newCancelVar
    showTableVar <- newCancelVar

    onFocusOut window $ \_ -> do
        when' (isActiveTimer tim) $ do
            stopTimer True tim
            doLater hideTableVar (1::Double) (setTableSt asp $ \s -> if s == Fixed then s else Stopped)
        return False

    onFocusIn window $ \_ -> do
        when' (fmap not $ isActiveTimer tim) $ do
            cancelAction hideTableVar
            setTableSt asp $ \s -> if s == Fixed then s else Normal Nothing
            startTimer True tim
        return False

    widgetShowAll window
    resizeTable_ pst

    mainGUI

flag' a b r = (c, d, r) where (c, d) = flag a b

clear :: ProgramState -> (Place -> IO ()) -> IO ()
clear pst m = do
    p <- getFocusPos (table pst)
    m p 

reveal :: Bool -> ProgramState -> IO ()
reveal all pst = withUState pst f where
    f s@(g: _, _) = do
        startTimer False (timer pst)
        stopTimer False (timer pst)
        return $ smartUndo (reveal' all g) s

undo :: ProgramState -> IO ()
undo pst = withUState pst f where
    f (g:g':gs, redos) = do
        stopTimer False (timer pst)
        return (g':gs, g:redos)
    f x = return x

redo :: ProgramState -> IO ()
redo pst = withUState pst f where
    f (gs, g:redos) = return (g:gs, redos)
    f x = return x

newGame :: ProgramState -> IO ()
newGame pst = withUState pst f where
    f (as, _) = do
        resetTimer (timer pst)
        return ([last as], [])

resizeTable_ :: ProgramState -> IO ()
resizeTable_ pst = do

    (g:_, _) <- readMVar (gstate pst)
    resizeTable (size g) (table pst)
    newGame pst


addMenuItem 
    :: GladeXML
   -> (String, IO ())
   -> IO (ConnectId MenuItem)

addMenuItem xml (str, action) = do
    m   <- xmlGetWidget xml castToMenuItem str
    onActivateLeaf m action


preferences :: ProgramState -> IO ()
preferences pst = do
    xml <- msglade
    a   <- xmlGetWidget xml castToDialog "dialog1"
    sx  <- xmlGetWidget xml castToSpinButton "spinbutton3"
    sy  <- xmlGetWidget xml castToSpinButton "spinbutton1"
    ms  <- xmlGetWidget xml castToSpinButton "spinbutton4"

    al@(g:_, _) <- takeMVar $ gstate pst
    let (xS,yS) = size g
    set sx [spinButtonValue := fromIntegral xS]
    set sy [spinButtonValue := fromIntegral yS]
    set ms [spinButtonValue := fromIntegral $ mines g]

    let setRange = do
        x <- get sx spinButtonValue
        y <- get sy spinButtonValue
        spinButtonSetRange ms 0 (x*y)

    onValueSpinned sx setRange
    onValueSpinned sy setRange

    setRange

    r <- dialogRun a
    case r of
        ResponseOk  -> do
            x   <- get sx spinButtonValue
            y   <- get sy spinButtonValue
            mines_   <- get ms spinButtonValue
            putMVar (gstate pst) ([initGState (round x, round y) (round mines_)], [])
            resizeTable_ pst

        _ -> 
            putMVar (gstate pst) al

    widgetDestroy a
    return ()



checkWin :: ProgramState -> (GState -> StdGen -> ([(Place, State)], GState, StdGen)) -> IO ()
checkWin pst f = withUState pst $ \x -> case x of
    s@(g:gs, redo)   | not (isEnd g) ->  do
        startTimer False $ timer pst
        r <- takeMVar $ seed pst
        let (ps, g', r') = f g r
        adjustButtsInc (table pst) ps
        putMVar (seed pst) r' 
        when (isEnd g') $ do
            _ti <- stopTimer False $ timer pst
            return ()
        return $ smartUndo g' s

    _   -> return x

smartUndo g' (gs, redo) = (g': drop x gs, if x==1 then redo else [])
 where
   x = deservesUndo g' gs


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

aboutDialog :: IO ()
aboutDialog =  do
    xml <- msglade
    a   <- xmlGetWidget xml castToAboutDialog "aboutdialog1"
    dialogRun a
    widgetDestroy a
    return ()

helpDialog :: IO ()
helpDialog =  do
    xml <- msglade
    a   <- xmlGetWidget xml castToDialog "dialog2"
    dialogRun a
    widgetDestroy a
    return ()


withUState pst f = modifyMVarInSeparateThread (gstate pst) (\x -> f x >>= h)  where
    h s@(g: gs, redos) = do
        adjustButts (table pst) (board g)
        setTableSt (table pst) $ if isEnd g then const Fixed else ff
        labelSetText (label pst) $ info g
        return s

    ff (Normal x) = Normal x
    ff _ = Normal Nothing
-------------------

when' :: Monad m => m Bool -> m a -> m ()
when' f g = f >>= \b -> if b then g >> return () else return ()

-- | modifies an mvar if it is not taken already
modifyMVarInSeparateThread :: MVar a -> (a -> IO a) -> IO ()
modifyMVarInSeparateThread v f = do
    b <- isEmptyMVar v
    if not b 
        then do
            forkIO (modifyMVar_ v f)
            return () 
        else 
            return ()


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