module Game.Goatee.Ui.Gtk.Tool.Mark (MarkTool, create) where
import Control.Monad (forM_, when)
import Game.Goatee.Lib.Board
import Game.Goatee.Lib.Monad (getMark, modifyMark)
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 MarkTool ui = MarkTool
{ myUi :: ui
, myViewState :: ViewState
, myToolState :: ToolState
, myMark :: Mark
, myWidgets :: Widgets
}
data Widgets = Widgets
{ myBox :: HBox
, myCircleButton :: RadioButton
, mySelectedButton :: RadioButton
, mySquareButton :: RadioButton
, myTriangleButton :: RadioButton
, myXButton :: RadioButton
, myViewUpdateLatch :: Latch
}
instance UiCtrl go ui => UiView go ui (MarkTool ui) where
viewName me = "MarkTool(" ++ show (myMark me) ++ ")"
viewCtrl = myUi
viewState = myViewState
viewUpdate = const $ return ()
instance UiCtrl go ui => UiTool go ui (MarkTool 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
let ui = myUi me
mark = myMark me
oldMark <- doUiGo ui $ getMark from
let newMark = case oldMark of
Just mark' | mark' == mark -> Nothing
_ -> Just mark
doUiGo ui $ mapM_ (modifyMark $ const newMark) $ coordRange from to
toolGobanClickComplete _ _ _ = return ()
toolGobanRenderGetBoard me cursor = do
let board = cursorBoard cursor
state <- toolGetGobanState me
return $ case toolGobanStateStartCoord state of
Nothing -> board
Just startCoord -> do
let mark = myMark me
applyMark = setMarkToOppositeOf mark $
boardCoordState startCoord board
foldr (\coord board' -> boardCoordModify board' coord applyMark)
board
(case state of
ToolGobanHovering (Just coord) -> [coord]
ToolGobanDragging _ (Just from) (Just to) -> coordRange from to
_ -> [])
create :: UiCtrl go ui => ui -> Mark -> Maybe (MarkTool ui) -> ToolState -> IO (MarkTool ui)
create ui mark existingTool toolState = do
viewState <- viewStateNew
widgets <- maybe (createWidgets ui) (return . myWidgets) existingTool
return MarkTool
{ myUi = ui
, myViewState = viewState
, myToolState = toolState
, myMark = mark
, myWidgets = widgets
}
createWidgets :: UiCtrl go ui => ui -> IO Widgets
createWidgets ui = do
box <- hBoxNew True 0
crButton <- radioButtonNewWithLabel "Cr"
slButton <- radioButtonNewWithLabelFromWidget crButton "Sl"
sqButton <- radioButtonNewWithLabelFromWidget crButton "Sq"
trButton <- radioButtonNewWithLabelFromWidget crButton "Tr"
xButton <- radioButtonNewWithLabelFromWidget crButton "X"
latch <- newLatch
forM_ [ (crButton, ToolMarkCircle)
, (slButton, ToolMarkSelected)
, (sqButton, ToolMarkSquare)
, (trButton, ToolMarkTriangle)
, (xButton, ToolMarkX)
] $ \(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
, myCircleButton = crButton
, mySelectedButton = slButton
, mySquareButton = sqButton
, myTriangleButton = trButton
, myXButton = xButton
, myViewUpdateLatch = latch
}
myRadioButton :: MarkTool ui -> RadioButton
myRadioButton me =
(case myMark me of
MarkCircle -> myCircleButton
MarkSelected -> mySelectedButton
MarkSquare -> mySquareButton
MarkTriangle -> myTriangleButton
MarkX -> myXButton) $ myWidgets me
setMarkToOppositeOf :: Mark -> CoordState -> CoordState -> CoordState
setMarkToOppositeOf mark baseCoord =
setMark $ case coordMark baseCoord of
Just mark' | mark' == mark -> Nothing
_ -> Just mark
setMark :: Maybe Mark -> CoordState -> CoordState
setMark maybeMark coord =
if coordMark coord == maybeMark
then coord
else coord { coordMark = maybeMark }