goatee-gtk 0.2.0 → 0.3.0
raw patch · 17 files changed
+1697/−423 lines, 17 filesdep ~goatee
Dependency ranges changed: goatee
Files
- goatee-gtk.cabal +14/−6
- src/Game/Goatee/Ui/Gtk.hs +76/−36
- src/Game/Goatee/Ui/Gtk/Actions.hs +63/−29
- src/Game/Goatee/Ui/Gtk/Common.hs +291/−92
- src/Game/Goatee/Ui/Gtk/Goban.hs +108/−199
- src/Game/Goatee/Ui/Gtk/MainWindow.hs +29/−39
- src/Game/Goatee/Ui/Gtk/NodePropertiesPanel.hs +2/−3
- src/Game/Goatee/Ui/Gtk/PlayPanel.hs +71/−18
- src/Game/Goatee/Ui/Gtk/Tool.hs +83/−0
- src/Game/Goatee/Ui/Gtk/Tool/AssignStone.hs +168/−0
- src/Game/Goatee/Ui/Gtk/Tool/Line.hs +109/−0
- src/Game/Goatee/Ui/Gtk/Tool/Mark.hs +179/−0
- src/Game/Goatee/Ui/Gtk/Tool/Null.hs +51/−0
- src/Game/Goatee/Ui/Gtk/Tool/Play.hs +119/−0
- src/Game/Goatee/Ui/Gtk/Tool/Visibility.hs +300/−0
- tests/Game/Goatee/Ui/Gtk/CommonTest.hs +31/−0
- tests/Test.hs +3/−1
goatee-gtk.cabal view
@@ -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 <bog@khumba.net> maintainer: Bryan Gardiner <bog@khumba.net> 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
src/Game/Goatee/Ui/Gtk.hs view
@@ -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 <b>Esc</b> focuses the board. When the board is focused, the following " +++ "keys are available:"+ , ""+ , "<b>Left:</b> Go up the tree one step."+ , "<b>Right:</b> Go down the tree one step."+ , "<b>Up:</b> Go to the previous variation."+ , "<b>Down:</b> Go to the next variation."+ , "<b>Home:</b> Go to the start of the game."+ , "<b>End:</b> Go to the end of the current variation."+ , "<b>Page Up:</b> Go up the tree 10 steps."+ , "<b>Page Down:</b> 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
src/Game/Goatee/Ui/Gtk/Actions.hs view
@@ -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 "<Control>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 "<Control>o"+ actionGroupAddAction fileActions fileOpenAction on fileOpenAction actionActivated $ fileOpen ui fileSaveAction <- actionNew "FileSave" "_Save file" Nothing Nothing- actionGroupAddActionWithAccel fileActions fileSaveAction $ Just "<Control>s"+ actionGroupAddAction fileActions fileSaveAction on fileSaveAction actionActivated $ void $ fileSave ui fileSaveAsAction <- actionNew "FileSaveAs" "Sa_ve file as..." Nothing Nothing- actionGroupAddActionWithAccel fileActions fileSaveAsAction $ Just "<Control><Shift>s"+ actionGroupAddAction fileActions fileSaveAsAction on fileSaveAsAction actionActivated $ void $ fileSaveAs ui fileCloseAction <- actionNew "FileClose" "_Close" Nothing Nothing- actionGroupAddActionWithAccel fileActions fileCloseAction $ Just "<Control>w"+ actionGroupAddAction fileActions fileCloseAction on fileCloseAction actionActivated $ void $ fileClose ui fileQuitAction <- actionNew "FileQuit" "_Quit" Nothing Nothing- actionGroupAddActionWithAccel fileActions fileQuitAction $ Just "<Control>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]
src/Game/Goatee/Ui/Gtk/Common.hs view
@@ -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
src/Game/Goatee/Ui/Gtk/Goban.hs view
@@ -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 ()
src/Game/Goatee/Ui/Gtk/MainWindow.hs view
@@ -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
src/Game/Goatee/Ui/Gtk/NodePropertiesPanel.hs view
@@ -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
src/Game/Goatee/Ui/Gtk/PlayPanel.hs view
@@ -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
+ src/Game/Goatee/Ui/Gtk/Tool.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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+ ]
+ src/Game/Goatee/Ui/Gtk/Tool/AssignStone.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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)
+ src/Game/Goatee/Ui/Gtk/Tool/Line.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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
+ src/Game/Goatee/Ui/Gtk/Tool/Mark.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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 }
+ src/Game/Goatee/Ui/Gtk/Tool/Null.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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+ }
+ src/Game/Goatee/Ui/Gtk/Tool/Play.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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
+ src/Game/Goatee/Ui/Gtk/Tool/Visibility.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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."+ , ""+ , "<b>" ++ show ModeInherited ++ ":</b> Points inherit their values from the parent " +++ "node. This is the default for all nodes."+ , "<b>" ++ show ModeReset ++ ":</b> This node resets all points to their default values."+ , "<b>" ++ show ModeAssigned ++ ":</b> 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 " +++ "<b>Copy</b> 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)
+ tests/Game/Goatee/Ui/Gtk/CommonTest.hs view
@@ -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 <http://www.gnu.org/licenses/>.++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)+ ]
tests/Test.hs view
@@ -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 ()