{-# LANGUAGE ViewPatterns #-}
module Table
( GameTable
, newTable
, St (Stopped, Normal, Fixed)
, setTableSt
, resizeTable
, adjustButts
, adjustButtsInc
, getFocusPos
) where
import TableGraphics
import Place
import PlaceSet
import Game
import Graphics.Rendering.Cairo
import Graphics.UI.Gtk.Gdk.EventM
import Graphics.UI.Gtk hiding (Clear, fill)
import Control.Monad (when)
import Control.Concurrent.MVar
import qualified Data.Map as M
import Data.Maybe
---------------------
-- ez van kivetítve
data IState = IState
{ size_ :: (Int, Int)
, board_ :: Board
, focusPos :: Place
, hidden :: St
}
data St
= Stopped
| Fixed
| Normal (Maybe Place)
deriving Eq
data GameTable
= T
{ frame :: AspectFrame
, area :: DrawingArea
, states :: MVar IState
, flag_ :: Place -> IO ()
, reveal :: Place -> IO ()
}
---------------------
newTable :: AspectFrame -> (Place -> IO ()) -> (Place -> IO ()) -> IO GameTable
newTable asp fA rA = do
canvas <- drawingAreaNew
m <- newMVar undefined
let g = T asp canvas m fA rA
containerAdd asp canvas
set canvas [widgetCanFocus := True]
widgetAddEvents canvas [LeaveNotifyMask, PointerMotionMask, KeyPressMask]
canvas `on` exposeEvent $ updateCanvas g
canvas `on` leaveNotifyEvent $ changeCanvas_ g
canvas `on` motionNotifyEvent $ changeCanvas g
canvas `on` buttonPressEvent $ changeCanvas' g
canvas `on` keyPressEvent $ changeCanvasKey g
return g
getFocusPos :: GameTable -> IO Place
getFocusPos g = fmap focusPos $ readMVar (states g)
setTableSt :: GameTable -> (St -> St) -> IO ()
setTableSt g fx = redrawButts_ g f where
f ss
| x == hh = ([], ss)
| Stopped `elem` [x, hh]
= (M.toList $ board_ ss, ss')
| otherwise
= (map h $ focusPos ss: ff hh ++ ff x, ss')
where
ss' = ss { hidden = x }
h p = (p, board_ ss M.! p)
x = fx hh
hh = hidden ss
ff (Normal (Just x)) = [x]
ff _ = []
resizeTable :: (Int, Int) -> GameTable -> IO ()
resizeTable s@(xS, yS) g = do
set (frame g) [aspectFrameRatio := fromIntegral xS / fromIntegral yS]
swapMVar (states g) $ IState
{ size_ = s
, board_ = M.fromList $ zip (placeSetToList $ places s) $ repeat $ Hidden False Nothing
, focusPos = place 1 1
, hidden = Normal Nothing
}
win <- drawingAreaGetDrawWindow' g
drawWindowClear win
updateCanvas' g
------------------
updateCanvas :: GameTable -> EventM EExpose Bool
updateCanvas g = do
liftIO $ updateCanvas' g
return True
updateCanvas' g = do
redrawButts_ g $ \ss -> (M.toList $ board_ ss, ss)
adjustButts :: GameTable -> Board -> IO ()
adjustButts g b =
redrawButts_ g $ \ss -> ([p | (p,y) <- zip (M.assocs b) (M.elems $ board_ ss), snd p /= y], ss { board_ = b })
adjustButtsInc :: GameTable -> [(Place, State)] -> IO ()
adjustButtsInc g [] = return ()
adjustButtsInc g ((p, s):ps) = do
redrawButts_ g $ \ss -> ([(p, s)], ss { board_ = M.insert p s $ board_ ss })
adjustButtsInc g ps
redrawButts :: GameTable -> [Place] -> IO ()
redrawButts g l
= redrawButts_ g $ \ss -> ([(p, board_ ss M.! p)| p <- l], ss)
redrawButts_ :: GameTable -> (IState -> ([(Place, State)], IState)) -> IO ()
redrawButts_ g f = do
ss <- takeMVar (states g)
let (ps, ss') = f ss
redrawButts__ g ss' ps
putMVar (states g) $ ss'
redrawButts__ :: GameTable -> IState -> [(Place, State)] -> IO ()
redrawButts__ gg g l = do
win <- drawingAreaGetDrawWindow' gg
let
size = size_ g
m = board_ g
b = hidden g
pp = case b of
Normal x -> x
_ -> Nothing
foc = focusPos g
let f (p, s) = do
renderWithDrawable' p size win $ drawPlace (b == Stopped) (isNormal b && pp == Just p) (p == foc && isNormal b) p s
mapM_ f l
isNormal (Normal _) = True
isNormal _ = False
renderWithDrawable' (coords -> (x,y)) (xx, yy) win m = do
(width, height) <- drawableGetSize_ win
let
a = width/fromIntegral xx
b = height/fromIntegral yy
drawWindowBeginPaintRect win $ Rectangle (round $ a*fromIntegral (x-1)) (round $ b*fromIntegral (y-1)) (round a) (round b)
renderWithDrawable win $ do
scale a b
translate (fromIntegral x - 0.5) (fromIntegral y - 0.5)
m
drawWindowEndPaint win
drawableGetSize_ win = do
(width, height) <- drawableGetSize win
return (realToFrac width, realToFrac height)
changeCanvas :: GameTable -> EventM EMotion Bool
changeCanvas g = do
pos <- eventCoordinates
liftIO $ do
n <- calcPos_ pos g
changeC n g
changeCanvas_ :: GameTable -> EventM ECrossing Bool
changeCanvas_ g = liftIO $ do
let n = Nothing
changeC n g
changeC n g = do
ss <- readMVar (states g)
case hidden ss of
Normal m -> do
ss <- takeMVar (states g)
putMVar (states g) $ ss { hidden = Normal n }
if m /= n
then redrawButts g $ catMaybes [m, n]
else return ()
_ -> return ()
return True
changeCanvas' :: GameTable -> EventM EButton Bool
changeCanvas' g = do
pos <- eventCoordinates
b <- eventButton
liftIO $ do
ss <- readMVar (states g)
when (isNormal (hidden ss)) $ do
n <- calcPos_ pos g
case (n, b) of
(Just p, LeftButton) -> reveal g p
(Just p, RightButton) -> flag_ g p
_ -> return ()
return True
changeCanvasKey :: GameTable -> EventM EKey Bool
changeCanvasKey g = do
k <- eventKeyName
liftIO $ do
case k of
"Right" -> moveFocus ( 1, 0)
"Left" -> moveFocus (-1, 0)
"Down" -> moveFocus ( 0, 1)
"Up" -> moveFocus ( 0,-1)
_ -> return False
where
moveFocus (dx, dy) = do
ss <- readMVar (states g)
when (isNormal (hidden ss)) $ do
ss <- takeMVar (states g)
let
foc@(coords -> (x, y)) = focusPos ss
(sx, sy) = size_ ss
foc' = place (max 1 $ min sx $ dx + x) (max 1 $ min sy $ dy + y)
putMVar (states g) $ ss { focusPos = foc' }
if foc /= foc'
then redrawButts g [foc, foc']
else return ()
return True
drawingAreaGetDrawWindow' = widgetGetDrawWindow . area
calcPos_ pos g = do
win <- drawingAreaGetDrawWindow' g
ss <- readMVar (states g)
(width, height) <- drawableGetSize_ win
return $ calcPos (size_ ss) (width, height) pos
calcPos (xx, yy) (width, height) (x,y)
| i + 1 `between` (1, xx) && j + 1 `between` (1, yy) {- && ii>0 && ii<9 && jj>0 && jj<9 -}
= Just $ place (i+1) (j+1)
| otherwise = Nothing
where
a = floor (x/width*10* fromIntegral xx)
b = floor (y/height*10* fromIntegral yy)
(i,_ii) = a `divMod` 10
(j,_jj) = b `divMod` 10
infix 4 `between`
a `between` (b, c) = b <= a && a <= c