{-# LANGUAGE CPP #-}
module Game.Goatee.Ui.Gtk.Tool.AssignStone (AssignStoneTool, create) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (forM_, when)
import Game.Goatee.Lib.Board
import qualified Game.Goatee.Lib.Monad as Monad
import Game.Goatee.Lib.Monad (
deleteChildAt, execGo, getAssignedStone, getCursor, modifyAssignedStones,
)
import Game.Goatee.Lib.Types
import Game.Goatee.Ui.Gtk.Common
import Game.Goatee.Ui.Gtk.Latch
import Graphics.UI.Gtk (
AttrOp ((:=)),
HBox,
RadioButton,
containerAdd,
get,
hBoxNew,
on,
radioButtonNewWithLabel, radioButtonNewWithLabelFromWidget,
set,
toggleButtonActive, toggled,
toWidget,
)
data AssignStoneTool ui = AssignStoneTool
{ myUi :: ui
, myViewState :: ViewState
, myToolState :: ToolState
, myStone :: Maybe Color
, myWidgets :: Widgets
}
data Widgets = Widgets
{ myBox :: HBox
, myBlackButton :: RadioButton
, myWhiteButton :: RadioButton
, myEmptyButton :: RadioButton
, myViewUpdateLatch :: Latch
}
instance UiCtrl go ui => UiView go ui (AssignStoneTool ui) where
viewName me = "AssignStoneTool(" ++ show (myStone me) ++ ")"
viewCtrl = myUi
viewState = myViewState
viewUpdate = const $ return ()
instance UiCtrl go ui => UiTool go ui (AssignStoneTool ui) where
toolState = myToolState
toolPanelWidget = Just . toWidget . myBox . myWidgets
toolOnActivating me = do
let latch = myViewUpdateLatch $ myWidgets me
withLatchOn latch $ set (myRadioButton me) [toggleButtonActive := True]
toolGobanClickComplete me (Just from) (Just to) = do
stoneToAssign <- oppositeOfAssignmentAtPoint me from
doUiGo (myUi me) $ do
modifyAssignedStones (coordRange from to) $ const stoneToAssign
cursor <- getCursor
when (null $ cursorProperties cursor) $
case (cursorParent cursor, cursorChildIndex cursor) of
(Just _, childIndex) -> do
Monad.goUp
deleteChildAt childIndex
return ()
_ -> return ()
toolGobanClickComplete _ _ _ = return ()
toolGobanRenderGetBoard me cursor = do
state <- toolGetGobanState me
case (toolGobanStateStartCoord state, toolGobanStateCurrentCoord state) of
(Just startCoord, Just endCoord) -> do
stoneToAssign <- oppositeOfAssignmentAtPoint me startCoord
return $ cursorBoard $ flip execGo cursor $
modifyAssignedStones (coordRange startCoord endCoord) $ const stoneToAssign
_ -> return $ cursorBoard cursor
create :: UiCtrl go ui
=> ui
-> Maybe Color
-> Maybe (AssignStoneTool ui)
-> ToolState
-> IO (AssignStoneTool ui)
create ui stone existingTool toolState = do
viewState <- viewStateNew
widgets <- maybe (createWidgets ui) (return . myWidgets) existingTool
return AssignStoneTool
{ myUi = ui
, myViewState = viewState
, myToolState = toolState
, myStone = stone
, myWidgets = widgets
}
createWidgets :: UiCtrl go ui => ui -> IO Widgets
createWidgets ui = do
box <- hBoxNew True 0
blackButton <- radioButtonNewWithLabel "Black"
whiteButton <- radioButtonNewWithLabelFromWidget blackButton "White"
emptyButton <- radioButtonNewWithLabelFromWidget blackButton "Empty"
latch <- newLatch
forM_ [ (blackButton, ToolAssignBlack)
, (whiteButton, ToolAssignWhite)
, (emptyButton, ToolAssignEmpty)
] $ \(button, toolType) -> do
containerAdd box button
on button toggled $ do
active <- get button toggleButtonActive
when active $ whenLatchOff latch $ setTool ui toolType
return Widgets
{ myBox = box
, myBlackButton = blackButton
, myWhiteButton = whiteButton
, myEmptyButton = emptyButton
, myViewUpdateLatch = latch
}
myRadioButton :: AssignStoneTool ui -> RadioButton
myRadioButton me =
(case myStone me of
Just Black -> myBlackButton
Just White -> myWhiteButton
Nothing -> myEmptyButton) $ myWidgets me
oppositeOfAssignmentAtPoint :: UiCtrl go ui
=> AssignStoneTool ui
-> Coord
-> IO (Maybe (Maybe Color))
oppositeOfAssignmentAtPoint me coord =
toggle (myStone me) <$> doUiGo (myUi me) (getAssignedStone coord)