module GTK
( GUIState
, guiState
, startGUI
, handleResponses
) where
import Preferences
import State
import Event
import Core.Square
import GTK.Square
import GTK.Preferences
import GTK.Score
import Paths_minesweeper
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Glade
import Graphics.Rendering.Cairo (liftIO) -- ???
import Data.Time.Clock
import Control.Monad (when)
import Control.Concurrent
------------------------------------------------------
data GUIState = GUIState
{ infoLabel :: Label
, timeLabel :: Label
, frame :: AspectFrame
, table :: DrawingArea
, window :: Window
, event_ :: Event -> IO ()
, tSize :: MVar BoardSize
, setPref :: Preferences -> IO (Maybe Preferences)
, newScore :: Preferences -> 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 $ boardSize 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
old_size <- takeMVar $ tSize gst
putMVar (tSize gst) size
postGUISync $ redrawSigns gst size sl
waitTill (addUTCTime 0.02 time)
event_ gst DrawingDone
when (old_size /= size) $ do
set (frame gst) [aspectFrameRatio := fromIntegral (xSize size) / fromIntegral (ySize size)]
event_ gst UpdateTable
ShowTime s -> do
postGUISync $ labelSetText (timeLabel gst) $ show s
ShowInfo s -> do
postGUISync $ labelSetText (infoLabel gst) $ show 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 -> BoardSize -> [(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)