module Graphics.UI.Gtk.Board.TiledBoard where
import Control.Monad (when, void)
import Control.Monad.Trans (liftIO)
import Data.Array.IO
import Data.IORef
import Data.Maybe (isJust, fromJust)
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Gdk.GC (gcNew)
import System.Glib.Types
import Data.Board.GameBoardIO
data Board index tile piece = Board
{ boardDrawingArea :: DrawingArea
, boardTiles :: GameBoard index tile
, boardPieces :: GameBoard index piece
, tilePixmaps :: PixmapsFor tile
, piecePixmaps :: PixmapsFor piece
, tileSize :: (Int, Int)
, background :: IORef (Maybe (Pixbuf, SizeAdjustment))
, overlay :: IORef (Maybe (Pixbuf, SizeAdjustment))
, dragEnabled :: IORef Bool
, draggingFrom :: IORef (Maybe (index, index))
, draggingTo :: IORef (Maybe (index, index))
, draggingMouseOrig :: IORef (Maybe (Int, Int))
, draggingMousePos :: IORef (Maybe (Int, Int))
, movingStatus :: IORef (Maybe (MovingStatus index))
}
data MovingStatus index = MovingStatus
{ movingFrom :: (index, index)
, movingTo :: (index, index)
, stepsPerUnit :: Double
, timePerUnit :: Double
, movingStep :: Double
}
instance WidgetClass (Board index tile piece)
instance ObjectClass (Board index tile piece)
instance GObjectClass (Board index tile piece) where
toGObject = toGObject . boardDrawingArea
unsafeCastGObject x = Board (unsafeCastGObject x) undefined undefined undefined undefined undefined undefined undefined undefined undefined undefined undefined undefined undefined
type PixmapsFor a = a -> Pixbuf
data SizeAdjustment = SizeAdjustment
boardNew :: Ix index
=> [(index,index,tile)] -> PixmapsFor tile -> PixmapsFor piece
-> IO (Board index tile piece)
boardNew tileList tilePixs piecePixs = do
da <- drawingAreaNew
tb <- gameBoardNew tileList
pb <- gameBoardNewEmpty (map (\(x,y,_) -> (x,y)) tileList)
ts <- getTileSize tileList tilePixs
bg <- newIORef Nothing
ov <- newIORef Nothing
dragging <- newIORef False
draggingF <- newIORef Nothing
draggingT <- newIORef Nothing
draggingO <- newIORef Nothing
draggingP <- newIORef Nothing
movingSt <- newIORef Nothing
let board = Board da tb pb tilePixs piecePixs ts bg ov
dragging draggingF draggingT draggingO draggingP
movingSt
(pixW, pixH) <- boardGetPixelSize board
da `on` realize $ widgetSetSizeRequest da pixW pixH
da `on` exposeEvent $ liftIO (boardRefresh board) >> return False
return board
getTileSize :: [(index, index, tile)] -> PixmapsFor tile -> IO (Int, Int)
getTileSize [] _ = return (0,0)
getTileSize ((_,_,t):_) pixs = do
let pb = pixs t
w <- pixbufGetWidth pb
h <- pixbufGetHeight pb
return (w,h)
boardGetPiece :: Ix index => (index, index) -> Board index tile piece -> IO (Maybe piece)
boardGetPiece pos board = gameBoardGetPiece pos (boardPieces board)
boardSetPiece :: Ix index => (index, index) -> piece -> Board index tile piece -> IO ()
boardSetPiece pos piece board = do
boardSetPieceNoRefresh pos piece board
boardInvalidate board
boardSetPieceNoRefresh :: Ix index => (index, index) -> piece -> Board index tile piece -> IO ()
boardSetPieceNoRefresh pos piece board = do
posOk <- fmap isJust $ gameBoardGetPiece pos $ boardTiles board
when posOk $ do
gameBoardSetPiece pos piece (boardPieces board)
boardRemovePiece :: Ix index => (index, index) -> Board index tile piece -> IO ()
boardRemovePiece pos board = do
posOk <- fmap isJust $ gameBoardGetPiece pos $ boardTiles board
when posOk $ do
gameBoardRemovePiece pos (boardPieces board)
boardInvalidate board
boardMovePiece :: Ix index => (index, index) -> (index, index) -> Board index tile piece -> IO ()
boardMovePiece posO posD board = do
posOrigOk <- fmap isJust $ gameBoardGetPiece posO $ boardTiles board
posDestOk <- fmap isJust $ gameBoardGetPiece posD $ boardTiles board
when (posOrigOk && posDestOk) $ do
gameBoardMovePiece posO posD $ boardPieces board
boardInvalidate board
boardInvalidate :: Ix index => Board index tile piece -> IO ()
boardInvalidate = widgetQueueDraw
boardRefresh :: Ix index => Board index tile piece -> IO ()
boardRefresh board = do
realized <- widgetGetRealized board
when realized $ do
dw <- widgetGetDrawWindow (boardDrawingArea board)
(w,h) <- widgetGetSize (boardDrawingArea board)
bg <- readIORef (background board)
ov <- readIORef (overlay board)
drawWindowBeginPaintRect dw (Rectangle 0 0 w h)
drawWindowClear dw
gc <- gcNew dw
when (isJust bg) $ do
((posBgX, posBgY), bg') <- uncurry (adjustPixbuf (w,h)) (fromJust bg)
drawPixbuf dw gc bg' 0 0 posBgX posBgY (1) (1) RgbDitherNone (1) (1)
posM <- readIORef (draggingFrom board)
mpOrig <- readIORef (draggingMouseOrig board)
mpPos <- readIORef (draggingMousePos board)
drawPixmaps dw (tileSize board) (boardTiles board) (tilePixmaps board)
piecesBoard <- if isJust posM && isJust mpOrig && isJust mpPos
then do pieces' <- gameBoardClone $ boardPieces board
gameBoardRemovePiece (fromJust posM) pieces'
return pieces'
else return $ boardPieces board
drawPixmaps dw (tileSize board) piecesBoard (piecePixmaps board)
when (isJust posM && isJust mpOrig && isJust mpPos) $ do
pieceM <- boardGetPiece (fromJust posM) board
when (isJust pieceM) $ do
let pb = piecePixmaps board (fromJust pieceM)
let (mpPosX, mpPosY) = fromJust mpPos
(mpOrigX, mpOrigY) = fromJust mpOrig
(x,y) = (mpPosX mpOrigX, mpPosY mpOrigY)
drawPixbuf dw gc pb 0 0 x y (1) (1) RgbDitherNone (1) (1)
when (isJust ov) $ do
((posOvX, posOvY), ov') <- uncurry (adjustPixbuf (w,h)) (fromJust ov)
drawPixbuf dw gc ov' 0 0 posOvX posOvY (1) (1) RgbDitherNone (1) (1)
drawWindowEndPaint dw
adjustPixbuf :: (Int, Int) -> Pixbuf -> SizeAdjustment -> IO ((Int, Int), Pixbuf)
adjustPixbuf _ pb _ = return ((0,0), pb)
mouseMotionHandler :: Ix index => Board index tile piece -> ((index, index) -> EventM EMotion Bool) -> EventM EMotion Bool
mouseMotionHandler board p = do
coords <- eventCoordinates
pos <- liftIO $ getMouseCoordinates board coords
maybe (return False) p pos
mouseButtonHandler :: Ix index => Board index tile piece -> ((index, index) -> EventM EButton Bool) -> EventM EButton Bool
mouseButtonHandler board p = do
coords <- eventCoordinates
pos <- liftIO $ getMouseCoordinates board coords
maybe (return False) p pos
getMouseCoordinates :: Ix index => Board index tile piece -> (Double, Double) -> IO (Maybe (index, index))
getMouseCoordinates board (x,y) = do
let (tileW, tileH) = tileSize board
tileCol = round x `div` tileW
tileRow = round y `div` tileH
let (GameBoard array) = boardTiles board
((xm, ym), (xM, yM)) <- getBounds $ array
let xs = range (xm, xM)
ys = range (ym, yM)
if (inRange (0, length xs 1) tileCol && inRange (0, length ys 1) tileRow)
then return $ Just ((head (drop tileCol xs)), (head (drop tileRow ys)))
else return Nothing
clickHandler :: Ix index => Board index tile piece -> ((index, index) -> IO ()) -> EventM EButton Bool
clickHandler board p = do
(x,y) <- eventCoordinates
liftIO $ do
let (tileW, tileH) = tileSize board
tileCol = round x `div` tileW
tileRow = round y `div` tileH
let (GameBoard array) = boardTiles board
((xm, ym), (xM, yM)) <- getBounds $ array
let xs = range (xm, xM)
ys = range (ym, yM)
when (inRange (0, length xs 1) tileCol && inRange (0, length ys 1) tileRow) $
p ((head (drop tileCol xs)), (head (drop tileRow ys)))
return False
boardGetPixelSize :: Ix index => Board index tile piece -> IO (Int, Int)
boardGetPixelSize board = do
let (GameBoard array) = boardTiles board
((xm, ym), (xM, yM)) <- getBounds $ array
let htiles = rangeSize (xm, xM)
vtiles = rangeSize (ym, yM)
(tileW, tileH) = tileSize board
return (htiles * tileW, vtiles * tileH)
drawPixmaps :: (Ix index, DrawableClass d) => d -> (Int, Int) -> GameBoard index e -> PixmapsFor e -> IO()
drawPixmaps d tileSize@(tw, th) gameBoard@(GameBoard array) pixmaps = do
gc <- gcNew d
((xm, ym), (xM, yM)) <- gameBoardGetBoundaries gameBoard
let paintPixmap (x,y) elem = do
let pixmap = pixmaps elem
ix = index (xm, xM) x
iy = index (ym, yM) y
posX = ix * tw
posY = iy * th
drawPixbuf d gc pixmap 0 0 posX posY (1) (1) RgbDitherNone (1) (1)
gameBoardMapM_ gameBoard paintPixmap
boardFoldM :: (Ix index) => Board index tile piece -> (b -> ((index,index), piece) -> IO b) -> b -> IO b
boardFoldM board f def = gameBoardFoldM (boardPieces board) f def
boardClear :: Ix index => Board index tile piece -> IO ()
boardClear board = do
gameBoardClear (boardPieces board)
boardInvalidate board
boardLoad :: Ix index => Board index tile piece -> [((index, index), piece)] -> IO()
boardLoad board pieces = do
gameBoardClear (boardPieces board)
mapM_ (\(pos, piece) -> boardSetPieceNoRefresh pos piece board) pieces
boardRefresh board
boardOnClick :: Ix index => Board index tile piece -> ((index, index) -> IO ()) -> IO()
boardOnClick board p = boardOnPress board (\c -> liftIO (p c) >> return False)
boardOnPress :: Ix index => Board index tile piece -> ((index, index) -> EventM EButton Bool) -> IO()
boardOnPress board f = void $ do
widgetAddEvents (boardDrawingArea board) [ButtonPressMask]
(boardDrawingArea board) `on` buttonPressEvent $ mouseButtonHandler board f
boardOnRelease :: Ix index => Board index tile piece -> ((index, index) -> EventM EButton Bool) -> IO()
boardOnRelease board f = void $ do
widgetAddEvents (boardDrawingArea board) [ButtonPressMask, ButtonReleaseMask]
(boardDrawingArea board) `on` buttonReleaseEvent $ mouseButtonHandler board f
boardOnMotion :: Ix index => Board index tile piece -> ((index, index) -> EventM EMotion Bool) -> IO()
boardOnMotion board f = void $ do
widgetAddEvents board [PointerMotionMask]
(boardDrawingArea board) `on` motionNotifyEvent $ mouseMotionHandler board f
boardSetBackground :: Ix index => Board index tile piece -> Maybe (Pixbuf, SizeAdjustment) -> IO()
boardSetBackground board bg = do
writeIORef (background board) bg
boardInvalidate board
boardSetOverlay :: Ix index => Board index tile piece -> Maybe (Pixbuf, SizeAdjustment) -> IO()
boardSetOverlay board bg = do
writeIORef (overlay board) bg
boardInvalidate board
boardEnableDrag :: Ix index => Board index tile piece -> IO()
boardEnableDrag board = writeIORef (dragEnabled board) True
boardDisableDrag :: Ix index => Board index tile piece -> IO()
boardDisableDrag board = do
writeIORef (dragEnabled board) False
boardInvalidate board
boardStartDrag :: Ix index => Board index tile piece -> (index, index) -> IO()
boardStartDrag board ix@(i,j) = do
writeIORef (draggingFrom board) (Just ix)
((xm, ym), (xM, yM)) <- gameBoardGetBoundaries $ boardPieces board
let (w,h) = tileSize board
x = round ((0.5 + fromIntegral (rangeSize (xm, i))) * fromIntegral w)
y = round ((0.5 + fromIntegral (rangeSize (ym, j))) * fromIntegral h)
writeIORef (draggingMouseOrig board) (Just (x, y))
boardStopDrag :: Ix index => Board index tile piece -> IO()
boardStopDrag board = do
writeIORef (draggingFrom board) Nothing
writeIORef (draggingTo board) Nothing
boardInvalidate board
boardOnPieceDragStart :: Ix index => Board index tile piece -> ((index, index) -> IO Bool) -> IO()
boardOnPieceDragStart board f = boardOnPress board $ \ix -> do
(x,y) <- eventCoordinates
returning False $ liftIO $ do
drag <- readIORef (dragEnabled board)
when drag $ do
canDragThis <- f ix
let from = if canDragThis then Just ix else Nothing
orig = if canDragThis then Just (relativePos board ix (round x, round y)) else Nothing
writeIORef (draggingFrom board) from
writeIORef (draggingMouseOrig board) orig
boardInvalidate board
boardOnPieceDragOver :: Ix index => Board index tile piece -> ((index, index) -> (index, index) -> IO Bool) -> IO()
boardOnPieceDragOver board f = boardOnMotion board $ \ix -> do
(x,y) <- eventCoordinates
returning False $ liftIO $ do
drag <- readIORef (dragEnabled board)
origM <- readIORef (draggingFrom board)
when (drag && isJust origM) $ do
canDropHere <- f (fromJust origM) ix
let newDest = if canDropHere then Just ix else Nothing
writeIORef (draggingTo board) newDest
writeIORef (draggingMousePos board) (Just (round x, round y))
boardInvalidate board
boardOnPieceDragDrop :: Ix index => Board index tile piece -> ((index, index) -> (index, index) -> IO ()) -> IO()
boardOnPieceDragDrop board f = void $ do
widgetAddEvents (boardDrawingArea board) [ButtonPressMask, ButtonReleaseMask]
(boardDrawingArea board) `on` buttonReleaseEvent $ returning False $ liftIO $ do
drag <- readIORef (dragEnabled board)
origM <- readIORef (draggingFrom board)
destM <- readIORef (draggingTo board)
let notSame = origM /= destM
when (drag && isJust origM) $ do
writeIORef (draggingFrom board) Nothing
writeIORef (draggingTo board) Nothing
writeIORef (draggingMouseOrig board) Nothing
writeIORef (draggingMousePos board) Nothing
when (isJust destM && notSame) $ f (fromJust origM) (fromJust destM)
boardInvalidate board
boardIsDragging :: Ix index => Board index tile piece -> IO Bool
boardIsDragging = fmap isJust . readIORef . draggingFrom
relativePos :: Ix index => Board index tile piece -> (index, index) -> (Int, Int) -> (Int, Int)
relativePos board (ix,iy) (x,y) = (x', y')
where (w,h) = tileSize board
x' = x `mod` w
y' = y `mod` h
returning :: Monad m => a -> m b -> m a
returning v f = f >> return v