diff --git a/goatee-gtk.cabal b/goatee-gtk.cabal --- a/goatee-gtk.cabal +++ b/goatee-gtk.cabal @@ -1,10 +1,10 @@ name: goatee-gtk -version: 0.2.0 +version: 0.3.0 synopsis: A monadic take on a 2,500-year-old board game - GTK+ UI. category: Game license: AGPL-3 license-file: LICENSE -copyright: Copyright 2014 Bryan Gardiner +copyright: Copyright 2014-2015 Bryan Gardiner author: Bryan Gardiner maintainer: Bryan Gardiner homepage: http://khumba.net/projects/goatee @@ -34,11 +34,12 @@ directory >= 1.1 && < 1.3, filepath >= 1.3 && < 1.4, gtk >= 0.12 && < 0.13, - goatee >= 0.2 && < 0.3, + goatee >= 0.3 && < 0.4, mtl >= 2.1 && < 2.3, parsec >= 3.1 && < 3.2 exposed-modules: Game.Goatee.Ui.Gtk + Game.Goatee.Ui.Gtk.Common Game.Goatee.Ui.Gtk.Latch extensions: ExistentialQuantification @@ -53,13 +54,19 @@ hs-source-dirs: src other-modules: Game.Goatee.Ui.Gtk.Actions - Game.Goatee.Ui.Gtk.Common Game.Goatee.Ui.Gtk.GamePropertiesPanel Game.Goatee.Ui.Gtk.Goban Game.Goatee.Ui.Gtk.InfoLine Game.Goatee.Ui.Gtk.MainWindow Game.Goatee.Ui.Gtk.NodePropertiesPanel Game.Goatee.Ui.Gtk.PlayPanel + Game.Goatee.Ui.Gtk.Tool + Game.Goatee.Ui.Gtk.Tool.AssignStone + Game.Goatee.Ui.Gtk.Tool.Line + Game.Goatee.Ui.Gtk.Tool.Mark + Game.Goatee.Ui.Gtk.Tool.Null + Game.Goatee.Ui.Gtk.Tool.Play + Game.Goatee.Ui.Gtk.Tool.Visibility Game.Goatee.Ui.Gtk.Utils Game.Goatee.Ui.Gtk.Widget Paths_goatee_gtk @@ -69,7 +76,7 @@ base >= 4 && < 5, gtk >= 0.12 && < 0.13, goatee-gtk - ghc-options: -W -fwarn-incomplete-patterns + ghc-options: -W -fwarn-incomplete-patterns -fwarn-unused-do-bind hs-source-dirs: src-exe main-is: Main.hs @@ -78,10 +85,11 @@ base >= 4 && < 5, goatee-gtk, HUnit >= 1.2 && < 1.3 - ghc-options: -W -fwarn-incomplete-patterns + ghc-options: -W -fwarn-incomplete-patterns -fwarn-unused-do-bind hs-source-dirs: tests main-is: Test.hs other-modules: + Game.Goatee.Ui.Gtk.CommonTest Game.Goatee.Ui.Gtk.LatchTest Test type: exitcode-stdio-1.0 diff --git a/src/Game/Goatee/Ui/Gtk.hs b/src/Game/Goatee/Ui/Gtk.hs --- a/src/Game/Goatee/Ui/Gtk.hs +++ b/src/Game/Goatee/Ui/Gtk.hs @@ -1,6 +1,6 @@ -- This file is part of Goatee. -- --- Copyright 2014 Bryan Gardiner +-- Copyright 2014-2015 Bryan Gardiner -- -- Goatee is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by @@ -33,6 +33,7 @@ import qualified Data.Foldable as Foldable import Data.Foldable (foldl') import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef) +import Data.List (intercalate) import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) @@ -54,13 +55,14 @@ import Game.Goatee.Ui.Gtk.Common import qualified Game.Goatee.Ui.Gtk.MainWindow as MainWindow import Game.Goatee.Ui.Gtk.MainWindow (MainWindow) +import Game.Goatee.Ui.Gtk.Tool import Graphics.UI.Gtk ( AttrOp ((:=)), ButtonsType (ButtonsNone, ButtonsOk, ButtonsYesNo), Clipboard, DialogFlags (DialogDestroyWithParent, DialogModal), FileChooserAction (FileChooserActionOpen, FileChooserActionSave), - MessageType (MessageError, MessageQuestion), + MessageType (MessageError, MessageInfo, MessageQuestion), ResponseId (ResponseCancel, ResponseNo, ResponseOk, ResponseYes), aboutDialogAuthors, aboutDialogCopyright, aboutDialogLicense, aboutDialogNew, aboutDialogProgramName, aboutDialogWebsite, @@ -68,7 +70,7 @@ dialogAddButton, dialogRun, fileChooserAddFilter, fileChooserDialogNew, fileChooserGetFilename, mainQuit, - messageDialogNew, + messageDialogNew, messageDialogNewWithMarkup, selectionClipboard, stockCancel, stockOpen, stockSave, stockSaveAs, widgetDestroy, widgetHide, @@ -147,6 +149,7 @@ , uiAppState :: AppState , uiDirty :: IORef Bool , uiFilePath :: IORef (Maybe FilePath) + , uiTools :: IORef (Map ToolType (AnyTool go (UiCtrlImpl go))) , uiModes :: IORef UiModes , uiCursor :: MVar Cursor @@ -176,8 +179,28 @@ newModes <- f oldModes when (newModes /= oldModes) $ do writeIORef (uiModes ui) newModes + let oldToolType = uiToolType oldModes + newToolType = uiToolType newModes + toolChanged = newToolType /= oldToolType + -- If the tool has changed, then follow the order: + -- 1) Tell the new tool that it is about to become active, so that it can + -- update the state of its widgets if necessary. + -- 2) Fire modes changed handlers (causing the old tool's widget to hide + -- and the new tool's widget, now up-to-date, to become visible). + -- 3) Tell the old tool that is was deactivated. + when toolChanged $ do + AnyTool newTool <- findTool ui newToolType + toolOnActivating newTool fireModesChangedHandlers ui oldModes newModes + when toolChanged $ do + AnyTool oldTool <- findTool ui oldToolType + toolOnDeactivated oldTool + findTool ui toolType = + fromMaybe (error $ "UiCtrlImpl.findTool: Couldn't find " ++ show toolType ++ ".") . + Map.lookup toolType <$> + readIORef (uiTools ui) + doUiGo ui go = do cursor <- takeMVar (uiCursor ui) doUiGo' ui go cursor @@ -205,43 +228,16 @@ dialogRun dialog widgetDestroy dialog else case cursorChildPlayingAt move cursor of - Just child -> doUiGo' ui (Monad.goDown $ cursorChildIndex child) cursor - Nothing -> + Just child -> do + ok <- doUiGo' ui (Monad.goDown $ cursorChildIndex child) cursor + unless ok $ fail "UiCtrlImpl.playAt: Failed to move to existing child." + Nothing -> do let board = cursorBoard cursor player = boardPlayerTurn board index = length $ cursorChildren cursor child = emptyNode { nodeProperties = [moveToProperty player move] } - in doUiGo' ui (Monad.addChildAt index child >> Monad.goDown index) cursor - - goUp ui = doUiGo ui $ do - cursor <- Monad.getCursor - if isNothing $ cursorParent cursor - then return False - else Monad.goUp >> return True - - goDown ui index = doUiGo ui $ do - cursor <- Monad.getCursor - if null $ drop index $ cursorChildren cursor - then return False - else Monad.goDown index >> return True - - goLeft ui = doUiGo ui $ do - cursor <- Monad.getCursor - case (cursorParent cursor, cursorChildIndex cursor) of - (Nothing, _) -> return False - (Just _, 0) -> return False - (Just _, n) -> do Monad.goUp - Monad.goDown $ n - 1 - return True - - goRight ui = doUiGo ui $ do - cursor <- Monad.getCursor - case (cursorParent cursor, cursorChildIndex cursor) of - (Nothing, _) -> return False - (Just parent, n) | n == cursorChildCount parent - 1 -> return False - (Just _, n) -> do Monad.goUp - Monad.goDown $ n + 1 - return True + ok <- doUiGo' ui (Monad.addChildAt index child >> Monad.goDown index) cursor + unless ok $ fail "UiCtrlImpl.playAt: Failed to move to new child." register view events = do let ui = viewCtrl view @@ -341,6 +337,7 @@ appState <- maybe newAppState (return . uiAppState) maybeUi dirty <- newIORef False filePath <- newIORef maybePath + toolsRef <- newIORef Map.empty modesVar <- newIORef defaultUiModes cursorVar <- newMVar $ rootCursor rootNode mainWindowRef <- newIORef Nothing @@ -356,6 +353,7 @@ , uiAppState = appState , uiDirty = dirty , uiFilePath = filePath + , uiTools = toolsRef , uiModes = modesVar , uiCursor = cursorVar , uiMainWindow = mainWindowRef @@ -371,6 +369,9 @@ appStateRegister appState ui rebuildGoRegistrationsAction ui + createTools ui >>= writeIORef toolsRef + readTool ui >>= \(AnyTool tool) -> toolOnActivating tool + mainWindow <- MainWindow.create ui writeIORef mainWindowRef $ Just mainWindow MainWindow.display mainWindow @@ -459,6 +460,21 @@ fileCloseSilently ui = do MainWindow.destroy =<< getMainWindow' ui + fmap Map.elems (readIORef $ uiTools ui) >>= mapM_ (\(AnyTool tool) -> toolDestroy tool) + writeIORef (uiTools ui) Map.empty + + -- There should be no more handlers registered now. + let assertNoHandlers label handlers = + unless (null handlers) $ hPutStrLn stderr $ + "UiCtrlImpl.fileCloseSilently: Warning, there are still" ++ + maybe "" (' ':) label ++ + " handler(s) registered:" ++ + concatMap (\handler -> "\n- " ++ show handler) handlers + registeredHandlers ui >>= assertNoHandlers Nothing + registeredDirtyChangedHandlers ui >>= assertNoHandlers (Just "dirty changed") + registeredFilePathChangedHandlers ui >>= assertNoHandlers (Just "file path changed") + registeredModesChangedHandlers ui >>= assertNoHandlers (Just "modes changed") + appStateUnregister (uiAppState ui) ui fileQuit ui = do @@ -503,6 +519,30 @@ dialogRun dialog widgetDestroy dialog Right node -> doUiGo ui $ Monad.addChild node + + helpKeyBindings ui = do + let message = + intercalate "\n" + [ "Pressing Esc focuses the board. When the board is focused, the following " ++ + "keys are available:" + , "" + , "Left: Go up the tree one step." + , "Right: Go down the tree one step." + , "Up: Go to the previous variation." + , "Down: Go to the next variation." + , "Home: Go to the start of the game." + , "End: Go to the end of the current variation." + , "Page Up: Go up the tree 10 steps." + , "Page Down: Go down the tree 10 steps." + ] + mainWindow <- getMainWindow ui + dialog <- messageDialogNewWithMarkup (Just mainWindow) + [DialogModal, DialogDestroyWithParent] + MessageInfo + ButtonsOk + message + dialogRun dialog + widgetDestroy dialog helpAbout _ = do about <- aboutDialogNew diff --git a/src/Game/Goatee/Ui/Gtk/Actions.hs b/src/Game/Goatee/Ui/Gtk/Actions.hs --- a/src/Game/Goatee/Ui/Gtk/Actions.hs +++ b/src/Game/Goatee/Ui/Gtk/Actions.hs @@ -1,6 +1,6 @@ -- This file is part of Goatee. -- --- Copyright 2014 Bryan Gardiner +-- Copyright 2014-2015 Bryan Gardiner -- -- Goatee is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by @@ -42,12 +42,15 @@ myViewStonesRegularModeAction, myViewStonesOneColorModeAction, myViewStonesBlindModeAction, + myHelpKeyBindingsAction, myHelpAboutAction, ) where import Control.Applicative ((<$>)) -import Control.Monad (unless, void, when) -import Data.Maybe (fromMaybe, isJust) +import Control.Monad (forM, unless, void, when) +import qualified Data.Foldable as F +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Maybe (catMaybes, fromMaybe, isJust) import Game.Goatee.Ui.Gtk.Common import Game.Goatee.Ui.Gtk.Utils import Game.Goatee.Lib.Board @@ -68,9 +71,11 @@ ResponseId (ResponseCancel, ResponseOk), SpinButtonUpdatePolicy (UpdateIfValid), ToggleAction, - actionActivate, actionActivated, actionGroupAddActionWithAccel, actionGroupAddRadioActions, - actionGroupGetAction, actionGroupNew, actionNew, actionSensitive, actionToggled, + actionActivate, actionActivated, actionGroupAddAction, actionGroupAddRadioActions, + actionGroupGetAction, actionGroupListActions, actionGroupNew, actionNew, actionSensitive, + actionToggled, boxPackStart, + castToRadioAction, dialogAddButton, dialogGetUpper, dialogNew, dialogRun, dialogSetDefaultResponse, get, labelNewWithMnemonic, labelSetMnemonicWidget, @@ -107,11 +112,15 @@ , myGameVariationsBoardMarkupOnAction :: RadioAction , myGameVariationsBoardMarkupOffAction :: RadioAction , myToolActions :: ActionGroup + , mySomeToolAction :: RadioAction + -- ^ An arbitrary action in the 'myToolActions' group. , myViewHighlightCurrentMovesAction :: ToggleAction , myViewStonesRegularModeAction :: RadioAction , myViewStonesOneColorModeAction :: RadioAction , myViewStonesBlindModeAction :: RadioAction + , myHelpKeyBindingsAction :: Action , myHelpAboutAction :: Action + , myModesChangedHandler :: IORef (Maybe Registration) } instance UiCtrl go ui => UiView go ui (Actions ui) where @@ -122,26 +131,26 @@ create :: UiCtrl go ui => ui -> IO (Actions ui) create ui = do - let tools = enumFrom minBound + let toolTypes = enumFrom minBound modes <- readModes ui -- File actions. fileActions <- actionGroupNew "File" fileNew9Action <- actionNew "FileNew9" "New _9x9 board" Nothing Nothing - actionGroupAddActionWithAccel fileActions fileNew9Action Nothing + actionGroupAddAction fileActions fileNew9Action on fileNew9Action actionActivated $ void $ openNewBoard (Just ui) (Just (9, 9)) fileNew13Action <- actionNew "FileNew13" "New 1_3x13 board" Nothing Nothing - actionGroupAddActionWithAccel fileActions fileNew13Action Nothing + actionGroupAddAction fileActions fileNew13Action on fileNew13Action actionActivated $ void $ openNewBoard (Just ui) (Just (13, 13)) fileNew19Action <- actionNew "FileNew19" "New _19x19 board" Nothing Nothing - actionGroupAddActionWithAccel fileActions fileNew19Action $ Just "n" + actionGroupAddAction fileActions fileNew19Action on fileNew19Action actionActivated $ void $ openNewBoard (Just ui) (Just (19, 19)) fileNewCustomAction <- actionNew "FileNewCustom" "New _custom board..." Nothing Nothing - actionGroupAddActionWithAccel fileActions fileNewCustomAction Nothing + actionGroupAddAction fileActions fileNewCustomAction on fileNewCustomAction actionActivated $ do dialog <- dialogNew windowSetTitle dialog "New custom board" @@ -225,23 +234,23 @@ setDirty ui' False fileOpenAction <- actionNew "FileOpen" "_Open file..." Nothing Nothing - actionGroupAddActionWithAccel fileActions fileOpenAction $ Just "o" + actionGroupAddAction fileActions fileOpenAction on fileOpenAction actionActivated $ fileOpen ui fileSaveAction <- actionNew "FileSave" "_Save file" Nothing Nothing - actionGroupAddActionWithAccel fileActions fileSaveAction $ Just "s" + actionGroupAddAction fileActions fileSaveAction on fileSaveAction actionActivated $ void $ fileSave ui fileSaveAsAction <- actionNew "FileSaveAs" "Sa_ve file as..." Nothing Nothing - actionGroupAddActionWithAccel fileActions fileSaveAsAction $ Just "s" + actionGroupAddAction fileActions fileSaveAsAction on fileSaveAsAction actionActivated $ void $ fileSaveAs ui fileCloseAction <- actionNew "FileClose" "_Close" Nothing Nothing - actionGroupAddActionWithAccel fileActions fileCloseAction $ Just "w" + actionGroupAddAction fileActions fileCloseAction on fileCloseAction actionActivated $ void $ fileClose ui fileQuitAction <- actionNew "FileQuit" "_Quit" Nothing Nothing - actionGroupAddActionWithAccel fileActions fileQuitAction $ Just "q" + actionGroupAddAction fileActions fileQuitAction on fileQuitAction actionActivated $ void $ fileQuit ui -- Edit actions. @@ -302,17 +311,21 @@ -- Tool actions. toolActions <- actionGroupNew "Tools" - actionGroupAddRadioActions toolActions - (flip map tools $ \tool -> - RadioActionEntry { radioActionName = show tool - , radioActionLabel = toolLabel tool - , radioActionStockId = Nothing - , radioActionAccelerator = Nothing - , radioActionTooltip = Nothing - , radioActionValue = fromEnum tool - }) - (fromEnum initialTool) + toolActionList <- fmap catMaybes $ forM toolTypes $ \toolType -> do + AnyTool tool <- findTool ui toolType + return $ Just RadioActionEntry + { radioActionName = show toolType + , radioActionLabel = toolLabel tool + , radioActionStockId = Nothing + , radioActionAccelerator = Nothing + , radioActionTooltip = Nothing + , radioActionValue = fromEnum toolType + } + actionGroupAddRadioActions toolActions toolActionList (fromEnum initialToolType) (\radioAction -> setTool ui =<< fmap toEnum (get radioAction radioActionCurrentValue)) + someToolAction <- actionGroupListActions toolActions >>= \actions -> case actions of + someAction:_ -> return $ castToRadioAction someAction + _ -> error "Actions.initialize: Couldn't grab a tool action!?" -- View actions. viewHighlightCurrentMovesAction <- @@ -351,14 +364,18 @@ modifyModes ui $ \modes -> return modes { uiViewStonesMode = value } -- Help actions. + helpKeyBindingsAction <- actionNew "HelpKeyBindings" "_Key bindings" Nothing Nothing + on helpKeyBindingsAction actionActivated $ helpKeyBindings ui + helpAboutAction <- actionNew "HelpAbout" "_About" Nothing Nothing on helpAboutAction actionActivated $ helpAbout ui actionActivate =<< - fmap (fromMaybe $ error $ "Could not find the initial tool " ++ show initialTool ++ ".") - (actionGroupGetAction toolActions $ show initialTool) + fmap (fromMaybe $ error $ "Could not find the initial tool " ++ show initialToolType ++ ".") + (actionGroupGetAction toolActions $ show initialToolType) state <- viewStateNew + modesChangedHandler <- newIORef Nothing let me = Actions { myUi = ui @@ -381,25 +398,34 @@ , myGameVariationsBoardMarkupOnAction = gameVariationsBoardMarkupOnAction , myGameVariationsBoardMarkupOffAction = gameVariationsBoardMarkupOffAction , myToolActions = toolActions + , mySomeToolAction = someToolAction , myViewHighlightCurrentMovesAction = viewHighlightCurrentMovesAction , myViewStonesRegularModeAction = viewStonesRegularModeAction , myViewStonesOneColorModeAction = viewStonesOneColorModeAction , myViewStonesBlindModeAction = viewStonesBlindModeAction + , myHelpKeyBindingsAction = helpKeyBindingsAction , myHelpAboutAction = helpAboutAction + , myModesChangedHandler = modesChangedHandler } initialize me return me initialize :: UiCtrl go ui => Actions ui -> IO () -initialize me = +initialize me = do + let ui = myUi me register me [ AnyEvent navigationEvent , AnyEvent variationModeChangedEvent ] + writeIORef (myModesChangedHandler me) =<< + fmap Just (registerModesChangedHandler ui "Actions" $ \_ _ -> update me) destroy :: UiCtrl go ui => Actions ui -> IO () -destroy = viewDestroy +destroy me = do + let ui = myUi me + F.mapM_ (unregisterModesChangedHandler ui) =<< readIORef (myModesChangedHandler me) + viewDestroy me update :: UiCtrl go ui => Actions ui -> IO () update me = do @@ -409,6 +435,7 @@ set (myEditCutNodeAction me) [actionSensitive := isJust $ cursorParent cursor] updateVariationModeActions me cursor + updateToolActions me -- | Updates the selection variation mode radio actions. updateVariationModeActions :: Actions ui -> Cursor -> IO () @@ -427,3 +454,10 @@ oldBoardMarkup <- get boardMarkupAction radioActionCurrentValue when (newBoardMarkup /= oldBoardMarkup) $ set boardMarkupAction [radioActionCurrentValue := newBoardMarkup] + +-- | Updates the active tool radio action. +updateToolActions :: UiCtrl go ui => Actions ui -> IO () +updateToolActions me = do + let ui = myUi me + tool <- uiToolType <$> readModes ui + set (mySomeToolAction me) [radioActionCurrentValue := fromEnum tool] diff --git a/src/Game/Goatee/Ui/Gtk/Common.hs b/src/Game/Goatee/Ui/Gtk/Common.hs --- a/src/Game/Goatee/Ui/Gtk/Common.hs +++ b/src/Game/Goatee/Ui/Gtk/Common.hs @@ -1,6 +1,6 @@ -- This file is part of Goatee. -- --- Copyright 2014 Bryan Gardiner +-- Copyright 2014-2015 Bryan Gardiner -- -- Goatee is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by @@ -41,16 +41,23 @@ UiModes (..), ViewStonesMode (..), defaultUiModes, - Tool (..), - initialTool, + -- * Tools + ToolType (..), UiTool (..), AnyTool (..), toolDestroy, toolType, toolLabel, + ToolState, toolStateNew, toolStateType, toolStateLabel, + ToolGobanState (..), toolGetGobanState, toolGobanStateStartCoord, toolGobanStateCurrentCoord, + GobanEvent (..), + RenderedCoord (..), + initialToolType, toolOrdering, - toolLabel, - toolIsImplemented, toolToColor, + -- * Miscellaneous fileFiltersForSgf, + coordRange, + toggle, ) where -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<*>), pure) +import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef) import qualified Data.Set as Set import Data.Set (Set) import Data.Unique (Unique, newUnique) @@ -59,7 +66,18 @@ import Game.Goatee.Lib.Parser import Game.Goatee.Lib.Tree import Game.Goatee.Lib.Types -import Graphics.UI.Gtk (FileFilter, Window, fileFilterAddPattern, fileFilterNew, fileFilterSetName) +import Graphics.UI.Gtk ( + ButtonsType (ButtonsOk), + FileFilter, + MessageType (MessageWarning), + MouseButton, + Widget, + Window, + dialogRun, + fileFilterAddPattern, fileFilterNew, fileFilterSetName, + messageDialogNew, + widgetDestroy, + ) import System.FilePath (takeFileName) -- | A class for monads that provide the features required to be used with a @@ -122,6 +140,13 @@ -- a mode change event via 'fireViewModesChanged'. modifyModes :: ui -> (UiModes -> IO UiModes) -> IO () + -- | Looks up the tool bound to a 'ToolType'. + findTool :: ui -> ToolType -> IO (AnyTool go ui) + + -- | Reads the active tool. + readTool :: ui -> IO (AnyTool go ui) + readTool ui = findTool ui . uiToolType =<< readModes ui + -- | Runs a Go monad on the current cursor, updating the cursor and firing -- handlers as necessary. doUiGo :: ui -> go a -> IO a @@ -136,26 +161,6 @@ -- case of 'Nothing'. playAt :: ui -> Maybe Coord -> IO () - -- | If possible, takes a step up to the parent of the current node in the - -- game tree. Returns whether a move was made (i.e. whether the current node - -- is not the root node). - goUp :: ui -> IO Bool - - -- | If possible, takes a step down from the current node to its child at the - -- given index. Returns whether a move was made (i.e. whether the node had - -- @n+1@ children). - goDown :: ui -> Int -> IO Bool - - -- | If possible, move to the sibling node immediately to the left of the - -- current one. Returns whether a move was made (i.e. whether there was a - -- left sibling). - goLeft :: ui -> IO Bool - - -- | If possible, move to the sibling node immediately to the right of the - -- current one. Returns whether a move was made (i.e. whether there was a - -- right sibling). - goRight :: ui -> IO Bool - -- | Registers a view to update when any of the given 'Event's fires. The -- controller will call 'viewUpdate' after the Go action finishes running. -- @@ -210,8 +215,21 @@ result <- parseFile file case result of -- TODO Don't only choose the first tree in the collection. - Right collection -> - fmap Right $ openBoard ui (Just file) $ head $ collectionTrees collection + Right collection -> case collectionTrees collection of + [root] -> Right <$> openBoard ui (Just file) root + root0:_:_ -> do + dialog <- messageDialogNew Nothing [] + MessageWarning + ButtonsOk + ("The file " ++ file ++ " contains multiple game trees. Goatee only " ++ + "supports single-tree collections at this time. Only the first tree " ++ + "will be presented, and saving the game will write a file containing " ++ + "only the first tree.\n\n" ++ + "Saving the game will not overwrite the existing file by default.") + dialogRun dialog + widgetDestroy dialog + Right <$> openBoard ui Nothing root0 + [] -> return $ Left "Invalid game file, it contains no game trees." Left err -> return $ Left err -- | Prompts with an open file dialog for a game to open, then opens the @@ -259,6 +277,9 @@ -- insert the parsed node below the current node. editPasteNode :: ui -> IO () + -- | Presents the user with a dialog that shows the UI's key bindings. + helpKeyBindings :: ui -> IO () + -- | Presents the user with an about dialog that shows general information -- about the application to the user (authorship, license, etc.). helpAbout :: ui -> IO () @@ -350,8 +371,8 @@ -- | Assigns to the current tool within the modes of 'ui' (firing any relevant -- change handlers). -setTool :: UiCtrl go ui => ui -> Tool -> IO () -setTool ui tool = modifyModesPure ui $ \modes -> modes { uiTool = tool } +setTool :: UiCtrl go ui => ui -> ToolType -> IO () +setTool ui toolType = modifyModesPure ui $ \modes -> modes { uiToolType = toolType } -- | A UI widget that listens to the state of a 'UiCtrl'. This class makes it -- easy to ask to be updated on relevant changes with 'register'. @@ -412,7 +433,7 @@ , uiHighlightCurrentMovesMode :: Bool -- ^ Whether to draw an indicator on the game board for moves on the current -- node. - , uiTool :: Tool + , uiToolType :: ToolType } deriving (Eq, Show) data ViewStonesMode = @@ -426,85 +447,249 @@ { uiViewStonesMode = ViewStonesRegularMode , uiViewStonesOneColorModeColor = Black , uiHighlightCurrentMovesMode = True - , uiTool = ToolPlay + , uiToolType = initialToolType } --- | Selectable tools for operating on the board. -data Tool = +-- | Selectable tools for operating on the board. See 'UiTool'. +data ToolType = ToolPlay -- ^ Game tool. | ToolJump -- ^ Game tool. | ToolScore -- ^ Game tool. - | ToolBlack -- ^ Editing tool. - | ToolWhite -- ^ Editing tool. - | ToolErase -- ^ Editing tool. - | ToolArrow -- ^ Markup tool. + | ToolAssignBlack -- ^ Editing tool. + | ToolAssignWhite -- ^ Editing tool. + | ToolAssignEmpty -- ^ Editing tool. | ToolMarkCircle -- ^ Markup tool. - | ToolLabel -- ^ Markup tool. - | ToolLine -- ^ Markup tool. - | ToolMarkX -- ^ Markup tool. | ToolMarkSelected -- ^ Markup tool. | ToolMarkSquare -- ^ Markup tool. | ToolMarkTriangle -- ^ Markup tool. + | ToolMarkX -- ^ Markup tool. + | ToolArrow -- ^ Markup tool. + | ToolLine -- ^ Markup tool. + | ToolLabel -- ^ Markup tool. | ToolVisible -- ^ Visibility tool. | ToolDim -- ^ Visibility tool. - deriving (Bounded, Enum, Eq, Show) + deriving (Bounded, Enum, Eq, Ord, Show) +-- | A tool is a mode of interaction between the user and the board, that +-- determines what actions the user can perform to the game. A tool interacts +-- with the goban and controls how mouse events are responded to. A tool can +-- also provide a widget (or container of widgets) that will be inserted into +-- the side panel while the tool is active. +-- +-- The 'ToolType' enum contains an entry for each tool. This 'UiTool' class is +-- used to define the implementation of a tool. A 'UiCtrl' manages tools, and +-- maps 'ToolType's to 'UiTool's. These can be accessed with 'findTool' and +-- 'readTool'. +-- +-- The goban sends events to the active tool as they occur, via +-- 'toolGobanHandleEvent'. The tool can then affect what the goban displays by +-- overriding 'toolGobanRenderGetBoard' and/or 'toolGobanRenderModifyCoords'. +class UiView go ui tool => UiTool go ui tool where + -- | Internal housekeeping data for the tool. Create with 'toolStateNew'. A + -- 'ToolState' may only be used with a single tool. + toolState :: tool -> ToolState + + -- | By default, this returns true. An implementation can override this to + -- return false if the implementation is a stub and the tool should not be + -- visible in the UI. + -- + -- TODO Remove this once all tools are implemented. + toolIsImplemented :: tool -> Bool + toolIsImplemented _ = True + + -- | A tool can provide a widget (or container of widgets) to display in the + -- side panel by returning it from this function. + toolPanelWidget :: tool -> Maybe Widget + toolPanelWidget _ = Nothing + + -- | A handler that is called when the tool is being destroyed as part of UI + -- shutdown. The default handler does nothing. This does not need to call + -- 'viewDestroy', which is already called after this handler. + toolOnDestroy :: tool -> IO () + toolOnDestroy _ = return () + + -- | A handler that is called when the user activates the tool. Runs before + -- the tool becomes active and before the tool's widgets are displayed. The + -- default implementation just calls 'toolGobanInvalidate'. + toolOnActivating :: tool -> IO () + toolOnActivating = toolGobanInvalidate + + -- | A handler that is called after the user deactivates the tool. The + -- default implementation does nothing. + toolOnDeactivated :: tool -> IO () + toolOnDeactivated _ = return () + + -- | Called by the goban when an event occurs. Override this to implement + -- custom event handling. The default implementation does basic click and + -- drag tracking for a single mouse button, and calls 'toolGobanClickComplete' + -- when a click/drag completes. + -- + -- Returning true causes the goban to redraw. + -- + -- The tool can also query the state of the mouse with 'toolGetGobanState'. + toolGobanHandleEvent :: tool -> GobanEvent -> IO Bool + toolGobanHandleEvent = toolGobanHandleEventDefault + + -- | The default 'toolGobanHandleEvent' calls this when a click or drag that + -- started on the goban completes. The two coordinates are the board points + -- at which the click started and ended, or nothing if the mouse was not over + -- a board point. + toolGobanClickComplete :: tool -> Maybe Coord -> Maybe Coord -> IO () + toolGobanClickComplete _ _ _ = return () + + -- | The default 'toolGobanHandleEvent' calls this when the tool should + -- invalidate its state because something has changed via e.g. a navigation + -- event, properties modified event, or modes changed event. + toolGobanInvalidate :: tool -> IO () + toolGobanInvalidate _ = return () + + -- | When rendering, the goban calls this function to let the active tool + -- extract a 'BoardState' from a 'Cursor' for rendering. The tool is free to + -- modify the cursor before returning a state. + toolGobanRenderGetBoard :: tool -> Cursor -> IO BoardState + toolGobanRenderGetBoard _ = return . cursorBoard + + -- | When rendering, the goban calls this function to let the active tool + -- modify the final 'RenderedCoord's before they are drawn. + toolGobanRenderModifyCoords :: tool -> BoardState -> [[RenderedCoord]] -> IO [[RenderedCoord]] + toolGobanRenderModifyCoords _ _ = return + +-- | An existential type for any tool under a specific UI controller. +data AnyTool go ui = forall tool. UiTool go ui tool => AnyTool tool + +-- | Performs tool-specific clean-up during 'UiCtrl' shutdown. +toolDestroy :: UiTool go ui tool => tool -> IO () +toolDestroy tool = do + toolOnDestroy tool + viewDestroy tool + +-- | Returns the 'ToolType' that a 'UiCtrl' was instantiated for. +toolType :: UiTool go ui tool => tool -> ToolType +toolType = toolStateType . toolState + +-- | Returns the UI text that names a tool. +toolLabel :: UiTool go ui tool => tool -> String +toolLabel = toolStateLabel . toolState + +-- | See 'toolGobanHandleEvent'. +toolGobanHandleEventDefault :: UiTool go ui tool => tool -> GobanEvent -> IO Bool +toolGobanHandleEventDefault me event = + let gobanStateRef = toolGobanStateRef $ toolState me + in case event of + GobanMouseMove coord -> do + state <- readIORef gobanStateRef + if coord /= toolGobanStateCurrentCoord state + then do writeIORef gobanStateRef $ toolGobanStateModify (const coord) state + return True + else return False + GobanClickStart button start -> do + writeIORef gobanStateRef $ ToolGobanDragging button start start + return True + GobanClickFinish button end -> do + state <- readIORef gobanStateRef + case state of + ToolGobanDragging button0 start _ | button == button0 -> do + writeIORef gobanStateRef $ ToolGobanHovering end + toolGobanClickComplete me start end + _ -> return () + return True + GobanInvalidate -> do + modifyIORef gobanStateRef $ \state -> case state of + ToolGobanHovering _ -> state + ToolGobanDragging _ _ current -> ToolGobanHovering current + toolGobanInvalidate me + return True + +-- | Internal state of a 'UiTool'. +data ToolState = ToolState + { toolStateType :: ToolType + , toolStateLabel :: String + , toolGobanStateRef :: IORef ToolGobanState + } + +-- | Creates a new 'ToolState' for a tool instiantiated for the given 'ToolType' +-- and with the given UI label. +toolStateNew :: ToolType -> String -> IO ToolState +toolStateNew toolType label = + ToolState <$> pure toolType <*> pure label <*> newIORef (ToolGobanHovering Nothing) + +-- | The state of the mouse with respect to the goban. +data ToolGobanState = + ToolGobanHovering (Maybe Coord) + -- ^ There is no click in process. The mouse is over the point on the board, + -- if present. + | ToolGobanDragging MouseButton (Maybe Coord) (Maybe Coord) + -- ^ There is a click in progress. The given button was pressed down, over + -- the first board point if present, and is currently over the second board + -- point if present, or elsewhere if absent. + +-- | __When 'toolGobanHandleEvent' is the default implementation,__ this method +-- returns the current state of the mouse with respect to the goban. +toolGetGobanState :: UiTool go ui tool => tool -> IO ToolGobanState +toolGetGobanState = readIORef . toolGobanStateRef . toolState + +-- | Returns the board point where an in-progress drag started, or the current +-- board point if there is no drag. +toolGobanStateStartCoord :: ToolGobanState -> Maybe Coord +toolGobanStateStartCoord state = case state of + ToolGobanHovering coord -> coord + ToolGobanDragging _ coord _ -> coord + +-- | Returns the board point that the mouse is over, according to a +-- 'ToolGobanState'. +toolGobanStateCurrentCoord :: ToolGobanState -> Maybe Coord +toolGobanStateCurrentCoord state = case state of + ToolGobanHovering coord -> coord + ToolGobanDragging _ _ coord -> coord + +-- | Modifies the board point that a 'ToolGobanState' says the mouse is over. +toolGobanStateModify :: (Maybe Coord -> Maybe Coord) -> ToolGobanState -> ToolGobanState +toolGobanStateModify f state = case state of + ToolGobanHovering coord -> ToolGobanHovering $ f coord + ToolGobanDragging button start current -> ToolGobanDragging button start $ f current + +-- | Event notifications that can be sent from the goban to a tool. +data GobanEvent = + GobanMouseMove (Maybe Coord) + -- ^ The mouse was moved over the goban. The 'Coord' is the current mouse + -- location, or nothing if the mouse is not currently over a board point. + | GobanClickStart MouseButton (Maybe Coord) + -- ^ A mouse button was pressed down, over the given board point if present. + | GobanClickFinish MouseButton (Maybe Coord) + -- ^ A mouse button was released, over the given point if present. + | GobanInvalidate + -- ^ The tool should invalidate cached state, abandon any existing drag, and + -- read the cursor and modes from the 'UiCtrl' anew, because something + -- changed (examples: game navigation, game modification, modes change). + +-- | Augments a 'CoordState' with data that is used for rendering purposes. +data RenderedCoord = RenderedCoord + { renderedCoordState :: CoordState + , renderedCoordCurrent :: Bool + -- ^ True if the point had a stone played on it in the current node. + , renderedCoordVariation :: Maybe Color + -- ^ If a variation move exists at this point, then this will be the color + -- of the move. + } deriving (Show) + -- | The tool that should be selected when a board first opens in the UI. -initialTool :: Tool -initialTool = ToolPlay +initialToolType :: ToolType +initialToolType = ToolPlay -- | The ordering and grouping of tools as they should appear in the UI. -toolOrdering :: [[Tool]] +toolOrdering :: [[ToolType]] toolOrdering = [[ToolPlay, ToolJump, ToolScore], - [ToolBlack, ToolWhite, ToolErase], - [ToolArrow, ToolMarkCircle, ToolLabel, ToolLine, ToolMarkX, ToolMarkSelected, - ToolMarkSquare, ToolMarkTriangle], + [ToolAssignBlack, ToolAssignWhite, ToolAssignEmpty], + [ToolMarkCircle, ToolMarkSelected, ToolMarkSquare, ToolMarkTriangle, ToolMarkX, + ToolArrow, ToolLine, ToolLabel], [ToolVisible, ToolDim]] -toolLabel :: Tool -> String -toolLabel tool = case tool of - ToolPlay -> "Play" - ToolJump -> "Jump to move" - ToolScore -> "Score" - ToolBlack -> "Paint black stones" - ToolWhite -> "Paint white stones" - ToolErase -> "Erase stones" - ToolArrow -> "Draw arrows" - ToolMarkCircle -> "Mark circles" - ToolLabel -> "Label points" - ToolLine -> "Draw lines" - ToolMarkX -> "Mark Xs" - ToolMarkSelected -> "Mark selected" - ToolMarkSquare -> "Mark squares" - ToolMarkTriangle -> "Mark triangles" - ToolVisible -> "Toggle points visible" - ToolDim -> "Toggle points dimmed" - --- | Returns true if the tool is implemented and should be available in the UI, --- and false if the tool is not implemented and should not be offered to the --- user. --- --- Eventually, this function should be removed. -toolIsImplemented :: Tool -> Bool -toolIsImplemented tool = case tool of - ToolJump -> False - ToolScore -> False - ToolBlack -> False - ToolWhite -> False - ToolErase -> False - ToolArrow -> False - ToolLabel -> False - ToolLine -> False - ToolVisible -> False - ToolDim -> False - _ -> True - --- | Converts 'ToolBlack' and 'ToolWhite' into 'Color's. Does not accept any --- other tools. -toolToColor :: Tool -> Color -toolToColor ToolBlack = Black -toolToColor ToolWhite = White +-- | Converts 'ToolAssignBlack' and 'ToolAssignWhite' into 'Color's. Does not +-- accept any other tools. +toolToColor :: ToolType -> Color +toolToColor ToolAssignBlack = Black +toolToColor ToolAssignWhite = White toolToColor other = error $ "toolToColor is invalid for " ++ show other ++ "." -- | Creates a list of 'FileFilter's that should be used in 'FileChooser's that @@ -523,3 +708,17 @@ -- disk. untitledFileName :: String untitledFileName = "(Untitled)" + +-- | @coordRange coord0 coord1@ returns a list of all the coordinates in the +-- rectangle with @coord0@ and @coord1@ as opposite corners. +coordRange :: Coord -> Coord -> [Coord] +coordRange (x0, y0) (x1, y1) = + [(x, y) | x <- [min x0 x1 .. max x0 x1] + , y <- [min y0 y1 .. max y0 y1]] + +-- | @toggle value@ toggles @value@ in a 'Maybe', returning 'Nothing' if the +-- maybe already holds the value, and @'Just' value@ otherwise. +toggle :: Eq a => a -> Maybe a -> Maybe a +toggle target maybeValue = case maybeValue of + Just value | value == target -> Nothing + _ -> Just target diff --git a/src/Game/Goatee/Ui/Gtk/Goban.hs b/src/Game/Goatee/Ui/Gtk/Goban.hs --- a/src/Game/Goatee/Ui/Gtk/Goban.hs +++ b/src/Game/Goatee/Ui/Gtk/Goban.hs @@ -1,6 +1,6 @@ -- This file is part of Goatee. -- --- Copyright 2014 Bryan Gardiner +-- Copyright 2014-2015 Bryan Gardiner -- -- Goatee is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by @@ -24,17 +24,25 @@ ) where import Control.Applicative ((<$>)) -import Control.Monad ((<=<), liftM, unless, when) +import Control.Monad ((<=<), liftM, unless, void, when) import qualified Data.Foldable as F import Data.IORef (IORef, newIORef, readIORef, writeIORef) import qualified Data.Map as Map import Data.Map (Map) -import Data.Maybe (fromJust, fromMaybe, isJust) +import Data.Maybe (fromJust, isJust) import Data.Tree (drawTree, unfoldTree) import Game.Goatee.Common import Game.Goatee.Lib.Board hiding (isValidMove) import Game.Goatee.Lib.Monad ( - AnyEvent (..), childAddedEvent, childDeletedEvent, modifyMark, navigationEvent, + AnyEvent (..), + childAddedEvent, + childDeletedEvent, + goDown, + goLeft, + goRight, + goToRoot, + goUp, + navigationEvent, propertiesModifiedEvent, ) import Game.Goatee.Lib.Property @@ -72,11 +80,11 @@ DrawingArea, EventMask (ButtonPressMask, LeaveNotifyMask, PointerMotionMask), Modifier (Shift), + MouseButton, Widget, - buttonPressEvent, + buttonPressEvent, buttonReleaseEvent, drawingAreaNew, - drawWindowGetPointerPos, - eventCoordinates, eventKeyName, eventModifier, + eventButton, eventCoordinates, eventKeyName, eventModifier, exposeEvent, keyPressEvent, leaveNotifyEvent, @@ -97,18 +105,27 @@ useHorizontalKeyNavigation = True -- Key handler code below requires that these keys don't use modifiers. -keyNavActions :: UiCtrl go ui => Map String (ui -> IO Bool) +keyNavActions :: UiCtrl go ui => Map String (ui -> IO ()) keyNavActions = Map.fromList $ - if useHorizontalKeyNavigation - then [("Up", goLeft), - ("Down", goRight), - ("Left", goUp), - ("Right", flip goDown 0)] - else [("Up", goUp), - ("Down", flip goDown 0), - ("Left", goLeft), - ("Right", goRight)] + --map (fmap ((>> return ()) .)) -- Drop the booleans these actions return. + map (fmap $ \action ui -> doUiGo ui $ void action) + (if useHorizontalKeyNavigation + then [ ("Up", goLeft) + , ("Down", goRight) + , ("Left", goUp) + , ("Right", goDown 0) + ] + else [ ("Up", goUp) + , ("Down", goDown 0) + , ("Left", goLeft) + , ("Right", goRight) + ]) ++ + [ ("Home", flip doUiGo goToRoot) + , ("End", flip doUiGo $ whileM (goDown 0) $ return ()) + , ("Page_Up", flip doUiGo $ void $ andM $ replicate 10 goUp) + , ("Page_Down", flip doUiGo $ void $ andM $ replicate 10 $ goDown 0) + ] boardBgColor :: Rgb boardBgColor = rgb255 229 178 58 @@ -149,7 +166,7 @@ stoneVariationBorderThickness :: Double stoneVariationBorderThickness = 0.02 --- | The radius of star points. Percentage of coordinate size, in @[0, 1]. +-- | The radius of star points. Percentage of coordinate size, in @[0, 1]@. starPointRadius :: Double starPointRadius = 0.1 @@ -186,9 +203,6 @@ , myState :: ViewState , myWidget :: Widget , myDrawingArea :: DrawingArea - , myHoverStateRef :: IORef (Maybe HoverState) - -- ^ A reference to the cached current hover state. Read with - -- 'readHoverState' to ensure you get a 'HoverState'. , myModesChangedHandler :: IORef (Maybe Registration) } @@ -198,31 +212,9 @@ viewState = myState viewUpdate = update --- | Holds data relating to the state of the mouse hovering over the board. -data HoverState = HoverState - { hoverCoord :: Maybe Coord - -- ^ The board coordinate corresponding to the current mouse position. - -- Nothing if the mouse is not over the board. - , hoverIsValidMove :: Bool - -- ^ True iff the hovered point is legal to play on for the current player. - } deriving (Show) - --- | Augments a 'CoordState' with data that is only used for rendering purposes. -data RenderedCoord = RenderedCoord - { renderedCoordState :: CoordState - , renderedCoordCurrent :: Bool - , renderedCoordVariation :: Maybe Color - -- ^ If a variation move exists at this point, then this will be the color - -- of the move. - } deriving (Show) - -- | Creates a 'Goban' for rendering Go boards of the given size. create :: UiCtrl go ui => ui -> IO (Goban ui) create ui = do - hoverStateRef <- newIORef $ Just HoverState { hoverCoord = Nothing - , hoverIsValidMove = False - } - drawingArea <- drawingAreaNew widgetSetCanFocus drawingArea True widgetAddEvents drawingArea [LeaveNotifyMask, @@ -236,7 +228,6 @@ , myState = state , myWidget = toWidget drawingArea , myDrawingArea = drawingArea - , myHoverStateRef = hoverStateRef , myModesChangedHandler = modesChangedHandler } @@ -254,11 +245,17 @@ return True on drawingArea buttonPressEvent $ do - liftIO $ widgetGrabFocus drawingArea - mouseXy <- eventCoordinates - liftIO $ doToolAtPoint ui drawingArea mouseXy + mouseButton <- eventButton + mouseCoord <- eventCoordinates + liftIO $ handleMouseDown me mouseButton mouseCoord return True + on drawingArea buttonReleaseEvent $ do + mouseButton <- eventButton + mouseCoord <- eventCoordinates + liftIO $ handleMouseUp me mouseButton mouseCoord + return True + on drawingArea keyPressEvent $ do key <- eventKeyName mods <- eventModifier @@ -307,92 +304,36 @@ update :: UiCtrl go ui => Goban ui -> IO () update me = do - invalidateHoverState me - widgetQueueDraw $ myDrawingArea me - --- | Called when the mouse is moved. Updates the 'HoverState' according to the --- new mouse location, and redraws the board if necessary. -handleMouseMove :: UiCtrl go ui - => Goban ui - -> Maybe (Double, Double) - -> IO () -handleMouseMove me maybeClickCoord = do - let ui = myUi me - drawingArea = myDrawingArea me - maybeXy <- case maybeClickCoord of - Nothing -> return Nothing - Just (mouseX, mouseY) -> do - board <- fmap cursorBoard (readCursor ui) - gtkToBoardCoordinates board drawingArea mouseX mouseY - updateHoverState me maybeXy >>= flip when - (widgetQueueDraw drawingArea) - --- | Applies the current tool at the given GTK coordinate, if such an action is --- valid. -doToolAtPoint :: UiCtrl go ui => ui -> DrawingArea -> (Double, Double) -> IO () -doToolAtPoint ui drawingArea (mouseX, mouseY) = do - cursor <- readCursor ui - let board = cursorBoard cursor - maybeXy <- gtkToBoardCoordinates board drawingArea mouseX mouseY - whenMaybe maybeXy $ \xy -> do - tool <- fmap uiTool (readModes ui) - - case tool of - ToolMarkCircle -> toggleMark ui xy MarkCircle - ToolMarkSelected -> toggleMark ui xy MarkSelected - ToolMarkSquare -> toggleMark ui xy MarkSquare - ToolMarkTriangle -> toggleMark ui xy MarkTriangle - ToolMarkX -> toggleMark ui xy MarkX - ToolPlay -> do - valid <- isValidMove ui xy - when valid $ playAt ui $ Just xy - _ -> return () -- TODO Support other tools. - where toggleMark ui xy mark = doUiGo ui $ modifyMark (toggleMark' mark) xy - toggleMark' mark maybeExistingMark = case maybeExistingMark of - Just existingMark | existingMark == mark -> Nothing - _ -> Just mark + fireGobanEvent me GobanInvalidate + redraw me --- | Reads the cached hover state, building a new one only if the cache is --- empty. -readHoverState :: UiCtrl go ui => Goban ui -> IO HoverState -readHoverState me = do - let ref = myHoverStateRef me - hoverState <- readIORef ref - case hoverState of - Just state -> return state - Nothing -> do updateHoverStateCurrent me - fromMaybe (error "Goban.readHoverState") <$> readIORef ref +-- | Notifies the active tool that a mouse button was pressed down over the +-- board. +handleMouseDown :: UiCtrl go ui => Goban ui -> MouseButton -> (Double, Double) -> IO () +handleMouseDown me mouseButton mouseCoord = do + widgetGrabFocus $ myDrawingArea me + maybeCoord <- gtkToBoardCoordinates me mouseCoord + fireGobanEvent me $ GobanClickStart mouseButton maybeCoord --- | Clears the cached hover state. -invalidateHoverState :: Goban ui -> IO () -invalidateHoverState me = writeIORef (myHoverStateRef me) Nothing +-- | Notifies the active tool that a mouse click or drag that started with the +-- mouse being pressed down over the board has completed. +handleMouseUp :: UiCtrl go ui => Goban ui -> MouseButton -> (Double, Double) -> IO () +handleMouseUp me mouseButton mouseCoord = do + maybeCoord <- gtkToBoardCoordinates me mouseCoord + fireGobanEvent me $ GobanClickFinish mouseButton maybeCoord --- | If the mouse has moved or the hover state is nothing, then this updates the --- hover state based on the mouse being at the given board coordinate (see --- 'gtkToBoardCoordinates'), and returns true. Returns false if no update was --- needed. -updateHoverState :: UiCtrl go ui => Goban ui -> Maybe Coord -> IO Bool -updateHoverState me maybeXy = do - let ui = myUi me - hoverStateRef = myHoverStateRef me - hoverState <- readIORef hoverStateRef - case hoverState of - Just state | hoverCoord state == maybeXy -> return False - _ -> do - valid <- case maybeXy of - Nothing -> return False - Just xy -> isValidMove ui xy - writeIORef hoverStateRef $ Just HoverState { hoverCoord = maybeXy - , hoverIsValidMove = valid - } - return True +-- | notifies the active tool that the mouse has moved over the board. +handleMouseMove :: UiCtrl go ui => Goban ui -> Maybe (Double, Double) -> IO () +handleMouseMove me maybeMouseCoord = do + maybeCoord <- maybe (return Nothing) (gtkToBoardCoordinates me) maybeMouseCoord + fireGobanEvent me $ GobanMouseMove maybeCoord --- | Updates the hover state based on the current mouse position. -updateHoverStateCurrent :: UiCtrl go ui => Goban ui -> IO () -updateHoverStateCurrent me = do - (_, x, y, _) <- drawWindowGetPointerPos =<< widgetGetDrawWindow (myDrawingArea me) - updateHoverState me $ Just (x, y) - return () +-- | Sends an event to the active tool. +fireGobanEvent :: UiCtrl go ui => Goban ui -> GobanEvent -> IO () +fireGobanEvent me event = do + AnyTool tool <- readTool $ myUi me + doRedraw <- toolGobanHandleEvent tool event + when doRedraw $ redraw me applyBoardCoordinates :: BoardState -> DrawingArea -> IO (Render ()) applyBoardCoordinates board drawingArea = do @@ -412,8 +353,11 @@ -- | Takes a GTK coordinate and, using a Cairo rendering context, returns the -- corresponding board coordinate, or @Nothing@ if the GTK coordinate is not -- over the board. -gtkToBoardCoordinates :: BoardState -> DrawingArea -> Double -> Double -> IO (Maybe (Int, Int)) -gtkToBoardCoordinates board drawingArea x y = do +gtkToBoardCoordinates :: UiCtrl go ui => Goban ui -> (Double, Double) -> IO (Maybe (Int, Int)) +gtkToBoardCoordinates me (x, y) = do + let ui = myUi me + drawingArea = myDrawingArea me + board <- cursorBoard <$> readCursor ui drawWindow <- widgetGetDrawWindow drawingArea changeCoords <- applyBoardCoordinates board drawingArea result@(bx, by) <- fmap (mapTuple floor) $ @@ -424,6 +368,10 @@ then Nothing else Just result +-- | Schedules the goban to repaint. +redraw :: UiCtrl go ui => Goban ui -> IO () +redraw = widgetQueueDraw . myDrawingArea + -- | Fully redraws the board based on the current controller and UI state. drawBoard :: UiCtrl go ui => Goban ui -> IO () drawBoard me = do @@ -431,11 +379,10 @@ drawingArea = myDrawingArea me cursor <- readCursor ui modes <- readModes ui - hoverState <- readHoverState me + AnyTool tool <- readTool ui - let board = cursorBoard cursor - tool = uiTool modes - variationMode = rootInfoVariationMode $ gameInfoRootInfo $ boardGameInfo $ cursorBoard cursor + board <- toolGobanRenderGetBoard tool cursor + let variationMode = rootInfoVariationMode $ gameInfoRootInfo $ boardGameInfo $ cursorBoard cursor variations :: [(Coord, Color)] variations = if variationModeBoardMarkup variationMode @@ -452,39 +399,14 @@ cursorProperties cursor else [] - -- The state of the board's points, with all data for rendering. - renderedCoords :: [[RenderedCoord]] - renderedCoords = - -- Add current moves. - (flip .) - foldr (\(x, y) grid -> - listUpdate (flip listUpdate x $ - \renderedCoord -> renderedCoord { renderedCoordCurrent = True }) - y - grid) - current $ - -- Add variations. - foldr (\((x, y), color) grid -> - listUpdate (flip listUpdate x $ - \renderedCoord -> renderedCoord { renderedCoordVariation = Just color }) - y - grid) - (map (map $ \state -> RenderedCoord state False Nothing) $ - mapBoardCoords preprocessCoord board) - variations - -- | Performs processing at the individual coord level based on UI state. - preprocessCoord :: Int -> Int -> CoordState -> CoordState - preprocessCoord y x = - let maybeAddHover = case hoverCoord hoverState of - Just (hx, hy) | x == hx && y == hy -> - modifyCoordForHover tool board hoverState - _ -> id - applyStoneViewMode = case uiViewStonesMode modes of + preprocessCoord :: CoordState -> CoordState + preprocessCoord = + let applyStoneViewMode = case uiViewStonesMode modes of ViewStonesRegularMode -> id ViewStonesOneColorMode -> coerceStone $ uiViewStonesOneColorModeColor modes ViewStonesBlindMode -> setStone Nothing - in applyStoneViewMode . maybeAddHover + in applyStoneViewMode -- | Replaces an existing stone of color opposite to the one given with a -- stone of the given color. @@ -499,6 +421,27 @@ then state else state { coordStone = color } + -- The state of the board's points, with all data for rendering. + renderedCoords <- + toolGobanRenderModifyCoords tool board $ + -- Add current moves. + (flip .) + foldr (\(x, y) grid -> + listUpdate (flip listUpdate x $ + \renderedCoord -> renderedCoord { renderedCoordCurrent = True }) + y + grid) + current $ + -- Add variations. + foldr (\((x, y), color) grid -> + listUpdate (flip listUpdate x $ + \renderedCoord -> renderedCoord { renderedCoordVariation = Just color }) + y + grid) + (map (map $ (\state -> RenderedCoord state False Nothing) . preprocessCoord) $ + boardCoordStates board) + variations + drawWindow <- widgetGetDrawWindow drawingArea changeCoords <- applyBoardCoordinates board drawingArea renderWithDrawable drawWindow $ do @@ -536,7 +479,7 @@ unless (null (boardLines board) && null (boardArrows board)) $ do setSourceRGB 0 0 0 setLineWidth boardAnnotationLineWidth - mapM_ (uncurry drawLine) $ boardLines board + mapM_ (uncurry drawLine . lineToPair) $ boardLines board mapM_ (uncurry drawArrow) $ boardArrows board return () @@ -577,40 +520,6 @@ _ -> return () -- Restore the coordinate system for the next stone. translate (-x') (-y') - --- | Given a current tool, board, and hover, modifies a 'CoordState' to reflect --- that the user is hovering over the point. The effect depends on the tool. --- The effect is to suggest what would happen if the point were clicked. -modifyCoordForHover :: Tool -> BoardState -> HoverState -> CoordState -> CoordState -modifyCoordForHover tool board hover coord = case tool of - ToolPlay -> if hoverIsValidMove hover - then coord { coordStone = Just (boardPlayerTurn board) } - else coord - ToolJump -> coord -- TODO Hover for ToolJump. - ToolScore -> coord -- TODO Hover for ToolScore. - ToolBlack -> coord { coordStone = Just (toolToColor tool) } - ToolWhite -> coord { coordStone = Just (toolToColor tool) } - ToolErase -> coord { coordStone = Nothing } - ToolArrow -> coord -- TODO Hover for ToolArrow. - ToolMarkCircle -> toggleMark MarkCircle coord - ToolLabel -> coord -- TODO Hover for ToolLabel. - ToolLine -> coord -- TODO Hover for ToolLine. - ToolMarkX -> toggleMark MarkX coord - ToolMarkSelected -> toggleMark MarkSelected coord - ToolMarkSquare -> toggleMark MarkSquare coord - ToolMarkTriangle -> toggleMark MarkTriangle coord - ToolVisible -> coord { coordVisible = not $ coordVisible coord } - ToolDim -> coord { coordDimmed = not $ coordDimmed coord } - --- | Toggles a specific mark on a 'CoordState'. If the @CoordState@ already has --- that mark, then it is removed. If the @CoordState@ has no mark or has --- another mark, then the given mark is added to the @CoordState@, overwriting --- an existing mark if there is one. -toggleMark :: Mark -> CoordState -> CoordState -toggleMark mark coord = let justMark = Just mark - in if coordMark coord == justMark - then coord { coordMark = Nothing } - else coord { coordMark = justMark } -- | Draws the gridlines for a single point on the board. drawGrid :: BoardState -> Double -> Double -> Int -> Int -> Render () diff --git a/src/Game/Goatee/Ui/Gtk/MainWindow.hs b/src/Game/Goatee/Ui/Gtk/MainWindow.hs --- a/src/Game/Goatee/Ui/Gtk/MainWindow.hs +++ b/src/Game/Goatee/Ui/Gtk/MainWindow.hs @@ -1,6 +1,6 @@ -- This file is part of Goatee. -- --- Copyright 2014 Bryan Gardiner +-- Copyright 2014-2015 Bryan Gardiner -- -- Goatee is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by @@ -25,7 +25,7 @@ ) where import Control.Applicative ((<$>)) -import Control.Monad (forM_, liftM, unless) +import Control.Monad (forM, forM_, join, liftM) import Control.Monad.Trans (liftIO) import qualified Data.Foldable as F import Data.IORef (IORef, newIORef, readIORef, writeIORef) @@ -48,6 +48,7 @@ Action, Menu, Packing (PackGrow, PackNatural), + ToolbarStyle (ToolbarText), Window, actionCreateMenuItem, actionCreateToolItem, actionGroupGetAction, boxPackStart, @@ -62,12 +63,11 @@ panedPack1, panedPack2, panedSetPosition, separatorMenuItemNew, separatorToolItemNew, toAction, - toolbarNew, + toolbarNew, toolbarSetStyle, vBoxNew, widgetDestroy, widgetGrabFocus, widgetShowAll, windowNew, windowSetDefaultSize, windowSetTitle, ) -import System.IO (hPutStrLn, stderr) data MainWindow ui = MainWindow { myUi :: ui @@ -162,24 +162,27 @@ toolbar <- toolbarNew boxPackStart boardBox toolbar PackNatural 0 + toolbarSetStyle toolbar ToolbarText - sequence_ $ - intersperse (do menuSep <- separatorMenuItemNew - toolSep <- separatorToolItemNew - containerAdd menuToolMenu menuSep - containerAdd toolbar toolSep) $ - catMaybes $ - flip map toolOrdering $ \toolGroup -> - let supportedTools = filter toolIsImplemented toolGroup - in if null supportedTools - then Nothing - else Just $ forM_ supportedTools $ \tool -> do - action <- fromMaybe (error $ "Tool has no action: " ++ show tool) <$> - actionGroupGetAction (Actions.myToolActions actions) (show tool) - menuItem <- actionCreateMenuItem action - toolItem <- actionCreateToolItem action - containerAdd menuToolMenu menuItem - containerAdd toolbar toolItem + let addToolSeparator = do + menuSep <- separatorMenuItemNew + toolSep <- separatorToolItemNew + containerAdd menuToolMenu menuSep + containerAdd toolbar toolSep + addTool (AnyTool tool) = do + action <- fromMaybe (error $ "No action for tool with type: " ++ show (toolType tool)) <$> + actionGroupGetAction (Actions.myToolActions actions) (show (toolType tool)) + menuItem <- actionCreateMenuItem action + toolItem <- actionCreateToolItem action + containerAdd menuToolMenu menuItem + containerAdd toolbar toolItem + in join $ fmap (sequence_ . intersperse addToolSeparator . catMaybes) $ + forM toolOrdering $ \toolGroup -> do + tools <- filter (\(AnyTool tool) -> toolIsImplemented tool) <$> + mapM (findTool ui) toolGroup + return $ if null tools + then Nothing + else Just $ mapM_ addTool tools menuView <- menuItemNewWithMnemonic "_View" menuViewMenu <- menuNew @@ -204,7 +207,10 @@ menuHelpMenu <- menuNew menuShellAppend menuBar menuHelp menuItemSetSubmenu menuHelp menuHelpMenu - addActionsToMenu menuHelpMenu actions [Actions.myHelpAboutAction] + addActionsToMenu menuHelpMenu actions + [ Actions.myHelpKeyBindingsAction + , Actions.myHelpAboutAction + ] infoLine <- InfoLine.create ui boxPackStart boardBox (InfoLine.myWidget infoLine) PackNatural 0 @@ -224,7 +230,7 @@ controlsBook <- notebookNew panedPack2 hPaned controlsBook False True - playPanel <- PlayPanel.create ui actions + playPanel <- PlayPanel.create ui gamePropertiesPanel <- GamePropertiesPanel.create ui nodePropertiesPanel <- NodePropertiesPanel.create ui notebookAppendPage controlsBook (PlayPanel.myWidget playPanel) "Play" @@ -289,22 +295,6 @@ let ui = myUi me F.mapM_ (unregisterDirtyChangedHandler ui) =<< readIORef (myDirtyChangedHandler me) F.mapM_ (unregisterFilePathChangedHandler ui) =<< readIORef (myFilePathChangedHandler me) - - -- A main window owns a UI controller. Once a main window is destroyed, - -- there should be no remaining handlers registered. - -- TODO Revisit this if we have multiple windows under a controller. - registeredHandlers ui >>= \handlers -> unless (null handlers) $ hPutStrLn stderr $ - "MainWindow.destroy: Warning, there are still handler(s) registered:" ++ - concatMap (\handler -> "\n- " ++ show handler) handlers - registeredDirtyChangedHandlers ui >>= \handlers -> unless (null handlers) $ hPutStrLn stderr $ - "MainWindow.destroy: Warning, there are still dirty changed handler(s) registered:" ++ - concatMap (\handler -> "\n- " ++ show handler) handlers - registeredFilePathChangedHandlers ui >>= \handlers -> unless (null handlers) $ hPutStrLn stderr $ - "MainWindow.destroy: Warning, there are still file path changed handler(s) registered:" ++ - concatMap (\handler -> "\n- " ++ show handler) handlers - registeredModesChangedHandlers ui >>= \handlers -> unless (null handlers) $ hPutStrLn stderr $ - "MainWindow.destroy: Warning, there are still modes changed handler(s) registered:" ++ - concatMap (\handler -> "\n- " ++ show handler) handlers widgetDestroy $ myWindow me diff --git a/src/Game/Goatee/Ui/Gtk/NodePropertiesPanel.hs b/src/Game/Goatee/Ui/Gtk/NodePropertiesPanel.hs --- a/src/Game/Goatee/Ui/Gtk/NodePropertiesPanel.hs +++ b/src/Game/Goatee/Ui/Gtk/NodePropertiesPanel.hs @@ -27,9 +27,9 @@ import Control.Applicative ((<$>), (<*), (*>)) import Control.Monad (forM_, unless, when) import qualified Data.Foldable as Foldable -import qualified Data.Function as Function import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.List (sortBy) +import Data.Ord (comparing) import Game.Goatee.Lib.Board import Game.Goatee.Lib.Monad hiding (on) import Game.Goatee.Lib.Parser @@ -170,8 +170,7 @@ cursor <- readCursor $ myUi me let model = myModel me modelProperties = myModelProperties me - newProperties = sortBy (compare `Function.on` propertyName) $ - cursorProperties cursor + newProperties = sortBy (comparing propertyName) $ cursorProperties cursor oldProperties <- listStoreToList model when (newProperties /= oldProperties) $ do listStoreClear model diff --git a/src/Game/Goatee/Ui/Gtk/PlayPanel.hs b/src/Game/Goatee/Ui/Gtk/PlayPanel.hs --- a/src/Game/Goatee/Ui/Gtk/PlayPanel.hs +++ b/src/Game/Goatee/Ui/Gtk/PlayPanel.hs @@ -1,6 +1,6 @@ -- This file is part of Goatee. -- --- Copyright 2014 Bryan Gardiner +-- Copyright 2014-2015 Bryan Gardiner -- -- Goatee is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by @@ -23,18 +23,25 @@ ) where import Control.Applicative ((<$>)) -import Control.Monad (void) +import Control.Monad (forM, void, when) +import Data.Foldable (forM_, mapM_) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Maybe (catMaybes) +import qualified Data.Set as Set import Game.Goatee.Common import Game.Goatee.Lib.Board -import qualified Game.Goatee.Lib.Monad as Monad import Game.Goatee.Lib.Monad ( - AnyEvent (..), getCursor, modifyPropertyString, navigationEvent, propertiesModifiedEvent, + AnyEvent (..), + goDown, + goToRoot, + goUp, + modifyPropertyString, + navigationEvent, + propertiesModifiedEvent, ) import Game.Goatee.Lib.Property import Game.Goatee.Lib.Tree import Game.Goatee.Lib.Types -import qualified Game.Goatee.Ui.Gtk.Actions as Actions -import Game.Goatee.Ui.Gtk.Actions (Actions) import Game.Goatee.Ui.Gtk.Common import Game.Goatee.Ui.Gtk.Utils import Graphics.UI.Gtk ( @@ -43,7 +50,7 @@ TextView, Widget, WrapMode (WrapWord), - actionActivate, + afterShow, boxPackStart, buttonActivated, buttonNewWithLabel, containerAdd, @@ -53,7 +60,9 @@ textViewNew, textViewSetWrapMode, toWidget, vBoxNew, + widgetHide, widgetShow, ) +import Prelude hiding (mapM_) data PlayPanel ui = PlayPanel { myUi :: ui @@ -61,6 +70,7 @@ , myWidget :: Widget , myComment :: TextView , myCommentSetter :: String -> IO () + , myModesChangedHandler :: IORef (Maybe Registration) } instance UiCtrl go ui => UiView go ui (PlayPanel ui) where @@ -69,8 +79,8 @@ viewState = myState viewUpdate = update -create :: UiCtrl go ui => ui -> Actions ui -> IO (PlayPanel ui) -create ui actions = do +create :: UiCtrl go ui => ui -> IO (PlayPanel ui) +create ui = do box <- vBoxNew False 0 navBox <- hBoxNew True 0 @@ -81,15 +91,20 @@ endButton <- buttonNewWithLabel ">>" mapM_ (\b -> boxPackStart navBox b PackGrow 0) [startButton, prevButton, nextButton, endButton] - on startButton buttonActivated $ doUiGo ui Monad.goToRoot - on prevButton buttonActivated $ void $ goUp ui - on nextButton buttonActivated $ void $ goDown ui 0 - on endButton buttonActivated $ doUiGo ui $ - whileM ((> 0) . length . cursorChildren <$> getCursor) $ Monad.goDown 0 + on startButton buttonActivated $ doUiGo ui goToRoot + on prevButton buttonActivated $ doUiGo ui $ void goUp + on nextButton buttonActivated $ doUiGo ui $ void $ goDown 0 + on endButton buttonActivated $ doUiGo ui $ whileM (goDown 0) $ return () - passButton <- buttonNewWithLabel "Pass" - boxPackStart box passButton PackNatural 0 - on passButton buttonActivated $ actionActivate $ Actions.myGamePassAction actions + -- Add the widgets of all of the tools. Deduplicate the widgets so those that + -- are shared between tools only get added once; GTK+ doesn't like having a + -- widget added multiple times. + toolWidgets <- fmap catMaybes $ + forM [minBound..] $ + fmap (\(AnyTool tool) -> toolPanelWidget tool) . + findTool ui + forM_ (Set.toList $ Set.fromList toolWidgets) $ \widget -> + boxPackStart box widget PackNatural 0 comment <- textViewNew textViewSetWrapMode comment WrapWord @@ -102,6 +117,7 @@ doUiGo ui $ modifyPropertyString propertyC $ const value state <- viewStateNew + modesChangedHandler <- newIORef Nothing let me = PlayPanel { myUi = ui @@ -109,23 +125,60 @@ , myWidget = toWidget box , myComment = comment , myCommentSetter = commentSetter + , myModesChangedHandler = modesChangedHandler } + -- After the panel is shown, we only want the tool widget for the active tool + -- to be visible. + afterShow (myWidget me) $ updateVisibleToolWidget me + initialize me return me initialize :: UiCtrl go ui => PlayPanel ui -> IO () initialize me = do + let ui = myUi me + register me [ AnyEvent navigationEvent , AnyEvent propertiesModifiedEvent ] + + writeIORef (myModesChangedHandler me) =<< + fmap Just (registerModesChangedHandler ui "PlayPanel" $ checkForToolChange me) + viewUpdate me destroy :: UiCtrl go ui => PlayPanel ui -> IO () -destroy = viewDestroy +destroy me = do + let ui = myUi me + mapM_ (unregisterModesChangedHandler ui) =<< readIORef (myModesChangedHandler me) + viewDestroy me update :: UiCtrl go ui => PlayPanel ui -> IO () update me = readCursor (myUi me) >>= myCommentSetter me . maybe "" fromText . findPropertyValue propertyC . cursorNode + +-- | Updates the visibility of all tool widgets, hiding all widgets of inactive +-- tools and showing the widget of the active tool. +updateVisibleToolWidget :: UiCtrl go ui => PlayPanel ui -> IO () +updateVisibleToolWidget me = do + let ui = myUi me + activeToolType <- (\(AnyTool tool) -> toolType tool) <$> readTool ui + forM_ [minBound..] $ \toolType -> + findTool ui toolType >>= \(AnyTool tool) -> + forM_ (toolPanelWidget tool) $ \widget -> + (if toolType == activeToolType then widgetShow else widgetHide) widget + +-- | Checks for a change in active tool between the two modes; if one is found, +-- the deactivating tool's widget is hidden and the activating tool's widget is +-- shown. +checkForToolChange :: UiCtrl go ui => PlayPanel ui -> UiModes -> UiModes -> IO () +checkForToolChange me oldModes newModes = do + let ui = myUi me + oldTool = uiToolType oldModes + newTool = uiToolType newModes + when (newTool /= oldTool) $ do + findTool ui oldTool >>= \(AnyTool tool) -> mapM_ widgetHide $ toolPanelWidget tool + findTool ui newTool >>= \(AnyTool tool) -> mapM_ widgetShow $ toolPanelWidget tool diff --git a/src/Game/Goatee/Ui/Gtk/Tool.hs b/src/Game/Goatee/Ui/Gtk/Tool.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Ui/Gtk/Tool.hs @@ -0,0 +1,83 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014-2015 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +module Game.Goatee.Ui.Gtk.Tool ( + createTools, + ) where + +import qualified Data.Map as Map +import Data.Map (Map) +import Game.Goatee.Lib.Board +import Game.Goatee.Lib.Property +import Game.Goatee.Lib.Types +import Game.Goatee.Ui.Gtk.Common +import qualified Game.Goatee.Ui.Gtk.Tool.AssignStone as AssignStone +import qualified Game.Goatee.Ui.Gtk.Tool.Line as Line +import qualified Game.Goatee.Ui.Gtk.Tool.Mark as Mark +import qualified Game.Goatee.Ui.Gtk.Tool.Null as Null +import qualified Game.Goatee.Ui.Gtk.Tool.Play as Play +import qualified Game.Goatee.Ui.Gtk.Tool.Visibility as Visibility + +-- | Instantiates 'UiTool' instances for all of the 'ToolType's, and returns a +-- map for looking up tools by their type. +createTools :: UiCtrl go ui => ui -> IO (Map ToolType (AnyTool go ui)) +createTools ui = do + toolArrow <- toolStateNew ToolArrow "Draw arrows" >>= Line.create ui Line.arrowDescriptor + toolAssignBlack <- toolStateNew ToolAssignBlack "Paint black stones" >>= + AssignStone.create ui (Just Black) Nothing + toolAssignEmpty <- toolStateNew ToolAssignEmpty "Paint empty stones" >>= + AssignStone.create ui Nothing (Just toolAssignBlack) + toolAssignWhite <- toolStateNew ToolAssignWhite "Paint white stones" >>= + AssignStone.create ui (Just White) (Just toolAssignBlack) + toolDim <- toolStateNew ToolDim "Toggle points dimmed" >>= + Visibility.create ui propertyDD boardHasDimmed "dimming" + toolJump <- toolStateNew ToolJump "Jump to move" >>= Null.create ui + toolLabel <- toolStateNew ToolLabel "Label points" >>= Null.create ui + toolLine <- toolStateNew ToolLine "Draw lines" >>= Line.create ui Line.lineDescriptor + toolMarkCircle <- toolStateNew ToolMarkCircle "Mark circles" >>= + Mark.create ui MarkCircle Nothing + toolMarkSelected <- toolStateNew ToolMarkSelected "Mark selected" >>= + Mark.create ui MarkSelected (Just toolMarkCircle) + toolMarkSquare <- toolStateNew ToolMarkSquare "Mark squares" >>= + Mark.create ui MarkSquare (Just toolMarkCircle) + toolMarkTriangle <- toolStateNew ToolMarkTriangle "Mark trianges" >>= + Mark.create ui MarkTriangle (Just toolMarkCircle) + toolMarkX <- toolStateNew ToolMarkX "Mark Xs" >>= + Mark.create ui MarkX (Just toolMarkCircle) + toolPlay <- toolStateNew ToolPlay "Play" >>= Play.create ui + toolScore <- toolStateNew ToolScore "Score" >>= Null.create ui + toolVisible <- toolStateNew ToolVisible "Toggle points visible" >>= + Visibility.create ui propertyVW boardHasInvisible "visibilities" + return $ Map.fromList $ map + (\tool@(AnyTool tool') -> (toolType tool', tool)) + [ AnyTool toolArrow + , AnyTool toolAssignBlack + , AnyTool toolAssignEmpty + , AnyTool toolAssignWhite + , AnyTool toolDim + , AnyTool toolJump + , AnyTool toolLabel + , AnyTool toolLine + , AnyTool toolMarkCircle + , AnyTool toolMarkSelected + , AnyTool toolMarkSquare + , AnyTool toolMarkTriangle + , AnyTool toolMarkX + , AnyTool toolPlay + , AnyTool toolScore + , AnyTool toolVisible + ] diff --git a/src/Game/Goatee/Ui/Gtk/Tool/AssignStone.hs b/src/Game/Goatee/Ui/Gtk/Tool/AssignStone.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Ui/Gtk/Tool/AssignStone.hs @@ -0,0 +1,168 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014-2015 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +module Game.Goatee.Ui.Gtk.Tool.AssignStone (AssignStoneTool, create) where + +import Control.Applicative ((<$>)) +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, + ) + +-- | A 'UiTool' that toggles assigned stones in rectangles on the board. +data AssignStoneTool ui = AssignStoneTool + { myUi :: ui + , myViewState :: ViewState + , myToolState :: ToolState + , myStone :: Maybe Color + , myWidgets :: Widgets + } + +-- | Widgets that are shared between 'AssignStone' instances for a common panel. +data Widgets = Widgets + { myBox :: HBox + , myBlackButton :: RadioButton + , myWhiteButton :: RadioButton + , myEmptyButton :: RadioButton + , myViewUpdateLatch :: Latch + -- ^ This latch should be held on whenever updating the radio buttons above. + } + +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 + -- If the node ends up with no properties, and is a child node, then + -- move up and delete the node. + 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 + +-- | Creates a 'AssignStoneTool' that will modify regions of the given mark on +-- the board. If given another 'AssignStoneTool', then this tool will share +-- 'Widgets' with the existing tool, otherwise it will create new 'Widgets' from +-- scratch. All instances of 'AssignStoneTool' are meant to share a single +-- instance of 'Widgets'. +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 + } + +-- | Creates a 'Widgets' for 'AssignStoneTool's, and configures the widgets +-- within to activate different tools. +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 + } + +-- | Picks the 'RadioButton' corresponding to an 'AssignStoneTool' from the +-- tool's 'Widgets'. +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) diff --git a/src/Game/Goatee/Ui/Gtk/Tool/Line.hs b/src/Game/Goatee/Ui/Gtk/Tool/Line.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Ui/Gtk/Tool/Line.hs @@ -0,0 +1,109 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014-2015 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +module Game.Goatee.Ui.Gtk.Tool.Line ( + LineTool, create, + LinelikeDescriptor, arrowDescriptor, lineDescriptor, + ) where + +import Data.List (delete) +import Game.Goatee.Lib.Board +import Game.Goatee.Lib.Monad +import Game.Goatee.Lib.Property +import Game.Goatee.Lib.Types +import Game.Goatee.Ui.Gtk.Common + +-- | A 'UiTool' that toggles lines between points on the board. +data LineTool ui = LineTool + { myUi :: ui + , myViewState :: ViewState + , myToolState :: ToolState + , myDescriptor :: AnyLinelikeDescriptor + } + +-- | A descriptor for a line-like property: a valued property that contains a +-- list of connections between two points on the board. +data LinelikeDescriptor v = LinelikeDescriptor + { linelikeDescriptor :: ValuedPropertyInfo [v] + , linelikeLift :: (Coord, Coord) -> v + } + +-- | An existential type for any linelike descriptor. +data AnyLinelikeDescriptor = forall v. Eq v => AnyLinelikeDescriptor (LinelikeDescriptor v) + +-- | A descriptor for directed arrows ('AR'). +arrowDescriptor :: AnyLinelikeDescriptor +arrowDescriptor = AnyLinelikeDescriptor LinelikeDescriptor + { linelikeDescriptor = propertyAR + , linelikeLift = id + } + +-- | A descriptor for undirected lines ('LN'). +lineDescriptor :: AnyLinelikeDescriptor +lineDescriptor = AnyLinelikeDescriptor LinelikeDescriptor + { linelikeDescriptor = propertyLN + , linelikeLift = uncurry Line + } + +instance UiCtrl go ui => UiView go ui (LineTool ui) where + viewName me = case myDescriptor me of + AnyLinelikeDescriptor descriptor -> + "LineTool(" ++ propertyName (linelikeDescriptor descriptor) ++ ")" + + viewCtrl = myUi + + viewState = myViewState + + viewUpdate = const $ return () + +instance UiCtrl go ui => UiTool go ui (LineTool ui) where + toolState = myToolState + + toolGobanClickComplete me (Just from) (Just to) | from /= to = case myDescriptor me of + AnyLinelikeDescriptor linelike -> + doUiGo (myUi me) $ + modifyPropertyList (linelikeDescriptor linelike) $ + toggleInList $ linelikeLift linelike (from, to) + + toolGobanClickComplete _ _ _ = return () + + toolGobanRenderGetBoard me cursor = do + state <- toolGetGobanState me + case state of + ToolGobanDragging _ (Just startCoord) (Just endCoord) | startCoord /= endCoord -> + case myDescriptor me of + AnyLinelikeDescriptor linelike -> + return $ cursorBoard $ flip execGo cursor $ + modifyPropertyList (linelikeDescriptor linelike) $ + toggleInList $ linelikeLift linelike (startCoord, endCoord) + _ -> return $ cursorBoard cursor + +-- | Creates a 'LineTool' that will toggle a line-like property between pairs of +-- points on the board. +create :: UiCtrl go ui => ui -> AnyLinelikeDescriptor -> ToolState -> IO (LineTool ui) +create ui descriptor toolState = do + viewState <- viewStateNew + return LineTool + { myUi = ui + , myViewState = viewState + , myToolState = toolState + , myDescriptor = descriptor + } + +-- | Toggles the presense of an item in a list. +toggleInList :: Eq a => a -> [a] -> [a] +toggleInList x xs = (if x `elem` xs then delete else (:)) x xs diff --git a/src/Game/Goatee/Ui/Gtk/Tool/Mark.hs b/src/Game/Goatee/Ui/Gtk/Tool/Mark.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Ui/Gtk/Tool/Mark.hs @@ -0,0 +1,179 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014-2015 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +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, + ) + +-- | A 'UiTool' that toggles 'Mark's in rectangles on the board. +data MarkTool ui = MarkTool + { myUi :: ui + , myViewState :: ViewState + , myToolState :: ToolState + , myMark :: Mark + , myWidgets :: Widgets + } + +-- | Widgets that are shared between 'MarkTool' instances for a common panel. +data Widgets = Widgets + { myBox :: HBox + , myCircleButton :: RadioButton + , mySelectedButton :: RadioButton + , mySquareButton :: RadioButton + , myTriangleButton :: RadioButton + , myXButton :: RadioButton + , myViewUpdateLatch :: Latch + -- ^ This latch should be held on whenever updating the radio buttons above. + } + +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 + _ -> []) + +-- | Creates a 'MarkTool' that will modify regions of the given mark on the +-- board. If given another 'MarkTool', then this tool will share 'Widgets' with +-- the existing tool, otherwise it will create new 'Widgets' from scratch. All +-- instances of 'MarkTool' are meant to share a single instance of 'Widgets'. +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 + } + +-- | Creates a 'Widgets' for 'MarkTool's, and configures the widgets within to +-- activate different tools. +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 + } + +-- | Picks the 'RadioButton' corresponding to a 'MarkTool' from the tool's +-- 'Widgets'. +myRadioButton :: MarkTool ui -> RadioButton +myRadioButton me = + (case myMark me of + MarkCircle -> myCircleButton + MarkSelected -> mySelectedButton + MarkSquare -> mySquareButton + MarkTriangle -> myTriangleButton + MarkX -> myXButton) $ myWidgets me + +-- | @setMarkToOppositeOf mark baseCoord targetCoord@ returns @targetCoord@ with +-- its mark modified to be nothing, if @baseCoord@ has @mark@, or @mark@, if +-- @baseCoord@ has something other than @mark@ (possibly no mark). +setMarkToOppositeOf :: Mark -> CoordState -> CoordState -> CoordState +setMarkToOppositeOf mark baseCoord = + setMark $ case coordMark baseCoord of + Just mark' | mark' == mark -> Nothing + _ -> Just mark + +-- | Changes the mark in a 'CoordState'. Returns the initial 'CoordState' if +-- the given mark is already set. +setMark :: Maybe Mark -> CoordState -> CoordState +setMark maybeMark coord = + if coordMark coord == maybeMark + then coord + else coord { coordMark = maybeMark } diff --git a/src/Game/Goatee/Ui/Gtk/Tool/Null.hs b/src/Game/Goatee/Ui/Gtk/Tool/Null.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Ui/Gtk/Tool/Null.hs @@ -0,0 +1,51 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +module Game.Goatee.Ui.Gtk.Tool.Null (NullTool, create) where + +import Game.Goatee.Ui.Gtk.Common + +-- | A 'UiTool' that does nothing and is not selectable in the UI. 'ToolType's +-- that are not yet implemented should be bound to this implementation. +data NullTool ui = NullTool + { myUi :: ui + , myViewState :: ViewState + , myToolState :: ToolState + } + +instance UiCtrl go ui => UiView go ui (NullTool ui) where + viewName = const "NullTool" + + viewCtrl = myUi + + viewState = myViewState + + viewUpdate = const $ return () + +instance UiCtrl go ui => UiTool go ui (NullTool ui) where + toolState = myToolState + + toolIsImplemented _ = False + +create :: UiCtrl go ui => ui -> ToolState -> IO (NullTool ui) +create ui toolState = do + viewState <- viewStateNew + return NullTool + { myUi = ui + , myViewState = viewState + , myToolState = toolState + } diff --git a/src/Game/Goatee/Ui/Gtk/Tool/Play.hs b/src/Game/Goatee/Ui/Gtk/Tool/Play.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Ui/Gtk/Tool/Play.hs @@ -0,0 +1,119 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +module Game.Goatee.Ui.Gtk.Tool.Play (PlayTool, create) where + +import Control.Applicative ((<$>)) +import Control.Monad (when) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Maybe (fromJust, isJust) +import Game.Goatee.Common +import qualified Game.Goatee.Lib.Board as Board +import Game.Goatee.Lib.Types +import Game.Goatee.Ui.Gtk.Common +import Graphics.UI.Gtk ( + Button, buttonActivated, buttonNewWithLabel, on, toWidget, + ) + +-- | A 'UiTool' for entering moves to record a game. When this tool is active, +-- clicking (not dragging) on a board point will make a move at the point if the +-- move is valid. A pass button is shown in the panel. +data PlayTool ui = PlayTool + { myUi :: ui + , myViewState :: ViewState + , myToolState :: ToolState + , myPassButton :: Button + , myIsValidMoveCache :: IORef (Maybe (Coord, Bool)) + } + +instance UiCtrl go ui => UiView go ui (PlayTool ui) where + viewName = const "PlayTool" + + viewCtrl = myUi + + viewState = myViewState + + viewUpdate = const $ return () + +instance UiCtrl go ui => UiTool go ui (PlayTool ui) where + toolState = myToolState + + toolPanelWidget = Just . toWidget . myPassButton + + toolGobanInvalidate = invalidateIsValidMoveCache + + toolGobanClickComplete me from to = do + let ui = myUi me + when (isJust from && from == to) $ do + valid <- isValidMove ui $ fromJust from + when valid $ playAt ui from + + toolGobanRenderModifyCoords me board coords = do + state <- toolGetGobanState me + let coordFromMouseState = case state of + ToolGobanHovering maybeCoord -> maybeCoord + ToolGobanDragging _ from current | from == current -> from + _ -> Nothing + coordIfValidMove <- case coordFromMouseState of + Nothing -> return Nothing + Just coord -> if' coordFromMouseState Nothing <$> getIsValidMove me coord + return $ case coordIfValidMove of + Just (x, y) -> + listUpdate + (flip listUpdate x $ \rendered -> + let coord = renderedCoordState rendered + coord' = coord { Board.coordStone = Just $ Board.boardPlayerTurn board } + in rendered { renderedCoordState = coord' }) + y + coords + _ -> coords + +create :: UiCtrl go ui => ui -> ToolState -> IO (PlayTool ui) +create ui toolState = do + viewState <- viewStateNew + passButton <- buttonNewWithLabel "Pass" + isValidMoveCache <- newIORef Nothing + + let me = PlayTool + { myUi = ui + , myViewState = viewState + , myToolState = toolState + , myPassButton = passButton + , myIsValidMoveCache = isValidMoveCache + } + + -- TODO Reuse Actions.myGamePassAction? + on passButton buttonActivated $ playAt ui Nothing + + return me + +-- | Calculates whether it is valid for the current player to to play at a +-- 'Coord'. Caches the result. +getIsValidMove :: UiCtrl go ui => PlayTool ui -> Coord -> IO Bool +getIsValidMove me coord = do + let ui = myUi me + cache = myIsValidMoveCache me + cached <- readIORef cache + case cached of + Just (cachedCoord, cachedValue) | cachedCoord == coord -> return cachedValue + _ -> do isValid <- isValidMove ui coord + writeIORef cache $ Just (coord, isValid) + return isValid + +-- | Invalidates the cache used by 'getIsValidMove'. +invalidateIsValidMoveCache :: PlayTool ui -> IO () +invalidateIsValidMoveCache me = writeIORef (myIsValidMoveCache me) Nothing diff --git a/src/Game/Goatee/Ui/Gtk/Tool/Visibility.hs b/src/Game/Goatee/Ui/Gtk/Tool/Visibility.hs new file mode 100644 --- /dev/null +++ b/src/Game/Goatee/Ui/Gtk/Tool/Visibility.hs @@ -0,0 +1,300 @@ +-- This file is part of Goatee. +-- +-- Copyright 2015 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +module Game.Goatee.Ui.Gtk.Tool.Visibility (VisibilityTool, create) where + +import Control.Applicative ((<$>), (<|>)) +import Control.Monad (void, when) +import Data.Foldable (forM_) +import Data.List (intercalate) +import qualified Data.Set as Set +import Game.Goatee.Lib.Board +import Game.Goatee.Lib.Monad ( + AnyEvent (AnyEvent), + deleteProperty, + execGo, + modifyPropertyCoords, + navigationEvent, + propertiesModifiedEvent, + putProperty, + ) +import Game.Goatee.Lib.Property +import Game.Goatee.Lib.Tree +import Game.Goatee.Lib.Types +import Game.Goatee.Ui.Gtk.Common +import Game.Goatee.Ui.Gtk.Latch +import Graphics.UI.Gtk ( + AttrOp ((:=)), + Button, + ButtonsType (ButtonsOk), + ComboBox, + DialogFlags (DialogDestroyWithParent, DialogModal), + HBox, + ListStore, + MessageType (MessageInfo), + Packing (PackGrow, PackNatural), + boxPackStart, + buttonActivated, buttonNewWithLabel, + cellLayoutAddColumnAttribute, cellLayoutPackStart, + cellRendererTextNew, cellText, + changed, + comboBoxActive, comboBoxNewWithModel, + dialogRun, + get, + hBoxNew, + listStoreAppend, listStoreGetSize, listStoreNew, listStoreRemove, + makeColumnIdString, + messageDialogNewWithMarkup, + on, + set, + toWidget, + treeModelSetColumn, + widgetDestroy, widgetSetSensitive, widgetTooltipText, + ) + +-- | A 'UiTool' that toggles visibility properties in rectangles on the board. +data VisibilityTool ui = VisibilityTool + { myUi :: ui + , myViewState :: ViewState + , myToolState :: ToolState + , myDescriptor :: ValuedPropertyInfo CoordList + , myBoardHasPointsPredicate :: BoardState -> Bool + + -- Widgets: + , myBox :: HBox + , myCombo :: ComboBox + , myModel :: ListStore Mode + , myCopyButton :: Button + , myViewUpdateLatch :: Latch + -- ^ This latch should be held on whenever updating the radio buttons above. + } + +-- | Describes the state of this tool's property on the current node. The +-- 'Show' instance is used in UI text. +data Mode = + ModeInherited + -- ^ The property is not present on the current node, so the current value is + -- inherited from the closest ancestor node to have the property. + | ModeReset + -- ^ The property is present on the current node, resetting all points back + -- to default (visible or undimmed, depending on the property). + | ModeAssigned + -- ^ The property is present on the current node, with a new set of points. + -- The set of points from the closest ancestor is abandoned. + deriving (Bounded, Enum, Eq, Ord) + +instance Show Mode where + show mode = case mode of + ModeInherited -> "Inherited" + ModeReset -> "Reset" + ModeAssigned -> "Assigned" + +instance UiCtrl go ui => UiView go ui (VisibilityTool ui) where + viewName me = "VisibilityTool(" ++ propertyName (myDescriptor me) ++ ")" + + viewCtrl = myUi + + viewState = myViewState + + viewUpdate = update + +instance UiCtrl go ui => UiTool go ui (VisibilityTool ui) where + toolState = myToolState + + toolPanelWidget = Just . toWidget . myBox + + toolGobanClickComplete me (Just from) (Just to) = do + modifier <- getModifierForRegion me from to + doUiGo (myUi me) $ modifyPropertyCoords (myDescriptor me) modifier + + toolGobanClickComplete _ _ _ = return () + + toolGobanRenderGetBoard me cursor = do + state <- toolGetGobanState me + case (toolGobanStateStartCoord state, toolGobanStateCurrentCoord state) of + (Just startCoord, Just endCoord) -> do + modifier <- getModifierForRegion me startCoord endCoord + return $ cursorBoard $ flip execGo cursor $ + modifyPropertyCoords (myDescriptor me) modifier + _ -> return $ cursorBoard cursor + +-- | Creates a 'VisibilityTool' that will modify regions of a type of visibility +-- on the board. +create :: UiCtrl go ui + => ui + -> ValuedPropertyInfo CoordList + -> (BoardState -> Bool) + -> String + -> ToolState + -> IO (VisibilityTool ui) +create ui descriptor boardHasPointsPrediate nounPlural toolState = do + viewState <- viewStateNew + + box <- hBoxNew False 0 + latch <- newLatch + + -- Create a dropdown that will allow selecting between the different modes. + -- Assigned mode may not be selected directly; it is activated by drawing on + -- the board or clicking Copy, and will be added to the ListStore when (and + -- only as long as) it is active. + model <- listStoreNew [ModeInherited, ModeReset] + combo <- comboBoxNewWithModel model + let column = makeColumnIdString 0 + treeModelSetColumn model column show + renderer <- cellRendererTextNew + cellLayoutPackStart combo renderer True + cellLayoutAddColumnAttribute combo renderer cellText column + boxPackStart box combo PackGrow 0 + + copyButton <- buttonNewWithLabel "Copy" + boxPackStart box copyButton PackNatural 0 + + helpButton <- buttonNewWithLabel "?" + boxPackStart box helpButton PackNatural 0 + + let me = VisibilityTool + { myUi = ui + , myViewState = viewState + , myToolState = toolState + , myDescriptor = descriptor + , myBoardHasPointsPredicate = boardHasPointsPrediate + + , myBox = box + , myCombo = combo + , myModel = model + , myCopyButton = copyButton + , myViewUpdateLatch = latch + } + + on combo changed $ whenLatchOff latch $ do + mode <- toEnum <$> get combo comboBoxActive + let descriptor = myDescriptor me + case mode of + ModeInherited -> doUiGo ui $ deleteProperty descriptor + ModeReset -> doUiGo ui $ putProperty $ propertyBuilder descriptor emptyCoordList + -- Shouldn't get here, since we only programatically give access to + -- Assigned in the dropdown. + ModeAssigned -> return () + + on copyButton buttonActivated $ do + let findAncestorProperty cursor = + findProperty descriptor (cursorNode cursor) <|> + (findAncestorProperty =<< cursorParent cursor) + cursor <- readCursor ui + forM_ (findAncestorProperty =<< cursorParent cursor) $ doUiGo ui . putProperty + + on helpButton buttonActivated $ showHelp ui nounPlural + + register me + [ AnyEvent navigationEvent + , AnyEvent propertiesModifiedEvent + ] + + viewUpdate me + return me + +-- | Displays a help dialog explaining this tool's controls in the side panel. +showHelp :: UiCtrl go ui => ui -> String -> IO () +showHelp ui nounPlural = do + let message = + intercalate "\n" + [ "The dropdown displays the " ++ nounPlural ++ " of points on the current node." + , "" + , "" ++ show ModeInherited ++ ": Points inherit their values from the parent " ++ + "node. This is the default for all nodes." + , "" ++ show ModeReset ++ ": This node resets all points to their default values." + , "" ++ show ModeAssigned ++ ": There is a custom set of points for this node " ++ + "and its descendents." + , "" + , "Drawing on the board with this tool will change the mode to " ++ show ModeAssigned ++ + ". If there is an ancestor node with " ++ show ModeAssigned ++ " then you can click " ++ + "Copy to copy those values to the current node." + ] + window <- getMainWindow ui + dialog <- messageDialogNewWithMarkup + (Just window) + [DialogModal, DialogDestroyWithParent] + MessageInfo + ButtonsOk + message + dialogRun dialog + widgetDestroy dialog + +update :: UiCtrl go ui => VisibilityTool ui -> IO () +update me = do + let ui = myUi me + cursor <- readCursor ui + + -- Set the combo box to reflect the state of VW/DD on the current node. + withLatchOn (myViewUpdateLatch me) $ setCombo me $ + case findPropertyValue (myDescriptor me) $ cursorNode cursor of + Nothing -> ModeInherited + Just coords | coords == emptyCoordList -> ModeReset + | otherwise -> ModeAssigned + + -- Enable the Copy button only if the parent has a non-empty VW/DD[...] that + -- we can copy. Copying reset properties isn't super important. + let hasParentWithPoints = + maybe False (myBoardHasPointsPredicate me . cursorBoard) $ cursorParent cursor + setCopyButtonEnabled me hasParentWithPoints + +-- | Sets the combo box to display the given 'Mode'. +setCombo :: UiCtrl go ui => VisibilityTool ui -> Mode -> IO () +setCombo me mode = do + let combo = myCombo me + model = myModel me + modelSize <- listStoreGetSize model + let modelHasAssigned = modelSize == fromEnum (maxBound :: Mode) + 1 + when (mode == ModeAssigned && not modelHasAssigned) $ + void $ listStoreAppend model ModeAssigned + set combo [comboBoxActive := fromEnum mode] + when (mode /= ModeAssigned && modelHasAssigned) $ + listStoreRemove model $ fromEnum ModeAssigned + +-- | Sets the Copy button's sensitivity and tooltip text. +setCopyButtonEnabled :: UiCtrl go ui => VisibilityTool ui -> Bool -> IO () +setCopyButtonEnabled me enabled = do + let button = myCopyButton me + widgetSetSensitive button enabled + set button [widgetTooltipText := + if enabled + then Nothing + else Just "The parent has no assigned points to copy."] + +-- | @getModifierForRegion me from to@ can be called when a drag has happened +-- over the rectangle with corners @from@ and @to@ to get a function suitable +-- for passing into 'modifyPropertyCoords' that will make the drag take effect. +getModifierForRegion :: UiCtrl go ui + => VisibilityTool ui + -> Coord + -> Coord + -> IO ([Coord] -> [Coord]) +getModifierForRegion me from to = do + currentlySet <- cursorHasPointSet me from + return $ + Set.toList . + (if currentlySet then flip Set.difference else Set.union) (Set.fromList $ coordRange from to) . + Set.fromList + +-- | Determines whether the tool's property is set on the current node, and the +-- given point is contained in the property's coord list. +cursorHasPointSet :: UiCtrl go ui => VisibilityTool ui -> Coord -> IO Bool +cursorHasPointSet me coord = + maybe False ((coord `elem`) . expandCoordList) . + findPropertyValue (myDescriptor me) . + cursorNode <$> + readCursor (myUi me) diff --git a/tests/Game/Goatee/Ui/Gtk/CommonTest.hs b/tests/Game/Goatee/Ui/Gtk/CommonTest.hs new file mode 100644 --- /dev/null +++ b/tests/Game/Goatee/Ui/Gtk/CommonTest.hs @@ -0,0 +1,31 @@ +-- This file is part of Goatee. +-- +-- Copyright 2014 Bryan Gardiner +-- +-- Goatee is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- Goatee is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with Goatee. If not, see . + +module Game.Goatee.Ui.Gtk.CommonTest (tests) where + +import Data.List (sort) +import Game.Goatee.Ui.Gtk.Common +import Test.HUnit ((~:), (@=?), Test (TestList)) + +tests = "Game.Goatee.Ui.Gtk.Common" ~: TestList + [ toolOrderingTests + ] + +toolOrderingTests = "toolOrdering" ~: TestList + [ "contains each ToolType exactly once" ~: + [minBound..] @=? sort (concat toolOrdering) + ] diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -17,12 +17,14 @@ module Main (main) where +import qualified Game.Goatee.Ui.Gtk.CommonTest import qualified Game.Goatee.Ui.Gtk.LatchTest import System.Exit (exitFailure, exitSuccess) import Test.HUnit (Counts (errors, failures), Test (TestList), runTestTT) tests = TestList - [ Game.Goatee.Ui.Gtk.LatchTest.tests + [ Game.Goatee.Ui.Gtk.CommonTest.tests + , Game.Goatee.Ui.Gtk.LatchTest.tests ] main :: IO ()