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