diff --git a/goatee-gtk.cabal b/goatee-gtk.cabal
--- a/goatee-gtk.cabal
+++ b/goatee-gtk.cabal
@@ -1,5 +1,5 @@
name: goatee-gtk
-version: 0.1.0
+version: 0.2.0
synopsis: A monadic take on a 2,500-year-old board game - GTK+ UI.
category: Game
license: AGPL-3
@@ -14,13 +14,11 @@
build-type: Simple
data-files: LICENSE
description:
- Goatee is a Go library and game editor, written in Haskell. It provides a GUI
- for recording, studying, and editing game records. Underneath this is a
- portable library for manipulating SGF files, to build UIs and tools.
- .
- Goatee, the library and GUI, aims to be full-featured, supporting all of the SGF
- spec and allowing for full customization of the game records you create.
- Currently it is in an alpha stage, supporting basic game viewing and editing.
+ Goatee is a Go library and game editor, written in Haskell. It provides a
+ GUI for recording, studying, and editing game records. Underneath this is a
+ portable library for manipulating SGF files to build UIs and tools. Goatee
+ aims to be full-featured by supporting all of the SGF spec and allowing for
+ full and easy customization of the game records you create.
.
This package is the GTK+ UI.
@@ -36,15 +34,18 @@
directory >= 1.1 && < 1.3,
filepath >= 1.3 && < 1.4,
gtk >= 0.12 && < 0.13,
- goatee >= 0.1 && < 0.2,
- mtl >= 2.1 && < 2.3
+ goatee >= 0.2 && < 0.3,
+ mtl >= 2.1 && < 2.3,
+ parsec >= 3.1 && < 3.2
exposed-modules:
Game.Goatee.Ui.Gtk
Game.Goatee.Ui.Gtk.Latch
extensions:
ExistentialQuantification
+ FlexibleContexts
FlexibleInstances
FunctionalDependencies
+ GeneralizedNewtypeDeriving
MultiParamTypeClasses
ScopedTypeVariables
ViewPatterns
@@ -57,7 +58,10 @@
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.Utils
+ Game.Goatee.Ui.Gtk.Widget
Paths_goatee_gtk
executable goatee-gtk
@@ -73,9 +77,7 @@
build-depends:
base >= 4 && < 5,
goatee-gtk,
- HUnit >= 1.2 && < 1.3,
- test-framework >= 0.6 && < 0.9,
- test-framework-hunit >= 0.2 && < 0.4
+ HUnit >= 1.2 && < 1.3
ghc-options: -W -fwarn-incomplete-patterns
hs-source-dirs: tests
main-is: Test.hs
diff --git a/src-exe/Main.hs b/src-exe/Main.hs
--- a/src-exe/Main.hs
+++ b/src-exe/Main.hs
@@ -25,8 +25,8 @@
main = do
args <- initGUI
if null args
- then void $ startNewBoard Nothing
- else do result <- startFile $ head args
+ then void (startNewBoard Nothing :: IO StdUiCtrlImpl)
+ else do result <- startFile $ head args :: IO (Either String StdUiCtrlImpl)
case result of
Left msg -> print msg
_ -> return ()
diff --git a/src/Game/Goatee/Ui/Gtk.hs b/src/Game/Goatee/Ui/Gtk.hs
--- a/src/Game/Goatee/Ui/Gtk.hs
+++ b/src/Game/Goatee/Ui/Gtk.hs
@@ -18,57 +18,74 @@
-- | The main module for the GTK+ UI, used by clients of the UI. Also
-- implements the UI controller.
module Game.Goatee.Ui.Gtk (
+ StdUiCtrlImpl,
startBoard,
startNewBoard,
startFile,
) where
+import Control.Applicative ((<$>), Applicative)
import Control.Concurrent.MVar (MVar, newMVar, takeMVar, readMVar, putMVar, modifyMVar, modifyMVar_)
import Control.Exception (IOException, catch, finally)
-import Control.Monad (forM_, join, liftM, unless, when)
+import Control.Monad (forM_, join, liftM, unless, void, when)
+import Control.Monad.State (MonadState, State, runState, get, put, modify)
+import Data.Char (isSpace)
+import qualified Data.Foldable as Foldable
import Data.Foldable (foldl')
import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (fromJust, fromMaybe, isJust, isNothing)
+import qualified Data.Set as Set
+import Data.Set (Set)
import Data.Unique (Unique, newUnique)
import Game.Goatee.App
import Game.Goatee.Common
-import Game.Goatee.Sgf.Board
-import Game.Goatee.Sgf.Renderer
-import Game.Goatee.Sgf.Renderer.Tree
-import Game.Goatee.Sgf.Tree
-import qualified Game.Goatee.Sgf.Monad as Monad
-import Game.Goatee.Sgf.Monad (Event, on, childAddedEvent, propertiesModifiedEvent)
+import Game.Goatee.Lib.Board
+import Game.Goatee.Lib.Parser
+import Game.Goatee.Lib.Renderer
+import Game.Goatee.Lib.Renderer.Tree
+import Game.Goatee.Lib.Tree
+import qualified Game.Goatee.Lib.Monad as Monad
+import Game.Goatee.Lib.Monad (
+ GoT, MonadGo, runGoT,
+ AnyEvent (..), on0, childAddedEvent, childDeletedEvent, propertiesModifiedEvent,
+ )
import Game.Goatee.Ui.Gtk.Common
import qualified Game.Goatee.Ui.Gtk.MainWindow as MainWindow
import Game.Goatee.Ui.Gtk.MainWindow (MainWindow)
import Graphics.UI.Gtk (
AttrOp ((:=)),
ButtonsType (ButtonsNone, ButtonsOk, ButtonsYesNo),
+ Clipboard,
DialogFlags (DialogDestroyWithParent, DialogModal),
FileChooserAction (FileChooserActionOpen, FileChooserActionSave),
MessageType (MessageError, MessageQuestion),
ResponseId (ResponseCancel, ResponseNo, ResponseOk, ResponseYes),
aboutDialogAuthors, aboutDialogCopyright, aboutDialogLicense, aboutDialogNew,
aboutDialogProgramName, aboutDialogWebsite,
+ clipboardGet, clipboardRequestText, clipboardSetText,
dialogAddButton, dialogRun,
fileChooserAddFilter, fileChooserDialogNew, fileChooserGetFilename,
mainQuit,
messageDialogNew,
+ selectionClipboard,
stockCancel, stockOpen, stockSave, stockSaveAs,
widgetDestroy, widgetHide,
set,
)
import qualified Paths_goatee_gtk as Paths
import System.Directory (doesFileExist)
+import System.IO (hPutStrLn, stderr)
+{-# ANN module "HLint: ignore Reduce duplication" #-}
+
-- | A structure for holding global application information about all open
-- boards.
-data AppState = AppState { appControllers :: MVar (Map CtrlId UiCtrlImpl)
- -- ^ Maps all of the open boards' controllers by
- -- their IDs.
- }
+data AppState = AppState
+ { appControllers :: MVar (Map CtrlId AnyUiCtrl)
+ -- ^ Maps all of the open boards' controllers by their IDs.
+ }
-- | Creates an 'AppState' that is holding no controllers.
newAppState :: IO AppState
@@ -77,77 +94,93 @@
return AppState { appControllers = controllers }
-- | Registers a 'UiCtrlImpl' with an 'AppState'.
-appStateRegister :: AppState -> UiCtrlImpl -> IO ()
+appStateRegister :: MonadUiGo go => AppState -> UiCtrlImpl go -> IO ()
appStateRegister appState ui =
- modifyMVar_ (appControllers appState) $ return . Map.insert (uiCtrlId ui) ui
+ modifyMVar_ (appControllers appState) $ return . Map.insert (uiCtrlId ui) (AnyUiCtrl ui)
-- | Unregisters a 'UiCtrlImpl' from an 'AppState'. If the 'AppState' is left
-- with no controllers, then the GTK+ main loop is shut down and the application
-- exits.
-appStateUnregister :: AppState -> UiCtrlImpl -> IO ()
+appStateUnregister :: AppState -> UiCtrlImpl go -> IO ()
appStateUnregister appState ui = do
ctrls' <- modifyMVar (appControllers appState) $ \ctrls ->
let ctrls' = Map.delete (uiCtrlId ui) ctrls
in return (ctrls', ctrls')
when (Map.null ctrls') mainQuit
-data UiHandler = forall handler. UiHandler String (Event UiGoM handler) handler
-
-data DirtyChangedHandlerRecord =
- DirtyChangedHandlerRecord { dirtyChangedHandlerOwner :: String
- , dirtyChangedHandlerFn :: DirtyChangedHandler
- }
+data DirtyChangedHandlerRecord = DirtyChangedHandlerRecord
+ { dirtyChangedHandlerOwner :: String
+ , dirtyChangedHandlerFn :: DirtyChangedHandler
+ }
-data FilePathChangedHandlerRecord =
- FilePathChangedHandlerRecord { filePathChangedHandlerOwner :: String
- , filePathChangedHandlerFn :: FilePathChangedHandler
- }
+data FilePathChangedHandlerRecord = FilePathChangedHandlerRecord
+ { filePathChangedHandlerOwner :: String
+ , filePathChangedHandlerFn :: FilePathChangedHandler
+ }
-data ModesChangedHandlerRecord =
- ModesChangedHandlerRecord { modesChangedHandlerOwner :: String
- , modesChangedHandlerFn :: ModesChangedHandler
- }
+data ModesChangedHandlerRecord = ModesChangedHandlerRecord
+ { modesChangedHandlerOwner :: String
+ , modesChangedHandlerFn :: ModesChangedHandler
+ }
-- | A unique ID that identifies a 'UiCtrlImpl'.
newtype CtrlId = CtrlId Unique
deriving (Eq, Ord)
--- | Implementation of 'UiCtrl'.
-data UiCtrlImpl = UiCtrlImpl { uiCtrlId :: CtrlId
- , uiAppState :: AppState
- , uiDirty :: IORef Bool
- , uiFilePath :: IORef (Maybe FilePath)
- , uiModes :: IORef UiModes
- , uiCursor :: MVar Cursor
+-- | The standard instance of 'MonadUiGo', with no frills.
+newtype UiGoM a = UiGoM (GoT (State UiGoState) a)
+ deriving (Functor, Applicative, Monad, MonadGo, MonadState UiGoState)
- , uiMainWindow :: IORef (Maybe (MainWindow UiCtrlImpl))
+instance MonadUiGo UiGoM where
+ runUiGo cursor (UiGoM go) =
+ let ((value, cursor'), state) = flip runState initialUiGoState $
+ runGoT go cursor
+ in (value, cursor', state)
- -- Go monad action-related properties:
- , uiHandlers :: IORef (Map Registration UiHandler)
- , uiBaseAction :: IORef (UiGoM ())
+ uiGoGetState = get
+ uiGoPutState = put
+ uiGoModifyState = modify
- -- Ui action-related properties:
- , uiDirtyChangedHandlers ::
- IORef (Map Registration DirtyChangedHandlerRecord)
- , uiFilePathChangedHandlers ::
- IORef (Map Registration FilePathChangedHandlerRecord)
- , uiModesChangedHandlers ::
- IORef (Map Registration ModesChangedHandlerRecord)
- }
+-- | The standard instance of 'UiCtrl'. See 'StdUiCtrlImpl'.
+data UiCtrlImpl go = UiCtrlImpl
+ { uiCtrlId :: CtrlId
+ , uiAppState :: AppState
+ , uiDirty :: IORef Bool
+ , uiFilePath :: IORef (Maybe FilePath)
+ , uiModes :: IORef UiModes
+ , uiCursor :: MVar Cursor
-instance UiCtrl UiCtrlImpl where
+ , uiMainWindow :: IORef (Maybe (MainWindow (UiCtrlImpl go)))
+ , uiViews :: IORef (Map ViewId AnyView)
+
+ -- Go monad action-related properties:
+ , uiGoRegistrationsByView :: IORef (Map AnyView (Set (AnyEvent go)))
+ , uiGoRegistrationsByEvent :: IORef (Map (AnyEvent go) (Set AnyView))
+ , uiGoRegistrationsAction :: IORef (go ())
+
+ -- Ui action-related properties:
+ , uiDirtyChangedHandlers :: IORef (Map Registration DirtyChangedHandlerRecord)
+ , uiFilePathChangedHandlers :: IORef (Map Registration FilePathChangedHandlerRecord)
+ , uiModesChangedHandlers :: IORef (Map Registration ModesChangedHandlerRecord)
+ }
+
+-- | The standard concrete controller type. Use this type with 'startBoard',
+-- etc.
+type StdUiCtrlImpl = UiCtrlImpl UiGoM
+
+instance MonadUiGo go => UiCtrl go (UiCtrlImpl go) where
readModes = readIORef . uiModes
modifyModes ui f = do
oldModes <- readModes ui
newModes <- f oldModes
- unless (newModes == oldModes) $ do
+ when (newModes /= oldModes) $ do
writeIORef (uiModes ui) newModes
fireModesChangedHandlers ui oldModes newModes
- runUiGo ui go = do
+ doUiGo ui go = do
cursor <- takeMVar (uiCursor ui)
- runUiGo' ui go cursor
+ doUiGo' ui go cursor
readCursor = readMVar . uiCursor
@@ -155,40 +188,44 @@
cursor <- readMVar $ uiCursor ui
return $ isCurrentValidMove (cursorBoard cursor) coord
- playAt ui coord = do
+ playAt ui move = do
cursor <- takeMVar $ uiCursor ui
- if not $ isCurrentValidMove (cursorBoard cursor) coord
+ let valid = case move of
+ Nothing -> True
+ Just coord -> isCurrentValidMove (cursorBoard cursor) coord
+ if not valid
then do
- dialog <- messageDialogNew Nothing
+ putMVar (uiCursor ui) cursor
+ mainWindow <- getMainWindow ui
+ dialog <- messageDialogNew (Just mainWindow)
[DialogModal, DialogDestroyWithParent]
MessageError
ButtonsOk
"Illegal move."
dialogRun dialog
widgetDestroy dialog
- putMVar (uiCursor ui) cursor
- else case cursorChildPlayingAt coord cursor of
- Just child -> runUiGo' ui (Monad.goDown $ cursorChildIndex child) cursor
+ else case cursorChildPlayingAt move cursor of
+ Just child -> doUiGo' ui (Monad.goDown $ cursorChildIndex child) cursor
Nothing ->
let board = cursorBoard cursor
player = boardPlayerTurn board
index = length $ cursorChildren cursor
- child = emptyNode { nodeProperties = [colorToMove player coord] }
- in runUiGo' ui (Monad.addChild index child >> Monad.goDown index) cursor
+ child = emptyNode { nodeProperties = [moveToProperty player move] }
+ in doUiGo' ui (Monad.addChildAt index child >> Monad.goDown index) cursor
- goUp ui = runUiGo ui $ do
+ goUp ui = doUiGo ui $ do
cursor <- Monad.getCursor
if isNothing $ cursorParent cursor
then return False
else Monad.goUp >> return True
- goDown ui index = runUiGo ui $ do
+ 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 = runUiGo ui $ do
+ goLeft ui = doUiGo ui $ do
cursor <- Monad.getCursor
case (cursorParent cursor, cursorChildIndex cursor) of
(Nothing, _) -> return False
@@ -197,7 +234,7 @@
Monad.goDown $ n - 1
return True
- goRight ui = runUiGo ui $ do
+ goRight ui = doUiGo ui $ do
cursor <- Monad.getCursor
case (cursorParent cursor, cursorChildIndex cursor) of
(Nothing, _) -> return False
@@ -206,26 +243,77 @@
Monad.goDown $ n + 1
return True
- register ui caller event handler = do
- unique <- newUnique
- modifyIORef (uiHandlers ui) $ Map.insert unique $ UiHandler caller event handler
- modifyIORef (uiBaseAction ui) (>> on event handler)
- return unique
+ register view events = do
+ let ui = viewCtrl view
+ view' = AnyView view
- unregister ui unique = do
- handlers <- readIORef $ uiHandlers ui
- let (handlers', found) = if Map.member unique handlers
- then (Map.delete unique handlers, True)
- else (handlers, False)
- when found $ do
- writeIORef (uiHandlers ui) handlers'
- rebuildBaseAction ui
- return found
+ -- Ensure that the view is in the controller's id -> view map.
+ modifyIORef (uiViews ui) $ \views ->
+ if Map.member (viewId view) views
+ then views
+ else Map.insert (viewId view) view' views
+ -- Go ahead and connect the event to the view.
+ byView <- readIORef $ uiGoRegistrationsByView ui
+ byEvent <- readIORef $ uiGoRegistrationsByEvent ui
+ let duplicates = Map.member view' byView
+ when duplicates $
+ uiLogWarning $ "UiCtrlImpl.register: A " ++ viewName view ++
+ " view registered multiple times. Overwriting previous registration(s)."
+ writeIORef (uiGoRegistrationsByView ui) $
+ Map.alter (Just .
+ (flip .) foldr Set.insert events .
+ fromMaybe Set.empty)
+ view'
+ byView
+ writeIORef (uiGoRegistrationsByEvent ui) $
+ foldr (Map.alter $ Just . maybe (Set.singleton view')
+ (Set.insert view'))
+ byEvent
+ events
+ -- TODO Don't need to fully rebuild the action. We can append to it.
+ rebuildGoRegistrationsAction ui
+
+ unregister view event = do
+ let ui = viewCtrl view
+ view' = AnyView view
+ byView <- readIORef $ uiGoRegistrationsByView ui
+ byEvent <- readIORef $ uiGoRegistrationsByEvent ui
+ let byView' = Map.update (\events ->
+ let events' = Set.delete event events
+ in if Set.null events' then Nothing else Just events')
+ view'
+ byView
+ byEvent' = Map.update (\views ->
+ let views' = Set.delete view' views
+ in if Set.null views' then Nothing else Just views')
+ event
+ byEvent
+ writeIORef (uiGoRegistrationsByView ui) byView'
+ writeIORef (uiGoRegistrationsByEvent ui) byEvent'
+
+ -- If there are no more events registered for the view, then remove it from
+ -- the list of known views.
+ when (isNothing $ Map.lookup view' byView') $
+ modifyIORef (uiViews ui) $ Map.delete $ viewId view
+
+ rebuildGoRegistrationsAction ui
+ return $ maybe False (Set.member event) (Map.lookup view' byView) ||
+ maybe False (Set.member view') (Map.lookup event byEvent)
+
+ unregisterAll view =
+ let ui = viewCtrl view
+ in readIORef (uiGoRegistrationsByView ui) >>=
+ Foldable.mapM_ (mapM_ (unregister view) . Set.elems) .
+ Map.lookup (AnyView view)
+
registeredHandlers =
- liftM (map (\(UiHandler owner event _) -> (owner, show event)) . Map.elems) .
+ fmap (concatMap (\(view, events) ->
+ let viewStr = show view
+ in for (Set.elems events) $ \event -> (viewStr, show event)) .
+ Map.assocs) .
readIORef .
- uiHandlers
+ uiGoRegistrationsByView
registerModesChangedHandler ui owner handler = do
unique <- newUnique
@@ -256,8 +344,10 @@
modesVar <- newIORef defaultUiModes
cursorVar <- newMVar $ rootCursor rootNode
mainWindowRef <- newIORef Nothing
- uiHandlers <- newIORef Map.empty
- baseAction <- newIORef $ return ()
+ views <- newIORef Map.empty
+ goRegistrationsByView <- newIORef Map.empty
+ goRegistrationsByEvent <- newIORef Map.empty
+ goRegistrationsAction <- newIORef $ return ()
dirtyChangedHandlers <- newIORef Map.empty
filePathChangedHandlers <- newIORef Map.empty
modesChangedHandlers <- newIORef Map.empty
@@ -269,15 +359,17 @@
, uiModes = modesVar
, uiCursor = cursorVar
, uiMainWindow = mainWindowRef
- , uiHandlers = uiHandlers
- , uiBaseAction = baseAction
+ , uiViews = views
+ , uiGoRegistrationsByView = goRegistrationsByView
+ , uiGoRegistrationsByEvent = goRegistrationsByEvent
+ , uiGoRegistrationsAction = goRegistrationsAction
, uiDirtyChangedHandlers = dirtyChangedHandlers
, uiFilePathChangedHandlers = filePathChangedHandlers
, uiModesChangedHandlers = modesChangedHandlers
}
appStateRegister appState ui
- rebuildBaseAction ui
+ rebuildGoRegistrationsAction ui
mainWindow <- MainWindow.create ui
writeIORef mainWindowRef $ Just mainWindow
@@ -362,15 +454,56 @@
fileClose ui = do
close <- confirmFileClose ui
- when close $ closeBoard ui
+ when close $ fileCloseSilently ui
return close
+ fileCloseSilently ui = do
+ MainWindow.destroy =<< getMainWindow' ui
+ appStateUnregister (uiAppState ui) ui
+
fileQuit ui = do
ctrls <- fmap Map.elems $ readMVar $ appControllers $ uiAppState ui
- okayToClose <- andM $ map confirmFileClose ctrls
- when okayToClose $ mapM_ closeBoard ctrls
+ okayToClose <- andM $ for ctrls $ \(AnyUiCtrl ctrl) -> confirmFileClose ctrl
+ when okayToClose $ forM_ ctrls $ \(AnyUiCtrl ctrl) -> fileCloseSilently ctrl
return okayToClose
+ editCutNode ui = do
+ initialCursor <- readCursor ui
+ case cursorParent initialCursor of
+ Nothing -> uiLogWarning "UiCtrlImpl.editCutNode: Can't cut the root node."
+ Just _ -> do
+ success <- editCopyNode' ui
+ when success $ doUiGo ui $ do
+ cursor <- Monad.getCursor
+ when (isJust $ cursorParent cursor) $ do
+ let index = cursorChildIndex cursor
+ Monad.goUp
+ Monad.deleteChildAt index
+ return ()
+
+ editCopyNode = void . editCopyNode'
+
+ editPasteNode ui = do
+ clipboard <- getClipboard
+ clipboardRequestText clipboard $ \maybeText -> case maybeText of
+ Nothing -> return ()
+ Just text -> unless (null text || all isSpace text) $ do
+ rootInfo <- gameInfoRootInfo . boardGameInfo . cursorBoard <$> readCursor ui
+ case parseSubtree rootInfo text of
+ Left error -> do
+ let (textBeginning, textRest) = splitAt 500 text
+ mainWindow <- getMainWindow ui
+ dialog <- messageDialogNew (Just mainWindow)
+ [DialogModal, DialogDestroyWithParent]
+ MessageError
+ ButtonsOk
+ ("Unable to parse the clipboard as an SGF game tree.\n\nError: " ++
+ error ++ "\n\nInput:\n" ++ textBeginning ++
+ if not $ null textRest then "\n(truncated)" else "")
+ dialogRun dialog
+ widgetDestroy dialog
+ Right node -> doUiGo ui $ Monad.addChild node
+
helpAbout _ = do
about <- aboutDialogNew
license <- fmap (fromMaybe fallbackLicense) readLicense
@@ -419,7 +552,7 @@
setDirty ui newDirty = do
oldDirty <- readIORef $ uiDirty ui
- unless (oldDirty == newDirty) $ do
+ when (newDirty /= oldDirty) $ do
writeIORef (uiDirty ui) newDirty
handlers <- readIORef $ uiDirtyChangedHandlers ui
forM_ (map dirtyChangedHandlerFn $ Map.elems handlers) ($ newDirty)
@@ -446,43 +579,53 @@
registeredDirtyChangedHandlers =
liftM (map dirtyChangedHandlerOwner . Map.elems) . readIORef . uiDirtyChangedHandlers
--- | 'runUiGo' for 'UiCtrlImpl' is implemented by taking the cursor MVar,
--- running a Go action, putting the MVar, then running handlers. Many types of
+-- | 'doUiGo' for 'UiCtrlImpl' is implemented by taking the cursor MVar, running
+-- a Go action, putting the MVar, then running follow-up tasks. Many types of
-- actions the UI wants to perform need to be able to take the cursor
-- themselves, do some logic, then pass it off to run a Go action, re-put, and
--- call handlers. This function is a helper for such UI code.
-runUiGo' :: UiCtrlImpl -> UiGoM a -> Cursor -> IO a
-runUiGo' ui go cursor = do
- baseAction <- readIORef $ uiBaseAction ui
- let (value, cursor', handlers) = runUiGoPure (baseAction >> go) cursor
+-- perform subsequent UI tasks. This function is a helper for such UI code.
+doUiGo' :: MonadUiGo go => UiCtrlImpl go -> go a -> Cursor -> IO a
+doUiGo' ui go cursor = do
+ goRegistrationsAction <- readIORef $ uiGoRegistrationsAction ui
+ let (value, cursor', state) = runUiGo cursor (goRegistrationsAction >> go)
+ staleViews = uiGoViewsToUpdate state
putMVar (uiCursor ui) cursor'
- handlers
+ when (uiGoMakesDirty state) $ setDirty ui True
+ unless (Set.null staleViews) $ do
+ viewMap <- readIORef $ uiViews ui
+ forM_ (Set.elems staleViews) $ \viewId -> case Map.lookup viewId viewMap of
+ Just (AnyView view) -> viewUpdate view
+ Nothing -> uiLogWarning "doUiGo': Asked to update an unknown view."
return value
-startBoard :: Node -> IO UiCtrlImpl
+startBoard :: MonadUiGo go => Node -> IO (UiCtrlImpl go)
startBoard = openBoard Nothing Nothing
-startNewBoard :: Maybe (Int, Int) -> IO UiCtrlImpl
+startNewBoard :: MonadUiGo go => Maybe (Int, Int) -> IO (UiCtrlImpl go)
startNewBoard = openNewBoard Nothing
-startFile :: FilePath -> IO (Either String UiCtrlImpl)
+startFile :: MonadUiGo go => FilePath -> IO (Either String (UiCtrlImpl go))
startFile = openFile Nothing
-rebuildBaseAction :: UiCtrlImpl -> IO ()
-rebuildBaseAction ui =
- readIORef (uiHandlers ui) >>= writeIORef (uiBaseAction ui) . buildBaseAction
- where buildBaseAction =
- foldl' (\io (UiHandler _ event handler) -> io >> on event handler)
- commonAction
+rebuildGoRegistrationsAction :: MonadUiGo go => UiCtrlImpl go -> IO ()
+rebuildGoRegistrationsAction ui =
+ readIORef (uiGoRegistrationsByEvent ui) >>=
+ writeIORef (uiGoRegistrationsAction ui) . buildAction
+ where buildAction =
+ foldl' (\m (AnyEvent event, views) ->
+ m >> on0 event (forM_ (Set.elems views) $ \(AnyView view) ->
+ uiGoUpdateView $ viewId view))
+ commonAction .
+ Map.assocs
commonAction = do
-- TODO This really calls for some sort of event hierarchy, so
-- that we can listen for all mutating events here, rather than
-- making it easy to forget to add new events here.
- on childAddedEvent $ \_ _ -> setDirtyTrue
- on propertiesModifiedEvent $ \_ _ -> setDirtyTrue
- setDirtyTrue = afterGo $ setDirty ui True
+ on0 childAddedEvent uiGoMakeDirty
+ on0 childDeletedEvent uiGoMakeDirty
+ on0 propertiesModifiedEvent uiGoMakeDirty
-fireModesChangedHandlers :: UiCtrlImpl -> UiModes -> UiModes -> IO ()
+fireModesChangedHandlers :: UiCtrlImpl go -> UiModes -> UiModes -> IO ()
fireModesChangedHandlers ui oldModes newModes = do
handlers <- readIORef $ uiModesChangedHandlers ui
forM_ (Map.elems handlers) $ \handler ->
@@ -490,7 +633,7 @@
-- | Retrieves the 'MainWindow' owned by the controller. It is an error to call
-- this before the main window has been set up.
-getMainWindow' :: UiCtrlImpl -> IO (MainWindow UiCtrlImpl)
+getMainWindow' :: UiCtrlImpl go -> IO (MainWindow (UiCtrlImpl go))
getMainWindow' ui = join $
fmap (maybe (fail "getMainWindow: No window available.") return) $
readIORef $
@@ -518,7 +661,7 @@
-- state of UI; if dirty, then a dialog prompts the user whether the game
-- should be saved before closing, and giving the option to cancel closing.
-- Returns true if the window should be closed.
-confirmFileClose :: UiCtrl ui => ui -> IO Bool
+confirmFileClose :: UiCtrl go ui => ui -> IO Bool
confirmFileClose ui = do
dirty <- getDirty ui
if dirty
@@ -542,14 +685,32 @@
_ -> return False
else return True
--- | Hides and releases the game's 'Game.Goatee.Ui.Gtk.MainWindow', and shuts
--- down the UI controller (in effect closing the game, with no prompting). If
--- this is the last board open, then the application will exit.
-closeBoard :: UiCtrlImpl -> IO ()
-closeBoard ui = do
- MainWindow.destroy =<< getMainWindow' ui
- appStateUnregister (uiAppState ui) ui
+-- | Attempts to copy the current node to the clipboard. Returns true if
+-- successful. If not, this presents a model dialog describing the error, waits
+-- for the user to click through, then returns false.
+editCopyNode' :: MonadUiGo go => UiCtrlImpl go -> IO Bool
+editCopyNode' ui = do
+ clipboard <- getClipboard
+ cursor <- readCursor ui
+ case runRender $ renderGameTree $ cursorNode cursor of
+ Right sgf -> do
+ clipboardSetText clipboard sgf
+ return True
+ Left error -> do
+ mainWindow <- getMainWindow ui
+ dialog <- messageDialogNew (Just mainWindow)
+ [DialogModal, DialogDestroyWithParent]
+ MessageError
+ ButtonsOk
+ ("Error rendering node for copy:\n\n" ++ error)
+ dialogRun dialog
+ widgetDestroy dialog
+ return False
+-- | Returns the clipboard we'll use for explicit cut/copy/paste actions.
+getClipboard :: IO Clipboard
+getClipboard = clipboardGet selectionClipboard
+
-- | Attempts to read the project's license file. If successful, the license is
-- returend, otherwise a fallback message is returned instead.
readLicense :: IO (Maybe String)
@@ -573,3 +734,7 @@
"\n" ++
"\nYou should have received a copy of the GNU Affero General Public License" ++
"\nalong with Goatee. If not, see ."
+
+-- | Logs a warning to stderr.
+uiLogWarning :: String -> IO ()
+uiLogWarning msg = hPutStrLn stderr $ applicationName ++ " WARNING: " ++ msg
diff --git a/src/Game/Goatee/Ui/Gtk/Actions.hs b/src/Game/Goatee/Ui/Gtk/Actions.hs
--- a/src/Game/Goatee/Ui/Gtk/Actions.hs
+++ b/src/Game/Goatee/Ui/Gtk/Actions.hs
@@ -29,22 +29,31 @@
myFileSaveAsAction,
myFileCloseAction,
myFileQuitAction,
+ myEditCutNodeAction,
+ myEditCopyNodeAction,
+ myEditPasteNodeAction,
+ myGamePassAction,
+ myGameVariationsChildAction,
+ myGameVariationsCurrentAction,
+ myGameVariationsBoardMarkupOnAction,
+ myGameVariationsBoardMarkupOffAction,
myToolActions,
- myViewVariationsChildAction,
- myViewVariationsCurrentAction,
- myViewVariationsBoardMarkupOnAction,
- myViewVariationsBoardMarkupOffAction,
myViewHighlightCurrentMovesAction,
+ myViewStonesRegularModeAction,
+ myViewStonesOneColorModeAction,
+ myViewStonesBlindModeAction,
myHelpAboutAction,
) where
import Control.Applicative ((<$>))
-import Control.Monad (void, when)
-import Data.Maybe (fromMaybe)
+import Control.Monad (unless, void, when)
+import Data.Maybe (fromMaybe, isJust)
import Game.Goatee.Ui.Gtk.Common
-import Game.Goatee.Sgf.Board
-import Game.Goatee.Sgf.Monad hiding (on)
-import Game.Goatee.Sgf.Types
+import Game.Goatee.Ui.Gtk.Utils
+import Game.Goatee.Lib.Board
+import Game.Goatee.Lib.Monad hiding (on)
+import Game.Goatee.Lib.Property
+import Game.Goatee.Lib.Types
import Graphics.UI.Gtk (
Action,
ActionGroup,
@@ -60,7 +69,7 @@
SpinButtonUpdatePolicy (UpdateIfValid),
ToggleAction,
actionActivate, actionActivated, actionGroupAddActionWithAccel, actionGroupAddRadioActions,
- actionGroupGetAction, actionGroupNew, actionNew, actionToggled,
+ actionGroupGetAction, actionGroupNew, actionNew, actionSensitive, actionToggled,
boxPackStart,
dialogAddButton, dialogGetUpper, dialogNew, dialogRun, dialogSetDefaultResponse,
get,
@@ -68,40 +77,50 @@
on,
radioActionChanged, radioActionCurrentValue, radioActionNew, radioActionSetGroup,
set,
- spinButtonGetValueAsInt, spinButtonNewWithRange, spinButtonSetNumeric, spinButtonSetUpdatePolicy,
- spinButtonSetValue, spinButtonSetWrap,
+ spinButtonGetValueAsInt, spinButtonNewWithRange, spinButtonSetDigits,
+ spinButtonSetNumeric, spinButtonSetUpdatePolicy, spinButtonSetValue, spinButtonSetWrap,
stockCancel,
tableAttachDefaults, tableNew,
toggleActionActive, toggleActionNew,
widgetDestroy, widgetShowAll,
+ windowSetTitle,
)
-data Actions ui = Actions { myUi :: ui
- , myRegistrations :: ViewRegistrations
- , myFileNew9Action :: Action
- , myFileNew13Action :: Action
- , myFileNew19Action :: Action
- , myFileNewCustomAction :: Action
- , myFileOpenAction :: Action
- , myFileSaveAction :: Action
- , myFileSaveAsAction :: Action
- , myFileCloseAction :: Action
- , myFileQuitAction :: Action
- , myToolActions :: ActionGroup
- , myViewVariationsChildAction :: RadioAction
- , myViewVariationsCurrentAction :: RadioAction
- , myViewVariationsBoardMarkupOnAction :: RadioAction
- , myViewVariationsBoardMarkupOffAction :: RadioAction
- , myViewHighlightCurrentMovesAction :: ToggleAction
- , myHelpAboutAction :: Action
- }
+data Actions ui = Actions
+ { myUi :: ui
+ , myState :: ViewState
+ , myFileNew9Action :: Action
+ , myFileNew13Action :: Action
+ , myFileNew19Action :: Action
+ , myFileNewCustomAction :: Action
+ , myFileOpenAction :: Action
+ , myFileSaveAction :: Action
+ , myFileSaveAsAction :: Action
+ , myFileCloseAction :: Action
+ , myFileQuitAction :: Action
+ , myEditCutNodeAction :: Action
+ , myEditCopyNodeAction :: Action
+ , myEditPasteNodeAction :: Action
+ , myGamePassAction :: Action
+ , myGameVariationsChildAction :: RadioAction
+ , myGameVariationsCurrentAction :: RadioAction
+ , myGameVariationsBoardMarkupOnAction :: RadioAction
+ , myGameVariationsBoardMarkupOffAction :: RadioAction
+ , myToolActions :: ActionGroup
+ , myViewHighlightCurrentMovesAction :: ToggleAction
+ , myViewStonesRegularModeAction :: RadioAction
+ , myViewStonesOneColorModeAction :: RadioAction
+ , myViewStonesBlindModeAction :: RadioAction
+ , myHelpAboutAction :: Action
+ }
-instance UiCtrl ui => UiView (Actions ui) ui where
+instance UiCtrl go ui => UiView go ui (Actions ui) where
viewName = const "Actions"
viewCtrl = myUi
- viewRegistrations = myRegistrations
+ viewState = myState
+ viewUpdate = update
-create :: UiCtrl ui => ui -> IO (Actions ui)
+create :: UiCtrl go ui => ui -> IO (Actions ui)
create ui = do
let tools = enumFrom minBound
modes <- readModes ui
@@ -125,23 +144,26 @@
actionGroupAddActionWithAccel fileActions fileNewCustomAction Nothing
on fileNewCustomAction actionActivated $ do
dialog <- dialogNew
+ windowSetTitle dialog "New custom board"
upper <- dialogGetUpper dialog
- table <- tableNew 2 2 False
+ table <- tableNew 4 2 False
boxPackStart upper table PackGrow 0
-- SGF only supports boards up to 'boardSizeMax', but Goatee works fine with
-- larger boards. The spinner wants an upper bound, so let's at least set
-- something that isn't too outrageous along a single dimension.
- let arbitraryUpperLimit = 1000
+ let arbitraryUpperLimit = 1000 :: Int
makeSpinButton = do
spin <- spinButtonNewWithRange
(fromIntegral boardSizeMin)
(fromIntegral arbitraryUpperLimit)
1
+ configureSpinButton spin
+ return spin
+ configureSpinButton spin = do
spinButtonSetUpdatePolicy spin UpdateIfValid
spinButtonSetNumeric spin True
spinButtonSetWrap spin False
- return spin
widthLabel <- labelNewWithMnemonic "_Width"
widthSpin <- makeSpinButton
@@ -155,6 +177,22 @@
tableAttachDefaults table heightLabel 0 1 1 2
tableAttachDefaults table heightSpin 1 2 1 2
+ handicapLabel <- labelNewWithMnemonic "H_andicap"
+ handicapSpin <- spinButtonNewWithRange 0 9 1
+ labelSetMnemonicWidget handicapLabel handicapSpin
+ configureSpinButton handicapSpin
+ tableAttachDefaults table handicapLabel 0 1 2 3
+ tableAttachDefaults table handicapSpin 1 2 2 3
+
+ komiLabel <- labelNewWithMnemonic "_Komi"
+ komiSpin <- spinButtonNewWithRange (-1000) 1000 0.5
+ labelSetMnemonicWidget komiLabel komiSpin
+ configureSpinButton komiSpin
+ spinButtonSetDigits komiSpin 1
+ spinButtonSetValue komiSpin 0
+ tableAttachDefaults table komiLabel 0 1 3 4
+ tableAttachDefaults table komiSpin 1 2 3 4
+
dialogAddButton dialog stockCancel ResponseCancel
dialogAddButton dialog "C_reate" ResponseOk
dialogSetDefaultResponse dialog ResponseOk
@@ -166,9 +204,25 @@
response <- dialogRun dialog
width <- spinButtonGetValueAsInt widthSpin
height <- spinButtonGetValueAsInt heightSpin
+ handicap <- spinButtonGetValueAsInt handicapSpin
+ komi <- spinButtonGetValueAsBigfloat komiSpin
widgetDestroy dialog
- when (response == ResponseOk) $
- void $ openNewBoard (Just ui) (Just (width, height))
+ when (response == ResponseOk) $ do
+ ui' <- openNewBoard (Just ui) (Just (width, height))
+ when (komi /= 0) $ doUiGo ui' $ putProperty $ KM komi
+ when (handicap > 0) $ do
+ -- If the board size + handicap configuration is known, then set up the
+ -- board for the handicap, otherwise, leave the user to do it.
+ --
+ -- TODO If the configuration is unknown and handicap >= 2, then maybe
+ -- set HA at least, anyway?
+ let stones = fromMaybe [] $ handicapStones width height handicap
+ unless (null stones) $ do
+ doUiGo ui' $ do
+ putProperty $ HA handicap
+ putProperty $ AB $ coords stones
+ putProperty $ PL White
+ setDirty ui' False
fileOpenAction <- actionNew "FileOpen" "_Open file..." Nothing Nothing
actionGroupAddActionWithAccel fileActions fileOpenAction $ Just "o"
@@ -190,63 +244,77 @@
actionGroupAddActionWithAccel fileActions fileQuitAction $ Just "q"
on fileQuitAction actionActivated $ void $ fileQuit ui
- -- 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)
- (\radioAction -> setTool ui =<< fmap toEnum (get radioAction radioActionCurrentValue))
+ -- Edit actions.
+ editCutNodeAction <- actionNew "EditCutNode" "Cut current node" Nothing Nothing
+ on editCutNodeAction actionActivated $ editCutNode ui
- -- Variation mode view actions.
- viewVariationsChildAction <- radioActionNew "viewVariationsChild"
+ editCopyNodeAction <- actionNew "EditCopyNode" "Copy current node" Nothing Nothing
+ on editCopyNodeAction actionActivated $ editCopyNode ui
+
+ editPasteNodeAction <- actionNew "EditPasteNode" "Paste node as child" Nothing Nothing
+ on editPasteNodeAction actionActivated $ editPasteNode ui
+
+ -- Game actions.
+ gamePassAction <- actionNew "GamePass" "_Pass" Nothing Nothing
+ on gamePassAction actionActivated $ playAt ui Nothing
+
+ gameVariationsChildAction <- radioActionNew "gameVariationsChild"
"_Child variations"
(Just "Show children node as variations")
Nothing
(fromEnum ShowChildVariations)
- viewVariationsCurrentAction <- radioActionNew "viewVariationsCurrent"
+ gameVariationsCurrentAction <- radioActionNew "gameVariationsCurrent"
"C_urrent variations"
(Just "Show variations of the current node")
Nothing
(fromEnum ShowCurrentVariations)
- radioActionSetGroup viewVariationsChildAction viewVariationsCurrentAction
+ radioActionSetGroup gameVariationsChildAction gameVariationsCurrentAction
- viewVariationsBoardMarkupOnAction <- radioActionNew "viewVariationsBoardMarkupOn"
+ gameVariationsBoardMarkupOnAction <- radioActionNew "gameVariationsBoardMarkupOn"
"_Show on board"
(Just "Show move variations on the board")
Nothing
(fromEnum True)
- viewVariationsBoardMarkupOffAction <- radioActionNew "viewVariationsBoardMarkupOn"
+ gameVariationsBoardMarkupOffAction <- radioActionNew "gameVariationsBoardMarkupOn"
"_Hide on board"
(Just "Hide move variations on the board")
Nothing
(fromEnum False)
- radioActionSetGroup viewVariationsBoardMarkupOnAction viewVariationsBoardMarkupOffAction
+ radioActionSetGroup gameVariationsBoardMarkupOnAction gameVariationsBoardMarkupOffAction
initialVariationMode <-
rootInfoVariationMode . gameInfoRootInfo . boardGameInfo . cursorBoard <$>
readCursor ui
- set viewVariationsChildAction
+ set gameVariationsChildAction
[radioActionCurrentValue := fromEnum (variationModeSource initialVariationMode)]
- set viewVariationsBoardMarkupOnAction
+ set gameVariationsBoardMarkupOnAction
[radioActionCurrentValue := fromEnum (variationModeBoardMarkup initialVariationMode)]
-- This signal is emitted on every action in a radio group when the active
-- item is changed, so we only need to listen with one action.
- on viewVariationsChildAction radioActionChanged $ \action -> do
+ on gameVariationsChildAction radioActionChanged $ \action -> do
value <- toEnum <$> get action radioActionCurrentValue
- runUiGo ui $ modifyVariationMode $ \mode -> mode { variationModeSource = value }
+ doUiGo ui $ modifyVariationMode $ \mode -> mode { variationModeSource = value }
- on viewVariationsBoardMarkupOnAction radioActionChanged $ \action -> do
+ on gameVariationsBoardMarkupOnAction radioActionChanged $ \action -> do
value <- toEnum <$> get action radioActionCurrentValue
- runUiGo ui $ modifyVariationMode $ \mode -> mode { variationModeBoardMarkup = value }
+ doUiGo ui $ modifyVariationMode $ \mode -> mode { variationModeBoardMarkup = value }
+ -- 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)
+ (\radioAction -> setTool ui =<< fmap toEnum (get radioAction radioActionCurrentValue))
+
+ -- View actions.
viewHighlightCurrentMovesAction <-
toggleActionNew "ViewHighlightCurrentMoves" "Highlight _current moves" Nothing Nothing
set viewHighlightCurrentMovesAction [toggleActionActive := uiHighlightCurrentMovesMode modes]
@@ -254,6 +322,35 @@
active <- get viewHighlightCurrentMovesAction toggleActionActive
modifyModes ui $ \modes -> return modes { uiHighlightCurrentMovesMode = active }
+ viewStonesRegularModeAction <-
+ radioActionNew "ViewStonesRegularMode"
+ "_Regular"
+ (Just "Regular Go: Render stones on the board normally.")
+ Nothing
+ (fromEnum ViewStonesRegularMode)
+ viewStonesOneColorModeAction <-
+ radioActionNew "ViewStonesOneColorMode"
+ "_One-color"
+ (Just "One-color Go: Both players use the same color stones.")
+ Nothing
+ (fromEnum ViewStonesOneColorMode)
+ viewStonesBlindModeAction <-
+ radioActionNew "ViewStonesBlindMode"
+ "_Blind"
+ (Just "Blind Go: No stones are visible on the board.")
+ Nothing
+ (fromEnum ViewStonesBlindMode)
+
+ radioActionSetGroup viewStonesOneColorModeAction viewStonesRegularModeAction
+ radioActionSetGroup viewStonesBlindModeAction viewStonesRegularModeAction
+ initialViewStonesMode <- uiViewStonesMode <$> readModes ui
+ set viewStonesRegularModeAction [radioActionCurrentValue := fromEnum initialViewStonesMode]
+
+ on viewStonesRegularModeAction radioActionChanged $ \action -> do
+ value <- toEnum <$> get action radioActionCurrentValue
+ modifyModes ui $ \modes -> return modes { uiViewStonesMode = value }
+
+ -- Help actions.
helpAboutAction <- actionNew "HelpAbout" "_About" Nothing Nothing
on helpAboutAction actionActivated $ helpAbout ui
@@ -261,46 +358,72 @@
fmap (fromMaybe $ error $ "Could not find the initial tool " ++ show initialTool ++ ".")
(actionGroupGetAction toolActions $ show initialTool)
- registrations <- viewNewRegistrations
+ state <- viewStateNew
- let me = Actions { myUi = ui
- , myRegistrations = registrations
- , myFileNew9Action = fileNew9Action
- , myFileNew13Action = fileNew13Action
- , myFileNew19Action = fileNew19Action
- , myFileNewCustomAction = fileNewCustomAction
- , myFileOpenAction = fileOpenAction
- , myFileSaveAction = fileSaveAction
- , myFileSaveAsAction = fileSaveAsAction
- , myFileCloseAction = fileCloseAction
- , myFileQuitAction = fileQuitAction
- , myToolActions = toolActions
- , myViewVariationsChildAction = viewVariationsChildAction
- , myViewVariationsCurrentAction = viewVariationsCurrentAction
- , myViewVariationsBoardMarkupOnAction = viewVariationsBoardMarkupOnAction
- , myViewVariationsBoardMarkupOffAction = viewVariationsBoardMarkupOffAction
- , myViewHighlightCurrentMovesAction = viewHighlightCurrentMovesAction
- , myHelpAboutAction = helpAboutAction
- }
+ let me = Actions
+ { myUi = ui
+ , myState = state
+ , myFileNew9Action = fileNew9Action
+ , myFileNew13Action = fileNew13Action
+ , myFileNew19Action = fileNew19Action
+ , myFileNewCustomAction = fileNewCustomAction
+ , myFileOpenAction = fileOpenAction
+ , myFileSaveAction = fileSaveAction
+ , myFileSaveAsAction = fileSaveAsAction
+ , myFileCloseAction = fileCloseAction
+ , myFileQuitAction = fileQuitAction
+ , myEditCutNodeAction = editCutNodeAction
+ , myEditCopyNodeAction = editCopyNodeAction
+ , myEditPasteNodeAction = editPasteNodeAction
+ , myGamePassAction = gamePassAction
+ , myGameVariationsChildAction = gameVariationsChildAction
+ , myGameVariationsCurrentAction = gameVariationsCurrentAction
+ , myGameVariationsBoardMarkupOnAction = gameVariationsBoardMarkupOnAction
+ , myGameVariationsBoardMarkupOffAction = gameVariationsBoardMarkupOffAction
+ , myToolActions = toolActions
+ , myViewHighlightCurrentMovesAction = viewHighlightCurrentMovesAction
+ , myViewStonesRegularModeAction = viewStonesRegularModeAction
+ , myViewStonesOneColorModeAction = viewStonesOneColorModeAction
+ , myViewStonesBlindModeAction = viewStonesBlindModeAction
+ , myHelpAboutAction = helpAboutAction
+ }
initialize me
return me
-initialize :: UiCtrl ui => Actions ui -> IO ()
+initialize :: UiCtrl go ui => Actions ui -> IO ()
initialize me =
- viewRegister me variationModeChangedEvent $ \_ new -> afterGo $ do
- let newSource = fromEnum $ variationModeSource new
- newBoardMarkup = fromEnum $ variationModeBoardMarkup new
- sourceAction = myViewVariationsChildAction me
- boardMarkupAction = myViewVariationsBoardMarkupOnAction me
+ register me
+ [ AnyEvent navigationEvent
+ , AnyEvent variationModeChangedEvent
+ ]
- oldSource <- get sourceAction radioActionCurrentValue
- when (newSource /= oldSource) $
- set sourceAction [radioActionCurrentValue := newSource]
+destroy :: UiCtrl go ui => Actions ui -> IO ()
+destroy = viewDestroy
- oldBoardMarkup <- get boardMarkupAction radioActionCurrentValue
- when (newBoardMarkup /= oldBoardMarkup) $
- set boardMarkupAction [radioActionCurrentValue := newBoardMarkup]
+update :: UiCtrl go ui => Actions ui -> IO ()
+update me = do
+ cursor <- readCursor $ myUi me
-destroy :: UiCtrl ui => Actions ui -> IO ()
-destroy = viewUnregisterAll
+ -- Update the sensitivity of the "Edit > Cut node" action.
+ set (myEditCutNodeAction me) [actionSensitive := isJust $ cursorParent cursor]
+
+ updateVariationModeActions me cursor
+
+-- | Updates the selection variation mode radio actions.
+updateVariationModeActions :: Actions ui -> Cursor -> IO ()
+updateVariationModeActions me cursor = do
+ let new = rootInfoVariationMode $ gameInfoRootInfo $ boardGameInfo $
+ cursorBoard cursor
+ newSource = fromEnum $ variationModeSource new
+ newBoardMarkup = fromEnum $ variationModeBoardMarkup new
+ sourceAction = myGameVariationsChildAction me
+ boardMarkupAction = myGameVariationsBoardMarkupOnAction me
+
+ oldSource <- get sourceAction radioActionCurrentValue
+ when (newSource /= oldSource) $
+ set sourceAction [radioActionCurrentValue := newSource]
+
+ oldBoardMarkup <- get boardMarkupAction radioActionCurrentValue
+ when (newBoardMarkup /= oldBoardMarkup) $
+ set boardMarkupAction [radioActionCurrentValue := newBoardMarkup]
diff --git a/src/Game/Goatee/Ui/Gtk/Common.hs b/src/Game/Goatee/Ui/Gtk/Common.hs
--- a/src/Game/Goatee/Ui/Gtk/Common.hs
+++ b/src/Game/Goatee/Ui/Gtk/Common.hs
@@ -18,11 +18,11 @@
-- | Common dependencies among all GTK+ UI code. Contains class definitions and
-- some common data declarations.
module Game.Goatee.Ui.Gtk.Common (
+ -- * UI Go monads
+ MonadUiGo (..), uiGoUpdateView, uiGoMakeDirty,
+ UiGoState (..), initialUiGoState,
-- * UI controllers
- UiGoM,
- afterGo,
- runUiGoPure,
- UiCtrl (..),
+ UiCtrl (..), AnyUiCtrl (..),
Registration,
DirtyChangedHandler,
FilePathChangedHandler,
@@ -31,131 +31,181 @@
setTool,
-- * UI views
UiView (..),
- ViewRegistrations,
- viewNewRegistrations,
- viewRegister,
- viewUnregisterAll,
+ AnyView (..),
+ ViewId,
+ ViewState,
+ viewStateNew,
+ viewDestroy,
+ viewId,
-- * UI modes
UiModes (..),
- ViewMode (..),
+ ViewStonesMode (..),
defaultUiModes,
Tool (..),
initialTool,
toolOrdering,
toolLabel,
+ toolIsImplemented,
toolToColor,
fileFiltersForSgf,
) where
import Control.Applicative ((<$>))
-import Control.Monad.Writer (Writer, runWriter, tell)
-import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef)
-import Data.Unique (Unique)
-import Game.Goatee.Common (Seq(..))
-import Game.Goatee.Sgf.Board
-import Game.Goatee.Sgf.Monad
-import Game.Goatee.Sgf.Parser
-import Game.Goatee.Sgf.Tree
-import Game.Goatee.Sgf.Types
+import qualified Data.Set as Set
+import Data.Set (Set)
+import Data.Unique (Unique, newUnique)
+import Game.Goatee.Lib.Board
+import Game.Goatee.Lib.Monad
+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 System.FilePath (takeFileName)
--- | A Go monad with handlers in the 'IO' monad.
-type UiGoM = GoT (Writer (Seq IO))
+-- | A class for monads that provide the features required to be used with a
+-- 'UiCtrl'. The type must have a 'MonadGo' instance and also provide access to
+-- some internal state, 'UiGoState'.
+class MonadGo go => MonadUiGo go where
+ -- | Evaluates the Go monad, returning the final value and cursor as well as
+ -- the internal 'UiGoState'.
+ runUiGo :: Cursor -> go a -> (a, Cursor, UiGoState)
--- | Schedules an IO action to run after the currently-executing Go monad
--- completes. The IO action should not attempt to access the cursor, as it may
--- not be available; instead it should work within the Go monad for cursor
--- manipulation (e.g. 'Game.Goatee.Sgf.Monad.getCursor').
-afterGo :: IO () -> UiGoM ()
-afterGo = tell . Seq
+ -- | Retrieves the current internal state.
+ uiGoGetState :: go UiGoState
--- | Applies a 'UiGoM' to a 'Cursor' purely, as opposed to 'runUiGo' which works
--- with the UI controller's cursor. Returns a tuple containing the Go action's
--- result, the final cursor, and the IO action resulting from all handlers being
--- run.
-runUiGoPure :: UiGoM a -> Cursor -> (a, Cursor, IO ())
-runUiGoPure go cursor =
- let ((value, cursor'), Seq action) = runWriter $ runGoT go cursor
- in (value, cursor', action)
+ -- | Assigns to the current internal state.
+ uiGoPutState :: UiGoState -> go ()
--- | A controller for the GTK+ UI.
-class UiCtrl a where
+ -- | Modifies the current internal state with the given function.
+ uiGoModifyState :: (UiGoState -> UiGoState) -> go ()
+
+-- | Forces the view with the given ID to update after the Go action completes.
+uiGoUpdateView :: MonadUiGo go => ViewId -> go ()
+uiGoUpdateView viewId = uiGoModifyState $ \state ->
+ let views = uiGoViewsToUpdate state
+ in if Set.member viewId views
+ then state
+ else state { uiGoViewsToUpdate = Set.insert viewId views }
+
+-- | Forces the UI to become dirty after the Go action completes. See
+-- 'setDirty'.
+uiGoMakeDirty :: MonadUiGo go => go ()
+uiGoMakeDirty = uiGoModifyState $ \state -> state { uiGoMakesDirty = True }
+
+-- | Internal state held by a type that implements 'MonadUiGo'.
+data UiGoState = UiGoState
+ { uiGoViewsToUpdate :: Set ViewId
+ -- ^ Keeps track of views that need updating after the Go action completes.
+ , uiGoMakesDirty :: Bool
+ -- ^ Whether the UI should be marked dirty as a result of running the Go
+ -- action.
+ }
+
+-- | The state with which a UI Go action should start executing.
+initialUiGoState :: UiGoState
+initialUiGoState = UiGoState
+ { uiGoViewsToUpdate = Set.empty
+ , uiGoMakesDirty = False
+ }
+
+-- | A controller for the GTK+ UI. A controller corresponds to a single open
+-- game.
+--
+-- The controller is agnostic to the type of Go monad it is used with, as long
+-- as it implements the functionality in 'MonadUiGo'. The monad can have extra
+-- functionality, e.g. for testing or debugging.
+class MonadUiGo go => UiCtrl go ui | ui -> go where
-- | Reads the current UI modes.
- readModes :: a -> IO UiModes
+ readModes :: ui -> IO UiModes
-- | Modifies the controller's modes according to the given action, then fires
-- a mode change event via 'fireViewModesChanged'.
- modifyModes :: a -> (UiModes -> IO UiModes) -> IO ()
+ modifyModes :: ui -> (UiModes -> IO UiModes) -> IO ()
-- | Runs a Go monad on the current cursor, updating the cursor and firing
-- handlers as necessary.
- runUiGo :: a -> UiGoM b -> IO b
+ doUiGo :: ui -> go a -> IO a
-- | Returns the current cursor.
- readCursor :: a -> IO Cursor
+ readCursor :: ui -> IO Cursor
-- | Determines whether it is currently valid to play at the given point.
- isValidMove :: a -> Coord -> IO Bool
+ isValidMove :: ui -> Coord -> IO Bool
- -- | Makes the current player place a stone at the given point.
- playAt :: a -> Coord -> IO ()
+ -- | Makes the current player place a stone at the given point, or pass in the
+ -- 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 :: a -> IO Bool
+ 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 :: a -> Int -> IO Bool
+ 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 :: a -> IO Bool
+ 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 :: a -> IO Bool
+ goRight :: ui -> IO Bool
- -- | Registers a handler for a given 'Event'. The string is the name of the
- -- caller, used to keep track of what components registered what handlers.
- -- Returns a 'Registration' that can be given to 'unregister' to prevent any
- -- further calls to the handler.
- register :: a -> String -> Event UiGoM handler -> handler -> IO Registration
+ -- | Registers a view to update when any of the given 'Event's fires. The
+ -- controller will call 'viewUpdate' after the Go action finishes running.
+ --
+ -- When the view is destroyed, it must call 'unregister' or 'unregisterAll' to
+ -- free the handlers it has installed. 'viewDestroy' calls this, and all
+ -- views should call 'viewDestroy', so there is no need to call this manually.
+ register :: UiView go ui view => view -> [AnyEvent go] -> IO ()
- -- | Unregisters the handler for a 'Registration' that was returned from
- -- 'register'. Returns true if such a handler was found and removed.
- unregister :: a -> Registration -> IO Bool
+ -- | Stops the controller from updating the view when the 'Event' fires.
+ -- Returns true if there was a registration that was removed.
+ unregister :: UiView go ui view => view -> AnyEvent go -> IO Bool
+ -- | Stops the controller from updating the view entirely.
+ unregisterAll :: UiView go ui view => view -> IO ()
+
-- | Returns the currently registered handlers, as (owner, event name) pairs.
- registeredHandlers :: a -> IO [(String, String)]
+ registeredHandlers :: ui -> IO [(String, String)]
-- | Registers a handler that will execute when UI modes change. The string
-- is the name of the caller, used to keep track of what components registered
-- what handlers.
- registerModesChangedHandler :: a -> String -> ModesChangedHandler -> IO Registration
+ registerModesChangedHandler :: ui -> String -> ModesChangedHandler -> IO Registration
-- | Unregisters the modes-changed handler for a 'Registration' that was
-- returned from 'registerModesChangedHandler'. Returns true if such a
-- handler was found and removed.
- unregisterModesChangedHandler :: a -> Registration -> IO Bool
+ unregisterModesChangedHandler :: ui -> Registration -> IO Bool
-- | Returns the owners of the currently registered 'ModesChangedHandler's.
- registeredModesChangedHandlers :: a -> IO [String]
+ registeredModesChangedHandlers :: ui -> IO [String]
-- | Returns the 'Window' for the game's 'MainWindow'.
- getMainWindow :: a -> IO Window
+ getMainWindow :: ui -> IO Window
- openBoard :: Maybe a -> Maybe FilePath -> Node -> IO a
+ openBoard :: Maybe ui -> Maybe FilePath -> Node -> IO ui
- openNewBoard :: Maybe a -> Maybe (Int, Int) -> IO a
- openNewBoard ui = openBoard ui Nothing . rootNode
+ openNewBoard :: Maybe ui -> Maybe (Int, Int) -> IO ui
+ openNewBoard ui =
+ openBoard ui Nothing .
- openFile :: Maybe a -> FilePath -> IO (Either String a)
+ -- Show variations of the current move rather than child variations by
+ -- default. The GTK+ UI always renders child variations when told to, even
+ -- when there's only a single child, so this puts less noise on the board.
+ cursorNode .
+ execGo (modifyVariationMode $ const $ VariationMode ShowCurrentVariations True) .
+ rootCursor .
+
+ rootNode
+
+ openFile :: Maybe ui -> FilePath -> IO (Either String ui)
openFile ui file = do
result <- parseFile file
case result of
@@ -166,53 +216,72 @@
-- | Prompts with an open file dialog for a game to open, then opens the
-- selected game if the user picks one.
- fileOpen :: a -> IO ()
+ fileOpen :: ui -> IO ()
-- | Saves the current game to a file. If the current game is not currently
-- tied to a file, then this will act identically to 'fileSaveAs'. Returns true
-- iff the game was saved.
- fileSave :: a -> IO Bool
+ fileSave :: ui -> IO Bool
-- | Presents a file save dialog for the user to specify a file to write the
-- current game to. If the user provides a filename, then the game is
-- written. If the user names an existing file, then another dialog confirms
-- overwriting the existing file. Returns true iff the user accepted the
-- dialog(s) and the game was saved.
- fileSaveAs :: a -> IO Bool
+ fileSaveAs :: ui -> IO Bool
-- | Closes the game and all UI windows, etc. attached to the given controller.
-- If the game is dirty, then a dialog first prompts the user whether to save,
-- throw away changes, or abort the closing.
- fileClose :: a -> IO Bool
+ fileClose :: ui -> IO Bool
+ -- | Hides and releases the game's UI window, and shut downs the UI controller
+ -- (in effect closing the game, with no prompting). If this is the last board
+ -- open, then the application will exit.
+ fileCloseSilently :: ui -> IO ()
+
-- | Closes all open games and exits the program. If any games are dirty then
-- we check if the user wants to save them. If the user clicks cancel at any
-- point then shutdown is cancelled and no games are closed.
- fileQuit :: a -> IO Bool
+ fileQuit :: ui -> IO Bool
+ -- | Performs a copy a la 'editCopyNode'. If this copy succeeds, then we
+ -- navigate to the parent of the current node, and delete the node we were
+ -- just on from the tree.
+ editCutNode :: ui -> IO ()
+
+ -- | Copies an SGF representation of the subtree rooted at the current node
+ -- onto the system clipboard. If the node fails to render, then an error
+ -- dialog is displayed and the clipboard is left untouched.
+ editCopyNode :: ui -> IO ()
+
+ -- | Attempts to parse text on the system clipboard as an SGF subtree and
+ -- insert the parsed node below the current node.
+ editPasteNode :: ui -> IO ()
+
-- | Presents the user with an about dialog that shows general information
-- about the application to the user (authorship, license, etc.).
- helpAbout :: a -> IO ()
+ helpAbout :: ui -> IO ()
-- | Returns the path to the file that the UI is currently displaying, or
-- nothing if the UI is displaying an unsaved game.
- getFilePath :: a -> IO (Maybe FilePath)
+ getFilePath :: ui -> IO (Maybe FilePath)
-- | Returns the filename (base name, with no directories before it) that is
-- currently open in the UI, or if the UI is showing an unsaved game, then a
-- fallback "untitled" string. As this may not be a real filename, it should
-- be used for display purposes only, and not for actually writing to.
- getFileName :: a -> IO String
+ getFileName :: ui -> IO String
getFileName ui = maybe untitledFileName takeFileName <$> getFilePath ui
-- | Sets the path to the file that the UI is currently displaying. This
-- changes the value returned by 'getFilePath' but does not do any saving or
-- loading.
- setFilePath :: a -> Maybe FilePath -> IO ()
+ setFilePath :: ui -> Maybe FilePath -> IO ()
-- | Registers a handler that will execute when the file path the UI is bound
-- to changes.
- registerFilePathChangedHandler :: a
+ registerFilePathChangedHandler :: ui
-> String
-- ^ The name of the caller, used to track
-- what components registered what handlers.
@@ -225,21 +294,21 @@
-- | Unregisters the handler for a 'Registration' that was returned from
-- 'registerFilePathChangedHandler'. Returns true if such a handler was found
-- and removed.
- unregisterFilePathChangedHandler :: a -> Registration -> IO Bool
+ unregisterFilePathChangedHandler :: ui -> Registration -> IO Bool
-- | Returns the owners of the currently registered 'FilePathChangedHandler's.
- registeredFilePathChangedHandlers :: a -> IO [String]
+ registeredFilePathChangedHandlers :: ui -> IO [String]
-- | Returns whether the UI is dirty, i.e. whether there are unsaved changes
-- to the current game.
- getDirty :: a -> IO Bool
+ getDirty :: ui -> IO Bool
-- | Sets the dirty state of the UI.
- setDirty :: a -> Bool -> IO ()
+ setDirty :: ui -> Bool -> IO ()
-- | Registers a handler that will execute when the dirty state of the UI
-- changes.
- registerDirtyChangedHandler :: a
+ registerDirtyChangedHandler :: ui
-> String
-- ^ The name of the caller, used to track what
-- components registered what handlers.
@@ -252,13 +321,16 @@
-- | Unregisters the handler for a 'Registration' that was returned from
-- 'registerDirtyChangedHandler'. Returns true if such a handler was found
-- and removed.
- unregisterDirtyChangedHandler :: a -> Registration -> IO Bool
+ unregisterDirtyChangedHandler :: ui -> Registration -> IO Bool
-- | Returns the owners of the currently registered 'DirtyChangedHandler's.
- registeredDirtyChangedHandlers :: a -> IO [String]
+ registeredDirtyChangedHandlers :: ui -> IO [String]
--- | A key that refers to registration of a handler with a UI controller. Used
--- to unregister handlers.
+-- | An existential type for all UI controllers.
+data AnyUiCtrl = forall go ui. UiCtrl go ui => AnyUiCtrl ui
+
+-- | A key that refers to registration of a handler with a UI controller, for
+-- non-Go-monad events. Used to unregister handlers.
type Registration = Unique
-- | A handler for when the dirty state of the UI changes. Passed the new dirty
@@ -273,94 +345,109 @@
-- the new modes, in that order.
type ModesChangedHandler = UiModes -> UiModes -> IO ()
-modifyModesPure :: UiCtrl ui => ui -> (UiModes -> UiModes) -> IO ()
+modifyModesPure :: UiCtrl go ui => ui -> (UiModes -> UiModes) -> IO ()
modifyModesPure ui f = modifyModes ui (return . f)
-- | Assigns to the current tool within the modes of 'ui' (firing any relevant
-- change handlers).
-setTool :: UiCtrl ui => ui -> Tool -> IO ()
+setTool :: UiCtrl go ui => ui -> Tool -> IO ()
setTool ui tool = modifyModesPure ui $ \modes -> modes { uiTool = tool }
-- | A UI widget that listens to the state of a 'UiCtrl'. This class makes it
--- easy to register and unregister event handlers with 'viewRegister' and
--- 'viewUnregisterAll'.
-class UiCtrl ui => UiView view ui | view -> ui where
+-- easy to ask to be updated on relevant changes with 'register'.
+class UiCtrl go ui => UiView go ui view | view -> ui where
-- | A printable name of the view; usually just the data type name.
viewName :: view -> String
-- | A reference to the view's controller.
viewCtrl :: view -> ui
- -- | An updatable list of registrations for event handlers the view has
- -- registered.
- viewRegistrations :: view -> ViewRegistrations
+ -- | Internal housekeeping data for the view. Create with 'viewStateNew'. A
+ -- 'ViewState' may only be used with a single view.
+ viewState :: view -> ViewState
-type ViewRegistrations = IORef [Registration]
+ -- | Updates the UI state of the view based on the current state of data that
+ -- backs it in the model.
+ viewUpdate :: view -> IO ()
--- | Creates a new 'ViewRegistrations'.
-viewNewRegistrations :: IO ViewRegistrations
-viewNewRegistrations = newIORef []
+-- | An existential type over all views. Provides 'Eq' and 'Ord' instances that
+-- use each view's 'ViewId', and a 'Show' instance that returns a view's name.
+data AnyView = forall go ui view. UiView go ui view => AnyView view
--- | Registers a handler for an event on a view.
-viewRegister :: UiView view ui => view -> Event UiGoM handler -> handler -> IO ()
-viewRegister view event handler = do
- let ui = viewCtrl view
- name = viewName view
- registration <- register ui name event handler
- modifyIORef (viewRegistrations view) (registration:)
+instance Eq AnyView where
+ (AnyView v) == (AnyView v') = viewId v == viewId v'
--- | Unregisters all event handlers that the view has registered in its
--- 'viewRegistrations'.
-viewUnregisterAll :: UiView view ui => view -> IO ()
-viewUnregisterAll view = do
- let ui = viewCtrl view
- registrations = viewRegistrations view
- readIORef registrations >>= mapM_ (unregister ui)
- writeIORef registrations []
+instance Ord AnyView where
+ compare (AnyView v) (AnyView v') = compare (viewId v) (viewId v')
-data UiModes = UiModes { uiViewMode :: ViewMode
- , uiViewOneColorModeColor :: Color
- , uiViewBlindModesAnnouncePlayer :: Bool
- -- ^ If true, announce the player whose turn it is with
- -- blindfolds off. If false, announce the player whose
- -- turn it is with blindfolds on.
- , uiHighlightCurrentMovesMode :: Bool
- -- ^ Whether to draw an indicator on the game board for
- -- moves on the current node.
- , uiTool :: Tool
- } deriving (Eq, Show)
+instance Show AnyView where
+ show (AnyView v) = viewName v
-data ViewMode = ViewRegularMode
- | ViewOneColorMode
- | ViewNothingMode
- deriving (Eq, Show)
+-- | A application-wide unique identifier for referring to an instance of a
+-- view.
+newtype ViewId = ViewId Unique deriving (Eq, Ord)
+-- | Internal controller housekeeping data for a view.
+data ViewState = ViewState
+ { viewId' :: ViewId
+ }
+
+-- | Creates a new 'ViewState'.
+viewStateNew :: IO ViewState
+viewStateNew = ViewState <$> (ViewId <$> newUnique)
+
+-- | Cleans up the internal state of a view, and releases registered Go event
+-- handlers for the view. Views should call this when destroying themselves;
+-- this does __not force__ a view to destroy itself.
+viewDestroy :: UiView go ui view => view -> IO ()
+viewDestroy = unregisterAll
+
+-- | Returns a view's unique ID.
+viewId :: UiView go ui view => view -> ViewId
+viewId = viewId' . viewState
+
+data UiModes = UiModes
+ { uiViewStonesMode :: ViewStonesMode
+ , uiViewStonesOneColorModeColor :: Color
+ , uiHighlightCurrentMovesMode :: Bool
+ -- ^ Whether to draw an indicator on the game board for moves on the current
+ -- node.
+ , uiTool :: Tool
+ } deriving (Eq, Show)
+
+data ViewStonesMode =
+ ViewStonesRegularMode
+ | ViewStonesOneColorMode
+ | ViewStonesBlindMode
+ deriving (Bounded, Enum, Eq, Show)
+
defaultUiModes :: UiModes
-defaultUiModes = UiModes { uiViewMode = ViewRegularMode
- , uiViewOneColorModeColor = Black
- , uiViewBlindModesAnnouncePlayer = True
- , uiHighlightCurrentMovesMode = False
- , uiTool = ToolPlay
- }
+defaultUiModes = UiModes
+ { uiViewStonesMode = ViewStonesRegularMode
+ , uiViewStonesOneColorModeColor = Black
+ , uiHighlightCurrentMovesMode = True
+ , uiTool = ToolPlay
+ }
-- | Selectable tools for operating on the board.
-data Tool = ToolPlay -- ^ Game tool.
- | ToolJump -- ^ Game tool.
- | ToolScore -- ^ Game tool.
- | ToolBlack -- ^ Editing tool.
- | ToolWhite -- ^ Editing tool.
- | ToolErase -- ^ Editing tool.
- | ToolArrow -- ^ Markup tool.
- | ToolMarkCircle -- ^ Markup tool.
- | ToolLabel -- ^ Markup tool.
- | ToolLine -- ^ Markup tool.
- | ToolMarkX -- ^ Markup tool.
- | ToolMarkSelected -- ^ Markup tool.
- | ToolMarkSquare -- ^ Markup tool.
- | ToolMarkTriangle -- ^ Markup tool.
- | ToolVisible -- ^ Visibility tool.
- | ToolDim -- ^ Visibility tool.
- deriving (Bounded, Enum, Eq, Show)
+data Tool =
+ ToolPlay -- ^ Game tool.
+ | ToolJump -- ^ Game tool.
+ | ToolScore -- ^ Game tool.
+ | ToolBlack -- ^ Editing tool.
+ | ToolWhite -- ^ Editing tool.
+ | ToolErase -- ^ Editing tool.
+ | ToolArrow -- ^ Markup tool.
+ | ToolMarkCircle -- ^ Markup tool.
+ | ToolLabel -- ^ Markup tool.
+ | ToolLine -- ^ Markup tool.
+ | ToolMarkX -- ^ Markup tool.
+ | ToolMarkSelected -- ^ Markup tool.
+ | ToolMarkSquare -- ^ Markup tool.
+ | ToolMarkTriangle -- ^ Markup tool.
+ | ToolVisible -- ^ Visibility tool.
+ | ToolDim -- ^ Visibility tool.
+ deriving (Bounded, Enum, Eq, Show)
-- | The tool that should be selected when a board first opens in the UI.
initialTool :: Tool
@@ -393,6 +480,25 @@
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.
diff --git a/src/Game/Goatee/Ui/Gtk/GamePropertiesPanel.hs b/src/Game/Goatee/Ui/Gtk/GamePropertiesPanel.hs
--- a/src/Game/Goatee/Ui/Gtk/GamePropertiesPanel.hs
+++ b/src/Game/Goatee/Ui/Gtk/GamePropertiesPanel.hs
@@ -24,212 +24,420 @@
myWidget,
) where
+import Control.Arrow (first)
import Control.Monad (forM_, void, when)
+import Control.Monad.Trans (liftIO)
+import Data.IORef (newIORef, readIORef, writeIORef)
import Data.Maybe (fromMaybe)
-import Game.Goatee.Sgf.Board
-import Game.Goatee.Sgf.Monad hiding (on)
-import Game.Goatee.Sgf.Property
-import Game.Goatee.Sgf.Tree
-import Game.Goatee.Sgf.Types
+import qualified Game.Goatee.Common.Bigfloat as BF
+import Game.Goatee.Lib.Board
+import Game.Goatee.Lib.Monad hiding (on)
+import Game.Goatee.Lib.Types
import Game.Goatee.Ui.Gtk.Common
-import Game.Goatee.Ui.Gtk.Latch
import Game.Goatee.Ui.Gtk.Utils
+import Game.Goatee.Ui.Gtk.Widget
import Graphics.UI.Gtk (
- Entry,
+ AttachOptions (Expand, Fill),
+ AttrOp ((:=)),
+ CheckButton,
+ Label,
Packing (PackGrow, PackNatural),
- PolicyType (PolicyAutomatic),
- TextBuffer, TextView,
+ PolicyType (PolicyAutomatic, PolicyNever),
+ TextView,
Widget,
- WrapMode (WrapWord),
+ WidgetClass,
boxPackStart,
- bufferChanged,
+ checkButtonNewWithLabel,
containerAdd,
- entryNew, entrySetText,
+ entryWidthChars,
+ focusOutEvent,
get,
+ hBoxNew,
hSeparatorNew,
- labelNewWithMnemonic, labelSetMnemonicWidget,
+ labelNew, labelSetMnemonicWidget, labelSetText,
on,
- scrolledWindowNew,
- scrolledWindowSetPolicy,
- tableAttachDefaults, tableNew, tableSetRowSpacing,
- textBufferSetText, textBufferText,
- textViewGetBuffer, textViewNew, textViewSetWrapMode,
+ scrolledWindowAddWithViewport, scrolledWindowNew, scrolledWindowSetPolicy,
+ set,
+ spinButtonSetDigits,
+ tableAttach, tableAttachDefaults, tableNew, tableSetRowSpacing,
+ textViewNew,
+ toggleButtonActive, toggled,
toWidget,
vBoxNew,
+ widgetSetSensitive, widgetSetSizeRequest,
)
-data GamePropertiesPanel ui =
- GamePropertiesPanel { myUi :: ui
- , myRegistrations :: ViewRegistrations
- , myWidget :: Widget
- , myBlackName :: Entry
- , myBlackRank :: Entry
- , myBlackTeam :: Entry
- , myWhiteName :: Entry
- , myWhiteRank :: Entry
- , myWhiteTeam :: Entry
- , myComment :: TextView
- , myCommentLatch :: Latch
- -- ^ When a 'TextBuffer' is programatically assigned to,
- -- two change events are fired, one to delete the old
- -- text and one to insert the new text. We don't want
- -- to handle the intermediate value by writing it back
- -- to the model because this triggers dirtyness. So we
- -- hold this latch on while we are doing a model-to-view
- -- update in order to avoid this problem.
- }
+-- A getter for 'Stringlike' 'GameInfo' fields.
+data InfoGetter = forall a. Stringlike a => InfoGetter (GameInfo -> Maybe a)
-instance UiCtrl ui => UiView (GamePropertiesPanel ui) ui where
+data GamePropertiesPanel ui = GamePropertiesPanel
+ { myUi :: ui
+ , myState :: ViewState
+ , myWidget :: Widget
+
+ -- Black's info.
+ , myBlackNameEntry :: GoateeEntry
+ , myBlackRankEntry :: GoateeEntry
+ , myBlackTeamEntry :: GoateeEntry
+
+ -- White's info.
+ , myWhiteNameEntry :: GoateeEntry
+ , myWhiteRankEntry :: GoateeEntry
+ , myWhiteTeamEntry :: GoateeEntry
+
+ -- Game rules.
+ , myRulesetEntry :: GoateeEntry
+ , myMainTimeSpin :: GoateeSpinButton
+ , myMainTimeLabel :: Label
+ , myOvertimeEntry :: GoateeEntry
+ , myGameResultDisplayCheck :: CheckButton
+ , myGameResultEntry :: GoateeEntry
+
+ -- Game editors.
+ , myGameAnnotatorEntry :: GoateeEntry
+ , myGameEntererEntry :: GoateeEntry
+
+ -- Game context.
+ , myEventNameEntry :: GoateeEntry
+ , myGamePlaceEntry :: GoateeEntry
+ , myGameRoundEntry :: GoateeEntry
+ , myGameDatesEntry :: GoateeEntry
+ , myGameNameEntry :: GoateeEntry
+ , myGameSourceEntry :: GoateeEntry
+ , myGameCopyrightEntry :: GoateeEntry
+
+ -- Further commentary.
+ , myGameOpeningEntry :: GoateeEntry
+ , myGameCommentTextView :: TextView
+ , myGameCommentTextViewSetter :: String -> IO ()
+ }
+
+instance UiCtrl go ui => UiView go ui (GamePropertiesPanel ui) where
viewName = const "GamePropertiesPanel"
viewCtrl = myUi
- viewRegistrations = myRegistrations
+ viewState = myState
+ viewUpdate = update
-create :: UiCtrl ui => ui -> IO (GamePropertiesPanel ui)
+create :: UiCtrl go ui => ui -> IO (GamePropertiesPanel ui)
create ui = do
- let rows = 8
+ let rows = 27
cols = 2
+ scroll <- scrolledWindowNew Nothing Nothing
box <- vBoxNew False 0
table <- tableNew rows cols False
+ scrolledWindowSetPolicy scroll PolicyNever PolicyAutomatic
+ scrolledWindowAddWithViewport scroll box
boxPackStart box table PackNatural 0
- let addSeparator row = do sep <- hSeparatorNew
- tableAttachDefaults table sep 0 cols row (row + 1)
- tableSetRowSpacing table (row - 1) 6
- tableSetRowSpacing table row 6
+ nextRowRef <- newIORef 0
+ let nextRow = do
+ row <- readIORef nextRowRef
+ writeIORef nextRowRef $ row + 1
+ return row
+ addSeparator = do
+ row <- nextRow
+ sep <- hSeparatorNew
+ tableAttachDefaults table sep 0 cols row (row + 1)
+ tableSetRowSpacing table (row - 1) 6
+ tableSetRowSpacing table row 6
+ addWidget :: WidgetClass widget => String -> widget -> IO widget
+ addWidget labelText widget = do
+ row <- nextRow
+ label <- labelNew $ Just labelText
+ labelSetMnemonicWidget label widget
+ tableAttach table label 0 1 row (row + 1)
+ [Fill] [] 0 0
+ widgetSetSizeRequest widget 0 (-1)
+ tableAttach table widget 1 2 row (row + 1)
+ [Expand, Fill] [] 0 0
+ return widget
+ addWideWidget :: WidgetClass widget => widget -> IO widget
+ addWideWidget widget = do
+ row <- nextRow
+ widgetSetSizeRequest widget 0 (-1)
+ tableAttachDefaults table widget 0 2 row (row + 1)
+ return widget
+ addEntry :: String -> IO GoateeEntry
+ addEntry labelText = do
+ entry <- goateeEntryNew
+ let widget = goateeEntryWidget entry
+ set widget [entryWidthChars := 0]
+ addWidget labelText widget
+ return entry
- let blackRow = 0
- blackNameLabel <- labelNewWithMnemonic "_Black"
- blackNameEntry <- entryNew
- labelSetMnemonicWidget blackNameLabel blackNameEntry
- tableAttachDefaults table blackNameLabel 0 1 blackRow (blackRow + 1)
- tableAttachDefaults table blackNameEntry 1 2 blackRow (blackRow + 1)
+ blackNameEntry <- addEntry "Black"
+ blackRankEntry <- addEntry "Rank"
+ blackTeamEntry <- addEntry "Team"
+ addSeparator
+ whiteNameEntry <- addEntry "White"
+ whiteRankEntry <- addEntry "Rank"
+ whiteTeamEntry <- addEntry "Team"
+ addSeparator
+ rulesetEntry <- addEntry "Ruleset"
- blackRankLabel <- labelNewWithMnemonic "_Rank"
- blackRankEntry <- entryNew
- labelSetMnemonicWidget blackRankLabel blackRankEntry
- tableAttachDefaults table blackRankLabel 0 1 (blackRow + 1) (blackRow + 2)
- tableAttachDefaults table blackRankEntry 1 2 (blackRow + 1) (blackRow + 2)
+ mainTimeBox <- hBoxNew True 0
+ mainTimeSpin <- goateeSpinButtonNewWithRange 0 3155692600 {- 100 years -} 1
+ let mainTimeSpinWidget = goateeSpinButtonWidget mainTimeSpin
+ spinButtonSetDigits mainTimeSpinWidget 1
+ mainTimeLabel <- labelNew Nothing
+ boxPackStart mainTimeBox mainTimeSpinWidget PackGrow 0
+ boxPackStart mainTimeBox mainTimeLabel PackNatural 0
+ addWidget "Time" mainTimeBox
- blackTeamLabel <- labelNewWithMnemonic "T_eam"
- blackTeamEntry <- entryNew
- labelSetMnemonicWidget blackTeamLabel blackTeamEntry
- tableAttachDefaults table blackTeamLabel 0 1 (blackRow + 2) (blackRow + 3)
- tableAttachDefaults table blackTeamEntry 1 2 (blackRow + 2) (blackRow + 3)
+ overtimeEntry <- addEntry "Overtime"
+ gameResultDisplayCheck <- addWideWidget =<< checkButtonNewWithLabel "Show game result"
+ gameResultEntry <- addEntry "Result"
+ addSeparator
+ gameAnnotatorEntry <- addEntry "Annotator"
+ gameEntererEntry <- addEntry "Enterer"
+ addSeparator
+ eventNameEntry <- addEntry "Event"
+ gamePlaceEntry <- addEntry "Place"
+ gameRoundEntry <- addEntry "Round"
+ gameDatesEntry <- addEntry "Dates"
+ gameNameEntry <- addEntry "Name"
+ gameSourceEntry <- addEntry "Source"
+ gameCopyrightEntry <- addEntry "Copyright"
+ addSeparator
+ gameOpeningEntry <- addEntry "Opening"
+ addWideWidget =<< labelNew (Just "Game comment:")
- addSeparator 3
+ gameCommentScroll <- scrolledWindowNew Nothing Nothing
+ scrolledWindowSetPolicy scroll PolicyAutomatic PolicyAutomatic
+ gameCommentTextView <- textViewNew
+ -- Set a minimum height on the text view, otherwise it's too short.
+ widgetSetSizeRequest gameCommentTextView 0 175
+ containerAdd gameCommentScroll gameCommentTextView
+ boxPackStart box gameCommentScroll PackNatural 0
- let whiteRow = 4
- whiteNameLabel <- labelNewWithMnemonic "_White"
- whiteNameEntry <- entryNew
- labelSetMnemonicWidget whiteNameLabel whiteNameEntry
- tableAttachDefaults table whiteNameLabel 0 1 whiteRow (whiteRow + 1)
- tableAttachDefaults table whiteNameEntry 1 2 whiteRow (whiteRow + 1)
+ gameCommentTextViewSetter <- textViewConfigure gameCommentTextView $ \value ->
+ doUiGo ui $ void $ modifyGameInfo $ \info ->
+ info { gameInfoGameComment = if null value then Nothing else Just $ stringToSgf value }
- whiteRankLabel <- labelNewWithMnemonic "Ran_k"
- whiteRankEntry <- entryNew
- labelSetMnemonicWidget whiteRankLabel whiteRankEntry
- tableAttachDefaults table whiteRankLabel 0 1 (whiteRow + 1) (whiteRow + 2)
- tableAttachDefaults table whiteRankEntry 1 2 (whiteRow + 1) (whiteRow + 2)
+ addedRowCount <- readIORef nextRowRef
+ when (addedRowCount /= rows) $ fail $
+ "GamePropertiesPanel: Table expected " ++ show rows ++ " rows, got " ++
+ show addedRowCount ++ "."
- whiteTeamLabel <- labelNewWithMnemonic "Te_am"
- whiteTeamEntry <- entryNew
- labelSetMnemonicWidget whiteTeamLabel whiteTeamEntry
- tableAttachDefaults table whiteTeamLabel 0 1 (whiteRow + 2) (whiteRow + 3)
- tableAttachDefaults table whiteTeamEntry 1 2 (whiteRow + 2) (whiteRow + 3)
+ state <- viewStateNew
- addSeparator 7
+ let me = GamePropertiesPanel
+ { myUi = ui
+ , myState = state
+ , myWidget = toWidget scroll
- comment <- textViewNew
- commentLatch <- newLatch
- textViewSetWrapMode comment WrapWord
- commentScroll <- scrolledWindowNew Nothing Nothing
- scrolledWindowSetPolicy commentScroll PolicyAutomatic PolicyAutomatic
- containerAdd commentScroll comment
- boxPackStart box commentScroll PackGrow 0
+ , myBlackNameEntry = blackNameEntry
+ , myBlackRankEntry = blackRankEntry
+ , myBlackTeamEntry = blackTeamEntry
- registrations <- viewNewRegistrations
+ , myWhiteNameEntry = whiteNameEntry
+ , myWhiteRankEntry = whiteRankEntry
+ , myWhiteTeamEntry = whiteTeamEntry
- let me = GamePropertiesPanel { myUi = ui
- , myRegistrations = registrations
- , myWidget = toWidget box
- , myBlackName = blackNameEntry
- , myBlackRank = blackRankEntry
- , myBlackTeam = blackTeamEntry
- , myWhiteName = whiteNameEntry
- , myWhiteRank = whiteRankEntry
- , myWhiteTeam = whiteTeamEntry
- , myComment = comment
- , myCommentLatch = commentLatch
- }
+ , myRulesetEntry = rulesetEntry
+ , myMainTimeSpin = mainTimeSpin
+ , myMainTimeLabel = mainTimeLabel
+ , myOvertimeEntry = overtimeEntry
+ , myGameResultDisplayCheck = gameResultDisplayCheck
+ , myGameResultEntry = gameResultEntry
+ , myGameAnnotatorEntry = gameAnnotatorEntry
+ , myGameEntererEntry = gameEntererEntry
+
+ , myEventNameEntry = eventNameEntry
+ , myGamePlaceEntry = gamePlaceEntry
+ , myGameRoundEntry = gameRoundEntry
+ , myGameDatesEntry = gameDatesEntry
+ , myGameNameEntry = gameNameEntry
+ , myGameSourceEntry = gameSourceEntry
+ , myGameCopyrightEntry = gameCopyrightEntry
+
+ , myGameOpeningEntry = gameOpeningEntry
+ , myGameCommentTextView = gameCommentTextView
+ , myGameCommentTextViewSetter = gameCommentTextViewSetter
+ }
+
initialize me
return me
-initialize :: UiCtrl ui => GamePropertiesPanel ui -> IO ()
+initialize :: UiCtrl go ui => GamePropertiesPanel ui -> IO ()
initialize me = do
+ register me [AnyEvent gameInfoChangedEvent]
+
+ viewUpdate me
+
+ connectEntry me (myBlackNameEntry me) gameInfoBlackName $ \x info ->
+ info { gameInfoBlackName = x }
+ connectEntry me (myBlackRankEntry me) gameInfoBlackRank $ \x info ->
+ info { gameInfoBlackRank = x }
+ connectEntry me (myBlackTeamEntry me) gameInfoBlackTeamName $ \x info ->
+ info { gameInfoBlackTeamName = x }
+
+ connectEntry me (myWhiteNameEntry me) gameInfoWhiteName $ \x info ->
+ info { gameInfoWhiteName = x }
+ connectEntry me (myWhiteRankEntry me) gameInfoWhiteRank $ \x info ->
+ info { gameInfoWhiteRank = x }
+ connectEntry me (myWhiteTeamEntry me) gameInfoWhiteTeamName $ \x info ->
+ info { gameInfoWhiteTeamName = x }
+
+ connectEntry me (myRulesetEntry me) gameInfoRuleset $ \x info -> info { gameInfoRuleset = x }
+ connect me (goateeSpinButtonOnSpinned $ myMainTimeSpin me) $ \x info ->
+ info { gameInfoBasicTimeSeconds = if x == 0 then Nothing else Just x }
+ connectEntry me (myOvertimeEntry me) gameInfoOvertime $ \x info -> info { gameInfoOvertime = x }
+ let gameResultCheck = myGameResultDisplayCheck me
+ on gameResultCheck toggled $ viewUpdate me
+ connectEntry' me (myGameResultEntry me) (get gameResultCheck toggleButtonActive) gameInfoResult $
+ \x info -> info { gameInfoResult = x }
+
+ connectEntry me (myGameAnnotatorEntry me) gameInfoAnnotatorName $ \x info ->
+ info { gameInfoAnnotatorName = x }
+ connectEntry me (myGameEntererEntry me) gameInfoEntererName $ \x info ->
+ info { gameInfoEntererName = x }
+
+ connectEntry me (myEventNameEntry me) gameInfoEvent $ \x info -> info { gameInfoEvent = x }
+ connectEntry me (myGamePlaceEntry me) gameInfoPlace $ \x info -> info { gameInfoPlace = x }
+ connectEntry me (myGameRoundEntry me) gameInfoRound $ \x info -> info { gameInfoRound = x }
+ connectEntry me (myGameDatesEntry me) gameInfoDatesPlayed $ \x info ->
+ info { gameInfoDatesPlayed = x }
+ connectEntry me (myGameNameEntry me) gameInfoGameName $ \x info -> info { gameInfoGameName = x }
+ connectEntry me (myGameSourceEntry me) gameInfoSource $ \x info -> info { gameInfoSource = x }
+ connectEntry me (myGameCopyrightEntry me) gameInfoCopyright $ \x info ->
+ info { gameInfoCopyright = x }
+
+ connectEntry me (myGameOpeningEntry me) gameInfoOpeningComment $ \x info ->
+ info { gameInfoOpeningComment = x }
+
+-- | @connectEntry me entry getter setter@ binds an 'Entry' to a field
+-- in the current 'GameInfo' so that changes in one affect the other.
+-- Empty strings are coerced to 'Nothing' and vice versa.
+--
+-- When an 'Entry' is changed, we immediately write the value back to
+-- the model: we can't wait until focus out because e.g. opening menus
+-- doesn't fire focus-out events. We also inhibit this widget's model
+-- change handler assigning back to the entry, because e.g. we don't
+-- want to canonicalize "B+1.0" to "B+1" as soon as it's typed.
+-- Instead, we do the model-to-view canonicalizing update on
+-- focus-out.
+connectEntry :: (UiCtrl go ui, Stringlike a)
+ => GamePropertiesPanel ui
+ -> GoateeEntry
+ -> (GameInfo -> Maybe a)
+ -> (Maybe a -> GameInfo -> GameInfo)
+ -> IO ()
+connectEntry me entry = connectEntry' me entry (return True)
+
+-- | This is like 'connectEntry'. The additional @IO Bool@ can return false to
+-- indicate that a change in the entry should not be written to the model;
+-- returning true writes the change.
+connectEntry' :: (UiCtrl go ui, Stringlike a)
+ => GamePropertiesPanel ui
+ -> GoateeEntry
+ -> IO Bool
+ -> (GameInfo -> Maybe a)
+ -> (Maybe a -> GameInfo -> GameInfo)
+ -> IO ()
+connectEntry' me entry propagateChangesToModel modelGetter modelSetter = do
let ui = myUi me
+ goateeEntryOnChange entry $ \value -> do
+ propagate <- propagateChangesToModel
+ when propagate $ doUiGo ui $ void $ modifyGameInfo $ modelSetter $
+ if null value then Nothing else Just $ stringToSgf value
+ on (goateeEntryWidget entry) focusOutEvent $ liftIO $ do
+ cursor <- readCursor ui
+ goateeEntrySetText entry $ maybe "" sgfToString $ modelGetter $
+ boardGameInfo $ cursorBoard cursor
+ return False
+ return ()
- -- Watch for game info changes.
- viewRegister me gameInfoChangedEvent $ \_ newInfo ->
- afterGo $ updateUiGameInfo me newInfo
+-- | @connect me connectFn setter@ binds a widget to a field in the current
+-- 'GameInfo' so that changes in one affect the other. @connect@ constructs an
+-- @a -> IO ()@ handler that takes a value and puts it into the model using
+-- @setter@, and immediately gives it to @connectFn@, which is in charge of
+-- registering the handler.
+connect :: UiCtrl go ui
+ => GamePropertiesPanel ui
+ -> ((a -> IO ()) -> IO ())
+ -> (a -> GameInfo -> GameInfo)
+ -> IO ()
+connect me connectFn modelSetter =
+ let ui = myUi me
+ in connectFn $ \newValue -> doUiGo ui $ void $ modifyGameInfo $ modelSetter newValue
- -- Watch for node changes.
- let onNodeChange = do cursor <- getCursor
- afterGo $ updateUiNodeInfo me cursor
- viewRegister me navigationEvent $ const onNodeChange
- viewRegister me propertiesModifiedEvent $ const $ const onNodeChange
+destroy :: UiCtrl go ui => GamePropertiesPanel ui -> IO ()
+destroy = viewDestroy
- updateUi me =<< readCursor ui
+update :: UiCtrl go ui => GamePropertiesPanel ui -> IO ()
+update me = do
+ cursor <- readCursor $ myUi me
+ let info = boardGameInfo $ cursorBoard cursor
+ forM_ [ (InfoGetter gameInfoBlackName, myBlackNameEntry)
+ , (InfoGetter gameInfoBlackRank, myBlackRankEntry)
+ , (InfoGetter gameInfoBlackTeamName, myBlackTeamEntry)
- commentBuffer <- textViewGetBuffer $ myComment me
- on commentBuffer bufferChanged $ handleCommentBufferChanged me commentBuffer
+ , (InfoGetter gameInfoWhiteName, myWhiteNameEntry)
+ , (InfoGetter gameInfoWhiteRank, myWhiteRankEntry)
+ , (InfoGetter gameInfoWhiteTeamName, myWhiteTeamEntry)
- connectEntryToGameInfo ui myBlackName $ \x info -> info { gameInfoBlackName = strToMaybe x }
- connectEntryToGameInfo ui myBlackRank $ \x info -> info { gameInfoBlackRank = strToMaybe x }
- connectEntryToGameInfo ui myBlackTeam $ \x info -> info { gameInfoBlackTeamName = strToMaybe x }
- connectEntryToGameInfo ui myWhiteName $ \x info -> info { gameInfoWhiteName = strToMaybe x }
- connectEntryToGameInfo ui myWhiteRank $ \x info -> info { gameInfoWhiteRank = strToMaybe x }
- connectEntryToGameInfo ui myWhiteTeam $ \x info -> info { gameInfoWhiteTeamName = strToMaybe x }
+ , (InfoGetter gameInfoRuleset, myRulesetEntry)
+ , (InfoGetter gameInfoOvertime, myOvertimeEntry)
- where connectEntryToGameInfo ui entryAccessor updater =
- onEntryChange (entryAccessor me) $ \value ->
- runUiGo ui $ void $ modifyGameInfo (updater value)
- strToMaybe str = if null str then Nothing else Just str
+ , (InfoGetter gameInfoAnnotatorName, myGameAnnotatorEntry)
+ , (InfoGetter gameInfoEntererName, myGameEntererEntry)
-destroy :: UiCtrl ui => GamePropertiesPanel ui -> IO ()
-destroy = viewUnregisterAll
+ , (InfoGetter gameInfoEvent, myEventNameEntry)
+ , (InfoGetter gameInfoPlace, myGamePlaceEntry)
+ , (InfoGetter gameInfoRound, myGameRoundEntry)
+ , (InfoGetter gameInfoDatesPlayed, myGameDatesEntry)
+ , (InfoGetter gameInfoGameName, myGameNameEntry)
+ , (InfoGetter gameInfoSource, myGameSourceEntry)
+ , (InfoGetter gameInfoCopyright, myGameCopyrightEntry)
-handleCommentBufferChanged :: UiCtrl ui => GamePropertiesPanel ui -> TextBuffer -> IO ()
-handleCommentBufferChanged me commentBuffer =
- -- Don't push the new comment value back to the model if we're already
- -- updating the view from the model.
- whenLatchOff (myCommentLatch me) $ do
- newComment <- get commentBuffer textBufferText
- runUiGo (myUi me) $ modifyPropertyString propertyC $ const newComment
+ , (InfoGetter gameInfoOpeningComment, myGameOpeningEntry)
+ ] $ \(InfoGetter getter, entry) ->
+ goateeEntrySetText (entry me) $ extractStringlike $ getter info
-updateUi :: UiCtrl ui => GamePropertiesPanel ui -> Cursor -> IO ()
-updateUi me cursor = do
- updateUiGameInfo me $ boardGameInfo $ cursorBoard cursor
- updateUiNodeInfo me cursor
+ -- Update the "main time" spinner.
+ goateeSpinButtonSetValue (myMainTimeSpin me) $ fromMaybe 0 $
+ gameInfoBasicTimeSeconds info
+ labelSetText (myMainTimeLabel me) $ maybe "" renderSeconds $
+ gameInfoBasicTimeSeconds info
-updateUiGameInfo :: GamePropertiesPanel ui -> GameInfo -> IO ()
-updateUiGameInfo me info =
- forM_ [(gameInfoBlackName, myBlackName),
- (gameInfoBlackRank, myBlackRank),
- (gameInfoBlackTeamName, myBlackTeam),
- (gameInfoWhiteName, myWhiteName),
- (gameInfoWhiteRank, myWhiteRank),
- (gameInfoWhiteTeamName, myWhiteTeam)] $ \(getter, entry) ->
- entrySetText (entry me) $ fromMaybe "" $ getter info
+ -- Update the game result entry.
+ let gameResultEntry = myGameResultEntry me
+ displayGameResult <- get (myGameResultDisplayCheck me) toggleButtonActive
+ widgetSetSensitive (goateeEntryWidget gameResultEntry) displayGameResult
+ goateeEntrySetText gameResultEntry $
+ if displayGameResult
+ then extractStringlike $ gameInfoResult info
+ else "(hidden)"
-updateUiNodeInfo :: UiCtrl ui => GamePropertiesPanel ui -> Cursor -> IO ()
-updateUiNodeInfo me cursor = do
- let newText = maybe "" fromText $ findPropertyValue propertyC $ cursorNode cursor
- buf <- textViewGetBuffer $ myComment me
- oldText <- get buf textBufferText
- when (oldText /= newText) $ do
- withLatchOn (myCommentLatch me) $ textBufferSetText buf newText
- -- It's not necessary to call this handler, but we do for consistency, since
- -- all other widgets currently behave this way (write back and forth until
- -- synchronized).
- handleCommentBufferChanged me buf
+ -- Update the game comment TextView.
+ myGameCommentTextViewSetter me $ maybe "" fromText $ gameInfoGameComment info
+
+extractStringlike :: Stringlike a => Maybe a -> String
+extractStringlike = maybe "" sgfToString
+
+renderSeconds :: BF.Bigfloat -> String
+renderSeconds totalSecondsFloat =
+ let isNegative = totalSecondsFloat < 0
+ (wholeSeconds, fractionalSecondsStr) = first abs $ splitFloat totalSecondsFloat
+ (totalMinutes, seconds) = wholeSeconds `divMod` 60
+ (hours, minutes) = totalMinutes `divMod` 60
+ in (if isNegative then ('-':) else id) $
+ (if hours > 0
+ then show hours ++ ':' : show2 minutes ++ ':' : show2 seconds
+ else show minutes ++ ':' : show2 seconds) ++
+ fractionalSecondsStr
+ where show2 n = if n < 10 then '0' : show n else show n
+
+-- | Returns a pair containing the signed whole part of a 'BF.Bigfloat', plus a
+-- string containing a decimal place and everything after it, if the float has a
+-- fractional part, otherwise an empty string.
+splitFloat :: BF.Bigfloat -> (Integer, String)
+splitFloat x =
+ let xs = show x
+ (addNeg, xs') = case xs of
+ '-':xs' -> (('-':), xs')
+ _ -> (id, xs)
+ (hd, tl) = break (== '.') xs'
+ in (read $ addNeg hd, tl)
diff --git a/src/Game/Goatee/Ui/Gtk/Goban.hs b/src/Game/Goatee/Ui/Gtk/Goban.hs
--- a/src/Game/Goatee/Ui/Gtk/Goban.hs
+++ b/src/Game/Goatee/Ui/Gtk/Goban.hs
@@ -24,21 +24,22 @@
) where
import Control.Applicative ((<$>))
-import Control.Monad (liftM, unless, when)
+import Control.Monad ((<=<), liftM, unless, 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, isJust)
+import Data.Maybe (fromJust, fromMaybe, isJust)
import Data.Tree (drawTree, unfoldTree)
import Game.Goatee.Common
-import Game.Goatee.Sgf.Board hiding (isValidMove)
-import Game.Goatee.Sgf.Monad (
- childAddedEvent, modifyMark, navigationEvent, propertiesModifiedEvent,
+import Game.Goatee.Lib.Board hiding (isValidMove)
+import Game.Goatee.Lib.Monad (
+ AnyEvent (..), childAddedEvent, childDeletedEvent, modifyMark, navigationEvent,
+ propertiesModifiedEvent,
)
-import Game.Goatee.Sgf.Property
-import Game.Goatee.Sgf.Tree
-import Game.Goatee.Sgf.Types
+import Game.Goatee.Lib.Property
+import Game.Goatee.Lib.Tree
+import Game.Goatee.Lib.Types
import Game.Goatee.Ui.Gtk.Common
import Graphics.Rendering.Cairo (
Antialias (AntialiasDefault, AntialiasNone),
@@ -47,6 +48,7 @@
closePath,
deviceToUser,
deviceToUserDistance,
+ fill,
fillPreserve,
liftIO,
lineTo,
@@ -55,6 +57,7 @@
paintWithAlpha,
popGroupToSource,
pushGroup,
+ rectangle,
rotate,
scale,
setAntialias,
@@ -62,6 +65,8 @@
setSourceRGB,
stroke,
translate,
+ userToDevice,
+ userToDeviceDistance,
)
import Graphics.UI.Gtk (
DrawingArea,
@@ -70,6 +75,7 @@
Widget,
buttonPressEvent,
drawingAreaNew,
+ drawWindowGetPointerPos,
eventCoordinates, eventKeyName, eventModifier,
exposeEvent,
keyPressEvent,
@@ -91,7 +97,7 @@
useHorizontalKeyNavigation = True
-- Key handler code below requires that these keys don't use modifiers.
-keyNavActions :: UiCtrl a => Map String (a -> IO Bool)
+keyNavActions :: UiCtrl go ui => Map String (ui -> IO Bool)
keyNavActions =
Map.fromList $
if useHorizontalKeyNavigation
@@ -143,6 +149,10 @@
stoneVariationBorderThickness :: Double
stoneVariationBorderThickness = 0.02
+-- | The radius of star points. Percentage of coordinate size, in @[0, 1].
+starPointRadius :: Double
+starPointRadius = 0.1
+
-- | The opacity, in @[0, 1]@, of a stone that should be drawn dimmed because of
-- 'DD'.
dimmedPointOpacity :: Double
@@ -171,31 +181,35 @@
-- | A GTK widget that renders a Go board.
--
-- @ui@ should be an instance of 'UiCtrl'.
-data Goban ui = Goban { myUi :: ui
- , myRegistrations :: ViewRegistrations
- , myWidget :: Widget
- , myDrawingArea :: DrawingArea
- , myModesChangedHandler :: IORef (Maybe Registration)
- }
+data Goban ui = Goban
+ { myUi :: ui
+ , 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)
+ }
-instance UiCtrl ui => UiView (Goban ui) ui where
+instance UiCtrl go ui => UiView go ui (Goban ui) where
viewName = const "Goban"
viewCtrl = myUi
- viewRegistrations = myRegistrations
+ 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)
+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
+data RenderedCoord = RenderedCoord
+ { renderedCoordState :: CoordState
, renderedCoordCurrent :: Bool
, renderedCoordVariation :: Maybe Color
-- ^ If a variation move exists at this point, then this will be the color
@@ -203,11 +217,11 @@
} deriving (Show)
-- | Creates a 'Goban' for rendering Go boards of the given size.
-create :: UiCtrl ui => ui -> IO (Goban ui)
+create :: UiCtrl go ui => ui -> IO (Goban ui)
create ui = do
- hoverStateRef <- newIORef HoverState { hoverCoord = Nothing
- , hoverIsValidMove = False
- }
+ hoverStateRef <- newIORef $ Just HoverState { hoverCoord = Nothing
+ , hoverIsValidMove = False
+ }
drawingArea <- drawingAreaNew
widgetSetCanFocus drawingArea True
@@ -215,17 +229,28 @@
ButtonPressMask,
PointerMotionMask]
+ state <- viewStateNew
+ modesChangedHandler <- newIORef Nothing
+
+ let me = Goban { myUi = ui
+ , myState = state
+ , myWidget = toWidget drawingArea
+ , myDrawingArea = drawingArea
+ , myHoverStateRef = hoverStateRef
+ , myModesChangedHandler = modesChangedHandler
+ }
+
on drawingArea exposeEvent $ liftIO $ do
- drawBoard ui hoverStateRef drawingArea
+ drawBoard me
return True
on drawingArea motionNotifyEvent $ do
mouseCoord <- fmap Just eventCoordinates
- liftIO $ handleMouseMove ui hoverStateRef drawingArea mouseCoord
+ liftIO $ handleMouseMove me mouseCoord
return True
on drawingArea leaveNotifyEvent $ do
- liftIO $ handleMouseMove ui hoverStateRef drawingArea Nothing
+ liftIO $ handleMouseMove me Nothing
return True
on drawingArea buttonPressEvent $ do
@@ -256,61 +281,55 @@
(show $ nodeProperties node, nodeChildren node)
return True)]
- registrations <- viewNewRegistrations
- modesChangedHandler <- newIORef Nothing
-
- let me = Goban { myUi = ui
- , myRegistrations = registrations
- , myWidget = toWidget drawingArea
- , myDrawingArea = drawingArea
- , myModesChangedHandler = modesChangedHandler
- }
-
initialize me
return me
-initialize :: UiCtrl ui => Goban ui -> IO ()
+initialize :: UiCtrl go ui => Goban ui -> IO ()
initialize me = do
let ui = myUi me
- onChange = afterGo $ update me
- viewRegister me childAddedEvent $ const $ const onChange
- viewRegister me navigationEvent $ const onChange
- viewRegister me propertiesModifiedEvent $ const $ const onChange
+ register me
+ [ AnyEvent childAddedEvent
+ , AnyEvent childDeletedEvent
+ , AnyEvent navigationEvent
+ , AnyEvent propertiesModifiedEvent
+ ]
writeIORef (myModesChangedHandler me) =<<
liftM Just (registerModesChangedHandler ui "Goban" $ \_ _ -> update me)
-- TODO Need to update the hover state's validity on cursor and tool (mode?)
-- changes.
- update me
+ --update me
-destroy :: UiCtrl ui => Goban ui -> IO ()
+destroy :: UiCtrl go ui => Goban ui -> IO ()
destroy me = do
let ui = myUi me
- viewUnregisterAll me
F.mapM_ (unregisterModesChangedHandler ui) =<< readIORef (myModesChangedHandler me)
+ viewDestroy me
-update :: UiCtrl ui => Goban ui -> IO ()
-update = widgetQueueDraw . myDrawingArea
+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 a
- => a
- -> IORef HoverState
- -> DrawingArea
+handleMouseMove :: UiCtrl go ui
+ => Goban ui
-> Maybe (Double, Double)
-> IO ()
-handleMouseMove ui hoverStateRef drawingArea maybeClickCoord = do
+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
- updateHoverPosition ui hoverStateRef maybeXy >>= flip when
+ updateHoverState me maybeXy >>= flip when
(widgetQueueDraw drawingArea)
-- | Applies the current tool at the given GTK coordinate, if such an action is
-- valid.
-doToolAtPoint :: UiCtrl ui => ui -> DrawingArea -> (Double, Double) -> IO ()
+doToolAtPoint :: UiCtrl go ui => ui -> DrawingArea -> (Double, Double) -> IO ()
doToolAtPoint ui drawingArea (mouseX, mouseY) = do
cursor <- readCursor ui
let board = cursorBoard cursor
@@ -326,28 +345,55 @@
ToolMarkX -> toggleMark ui xy MarkX
ToolPlay -> do
valid <- isValidMove ui xy
- when valid $ playAt ui xy
+ when valid $ playAt ui $ Just xy
_ -> return () -- TODO Support other tools.
- where toggleMark ui xy mark = runUiGo ui $ modifyMark (toggleMark' mark) xy
+ where toggleMark ui xy mark = doUiGo ui $ modifyMark (toggleMark' mark) xy
toggleMark' mark maybeExistingMark = case maybeExistingMark of
Just existingMark | existingMark == mark -> Nothing
_ -> Just mark
--- | Updates the hover state for the mouse having moved to the given board
--- coordinate. Returns true if the board coordinate has changed.
-updateHoverPosition :: UiCtrl ui => ui -> IORef HoverState -> Maybe Coord -> IO Bool
-updateHoverPosition ui hoverStateRef maybeXy = do
+-- | 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
+
+-- | Clears the cached hover state.
+invalidateHoverState :: Goban ui -> IO ()
+invalidateHoverState me = writeIORef (myHoverStateRef me) Nothing
+
+-- | 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
- if maybeXy == hoverCoord hoverState
- then return False
- else do valid <- case maybeXy of
- Nothing -> return False
- Just xy -> isValidMove ui xy
- writeIORef hoverStateRef HoverState { hoverCoord = maybeXy
- , hoverIsValidMove = valid
- }
- return True
+ 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
+-- | 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 ()
+
applyBoardCoordinates :: BoardState -> DrawingArea -> IO (Render ())
applyBoardCoordinates board drawingArea = do
(canvasWidth, canvasHeight) <- return . mapTuple fromIntegral =<< widgetGetSize drawingArea
@@ -379,11 +425,13 @@
else Just result
-- | Fully redraws the board based on the current controller and UI state.
-drawBoard :: UiCtrl ui => ui -> IORef HoverState -> DrawingArea -> IO ()
-drawBoard ui hoverStateRef drawingArea = do
+drawBoard :: UiCtrl go ui => Goban ui -> IO ()
+drawBoard me = do
+ let ui = myUi me
+ drawingArea = myDrawingArea me
cursor <- readCursor ui
modes <- readModes ui
- hoverState <- readIORef hoverStateRef
+ hoverState <- readHoverState me
let board = cursorBoard cursor
tool = uiTool modes
@@ -422,15 +470,35 @@
y
grid)
(map (map $ \state -> RenderedCoord state False Nothing) $
- mapBoardCoords maybeAddHover board)
+ mapBoardCoords preprocessCoord board)
variations
- maybeAddHover :: Int -> Int -> CoordState -> CoordState
- maybeAddHover y x state = case hoverCoord hoverState of
- Just (hx, hy) | x == hx && y == hy ->
- modifyCoordForHover tool board hoverState state
- _ -> state
+ -- | 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
+ ViewStonesRegularMode -> id
+ ViewStonesOneColorMode -> coerceStone $ uiViewStonesOneColorModeColor modes
+ ViewStonesBlindMode -> setStone Nothing
+ in applyStoneViewMode . maybeAddHover
+ -- | Replaces an existing stone of color opposite to the one given with a
+ -- stone of the given color.
+ coerceStone :: Color -> CoordState -> CoordState
+ coerceStone color state = if coordStone state == Just (cnot color)
+ then state { coordStone = Just color }
+ else state
+
+ -- | Replaces a coordinate's stone.
+ setStone :: Maybe Color -> CoordState -> CoordState
+ setStone color state = if coordStone state == color
+ then state
+ else state { coordStone = color }
+
drawWindow <- widgetGetDrawWindow drawingArea
changeCoords <- applyBoardCoordinates board drawingArea
renderWithDrawable drawWindow $ do
@@ -494,9 +562,9 @@
variation = renderedCoordVariation renderedCoord
-- Translate the grid so that we can draw the stone from (0,0) to (1,1).
translate x' y'
- -- Draw the grid, stone (if present), and mark (if present).
+ -- Draw the grid, stone or star (if present), and mark (if present).
drawGrid board gridWidth gridBorderWidth x y
- F.mapM_ drawStone $ coordStone coord
+ maybe (when (coordStar coord) drawStar) drawStone $ coordStone coord
maybe (return ()) (drawMark $ coordStone coord) $ coordMark coord
case (current, variation) of
-- With @VariationMode ShowChildVariations True@, this is the case of an
@@ -556,16 +624,17 @@
gridY0 = if atTop then 0.5 else 0
gridX1 = if atRight then 0.5 else 1
gridY1 = if atBottom then 0.5 else 1
+ (cx, cy) <- roundToPixels 0.5 0.5
-- Temporarily disable antialiasing. We want grid lines to be sharp.
setAntialias AntialiasNone
setSourceRGB 0 0 0
setLineWidth $ if atTop || atBottom then gridBorderWidth else gridWidth
- moveTo gridX0 0.5
- lineTo gridX1 0.5
+ moveTo gridX0 cy
+ lineTo gridX1 cy
stroke
setLineWidth $ if atLeft || atRight then gridBorderWidth else gridWidth
- moveTo 0.5 gridY0
- lineTo 0.5 gridY1
+ moveTo cx gridY0
+ lineTo cx gridY1
stroke
setAntialias AntialiasDefault
@@ -579,6 +648,26 @@
setRgb $ stoneBorderColor color
stroke
+-- | Draws a dot to indicate that the current point is a star point.
+drawStar :: Render ()
+drawStar = do
+ setSourceRGB 0 0 0
+ -- This seems to be a decent point to transition from an antialiased star to
+ -- an aliased star (well, box), balancing transitioning too early (having a
+ -- jump in size) with too late (and having ugly antialiased bouncing star
+ -- points for a range).
+ let minRadiusOnScreen = 1.8
+ (radiusOnScreen, _) <- userToDeviceDistance starPointRadius 0
+ (cx, cy) <- roundToPixels 0.5 0.5
+ if radiusOnScreen >= minRadiusOnScreen
+ then do arc cx cy starPointRadius 0 pi_2
+ fill
+ else do setAntialias AntialiasNone
+ (pixel, _) <- deviceToUserDistance 1 0
+ rectangle (cx - 2 * pixel) (cy - 2 * pixel) (3 * pixel) (3 * pixel)
+ fill
+ setAntialias AntialiasDefault
+
-- | Draws the given mark on the current point. The color should be that of the
-- stone on the point, if there is one; it determines the color of the mark.
drawMark :: Maybe Color -> Mark -> Render ()
@@ -681,6 +770,11 @@
setLineWidth stoneVariationBorderThickness
setRgb border
stroke
+
+roundToPixels :: Double -> Double -> Render (Double, Double)
+roundToPixels =
+ (uncurry deviceToUser . mapTuple (fromIntegral . (round :: Double -> Int)) <=<) .
+ userToDevice
type Rgb = (Double, Double, Double)
diff --git a/src/Game/Goatee/Ui/Gtk/InfoLine.hs b/src/Game/Goatee/Ui/Gtk/InfoLine.hs
--- a/src/Game/Goatee/Ui/Gtk/InfoLine.hs
+++ b/src/Game/Goatee/Ui/Gtk/InfoLine.hs
@@ -21,66 +21,69 @@
InfoLine,
create,
destroy,
- myLabel,
+ myWidget,
) where
+import Control.Applicative ((<$>))
import Data.Maybe (fromMaybe)
-import Game.Goatee.Sgf.Board
-import Game.Goatee.Sgf.Monad
+import Game.Goatee.Lib.Board
+import Game.Goatee.Lib.Monad
+import Game.Goatee.Lib.Types
import Game.Goatee.Ui.Gtk.Common
-import Graphics.UI.Gtk (Label, labelNew, labelSetMarkup)
+import Graphics.UI.Gtk (Label, Widget, labelNew, labelSetMarkup, toWidget)
-data InfoLine ui = InfoLine { myUi :: ui
- , myRegistrations :: ViewRegistrations
- , myLabel :: Label
- }
+data InfoLine ui = InfoLine
+ { myUi :: ui
+ , myState :: ViewState
+ , myWidget :: Widget
+ , myLabel :: Label
+ }
-instance UiCtrl ui => UiView (InfoLine ui) ui where
+instance UiCtrl go ui => UiView go ui (InfoLine ui) where
viewName = const "InfoLine"
viewCtrl = myUi
- viewRegistrations = myRegistrations
+ viewState = myState
+ viewUpdate = update
-create :: UiCtrl ui => ui -> IO (InfoLine ui)
+create :: UiCtrl go ui => ui -> IO (InfoLine ui)
create ui = do
label <- labelNew Nothing
- registrations <- viewNewRegistrations
+ state <- viewStateNew
let me = InfoLine { myUi = ui
- , myRegistrations = registrations
+ , myState = state
+ , myWidget = toWidget label
, myLabel = label
}
initialize me
return me
-initialize :: UiCtrl ui => InfoLine ui -> IO ()
+initialize :: UiCtrl go ui => InfoLine ui -> IO ()
initialize me = do
- let updateAfter = afterGo . updateWithCursor me =<< getCursor
- viewRegister me childAddedEvent $ const $ const updateAfter
- viewRegister me navigationEvent $ const updateAfter
- viewRegister me propertiesModifiedEvent $ const $ const updateAfter
- update me
-
-destroy :: UiCtrl ui => InfoLine ui -> IO ()
-destroy = viewUnregisterAll
+ register me
+ [ AnyEvent childAddedEvent
+ , AnyEvent childDeletedEvent
+ , AnyEvent navigationEvent
+ , AnyEvent propertiesModifiedEvent
+ ]
+ viewUpdate me
-update :: UiCtrl ui => InfoLine ui -> IO ()
-update me = do
- cursor <- readCursor $ myUi me
- updateWithCursor me cursor
+destroy :: UiCtrl go ui => InfoLine ui -> IO ()
+destroy = viewDestroy
-updateWithCursor :: UiCtrl ui => InfoLine ui -> Cursor -> IO ()
-updateWithCursor me cursor =
- labelSetMarkup (myLabel me) $ generateMarkup cursor
+update :: UiCtrl go ui => InfoLine ui -> IO ()
+update me =
+ labelSetMarkup (myLabel me) . generateMarkup =<< readCursor (myUi me)
generateMarkup :: Cursor -> String
generateMarkup cursor =
let board = cursorBoard cursor
gameInfoMsg = fromMaybe "" $ do
let info = boardGameInfo board
- black <- gameInfoBlackName info
- white <- gameInfoWhiteName info
- let renderRank = maybe "" (\x -> " (" ++ x ++ ")")
+ black <- sgfToString <$> gameInfoBlackName info
+ white <- sgfToString <$> gameInfoWhiteName info
+ let renderRank = maybe "" (\x -> " (" ++ sgfToString x ++ ")")
blackRank = renderRank $ gameInfoBlackRank info
whiteRank = renderRank $ gameInfoWhiteRank info
return $ white ++ whiteRank ++ " vs. " ++ black ++ blackRank ++ "\n"
diff --git a/src/Game/Goatee/Ui/Gtk/Latch.hs b/src/Game/Goatee/Ui/Gtk/Latch.hs
--- a/src/Game/Goatee/Ui/Gtk/Latch.hs
+++ b/src/Game/Goatee/Ui/Gtk/Latch.hs
@@ -30,9 +30,10 @@
-- | A binary switch that is off unless held on during the execution of some IO
-- process. The state of a latch can be read at any time, but can be held on by
-- at most one thread at a time.
-data Latch = Latch { latchValue :: IORef Bool
- , latchLock :: MVar ()
- }
+data Latch = Latch
+ { latchValue :: IORef Bool
+ , latchLock :: MVar ()
+ }
-- | Creates a new latch that is off.
newLatch :: IO Latch
diff --git a/src/Game/Goatee/Ui/Gtk/MainWindow.hs b/src/Game/Goatee/Ui/Gtk/MainWindow.hs
--- a/src/Game/Goatee/Ui/Gtk/MainWindow.hs
+++ b/src/Game/Goatee/Ui/Gtk/MainWindow.hs
@@ -30,7 +30,7 @@
import qualified Data.Foldable as F
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.List (intersperse)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (catMaybes, fromMaybe)
import Game.Goatee.Ui.Gtk.Common
import qualified Game.Goatee.Ui.Gtk.Actions as Actions
import Game.Goatee.Ui.Gtk.Actions (Actions)
@@ -40,6 +40,10 @@
import Game.Goatee.Ui.Gtk.Goban (Goban)
import qualified Game.Goatee.Ui.Gtk.InfoLine as InfoLine
import Game.Goatee.Ui.Gtk.InfoLine (InfoLine)
+import qualified Game.Goatee.Ui.Gtk.NodePropertiesPanel as NodePropertiesPanel
+import Game.Goatee.Ui.Gtk.NodePropertiesPanel (NodePropertiesPanel)
+import qualified Game.Goatee.Ui.Gtk.PlayPanel as PlayPanel
+import Game.Goatee.Ui.Gtk.PlayPanel (PlayPanel)
import Graphics.UI.Gtk (
Action,
Menu,
@@ -49,12 +53,15 @@
boxPackStart,
containerAdd,
deleteEvent,
+ eventKeyName, eventModifier,
hPanedNew,
+ keyPressEvent,
menuBarNew, menuItemNewWithMnemonic, menuItemSetSubmenu, menuNew, menuShellAppend,
notebookAppendPage, notebookNew,
on,
- panedAdd1, panedAdd2, panedSetPosition,
+ panedPack1, panedPack2, panedSetPosition,
separatorMenuItemNew, separatorToolItemNew,
+ toAction,
toolbarNew,
vBoxNew,
widgetDestroy, widgetGrabFocus, widgetShowAll,
@@ -62,17 +69,20 @@
)
import System.IO (hPutStrLn, stderr)
-data MainWindow ui = MainWindow { myUi :: ui
- , myWindow :: Window
- , myActions :: Actions ui
- , myGamePropertiesPanel :: GamePropertiesPanel ui
- , myGoban :: Goban ui
- , myInfoLine :: InfoLine ui
- , myDirtyChangedHandler :: IORef (Maybe Registration)
- , myFilePathChangedHandler :: IORef (Maybe Registration)
- }
+data MainWindow ui = MainWindow
+ { myUi :: ui
+ , myWindow :: Window
+ , myActions :: Actions ui
+ , myInfoLine :: InfoLine ui
+ , myGoban :: Goban ui
+ , myPlayPanel :: PlayPanel ui
+ , myGamePropertiesPanel :: GamePropertiesPanel ui
+ , myNodePropertiesPanel :: NodePropertiesPanel ui
+ , myDirtyChangedHandler :: IORef (Maybe Registration)
+ , myFilePathChangedHandler :: IORef (Maybe Registration)
+ }
-create :: UiCtrl ui => ui -> IO (MainWindow ui)
+create :: UiCtrl go ui => ui -> IO (MainWindow ui)
create ui = do
window <- windowNew
windowSetDefaultSize window 640 480
@@ -112,6 +122,39 @@
, Actions.myFileQuitAction
]
+ menuEdit <- menuItemNewWithMnemonic "_Edit"
+ menuEditMenu <- menuNew
+ menuShellAppend menuBar menuEdit
+ menuItemSetSubmenu menuEdit menuEditMenu
+ addActionsToMenu menuEditMenu actions
+ [ Actions.myEditCutNodeAction
+ , Actions.myEditCopyNodeAction
+ , Actions.myEditPasteNodeAction
+ ]
+
+ menuGame <- menuItemNewWithMnemonic "_Game"
+ menuGameMenu <- menuNew
+ menuShellAppend menuBar menuGame
+ menuItemSetSubmenu menuGame menuGameMenu
+ addActionsToMenu menuGameMenu actions
+ [ Actions.myGamePassAction
+ ]
+
+ menuGameVariations <- menuItemNewWithMnemonic "_Variations"
+ menuGameVariationsMenu <- menuNew
+ containerAdd menuGameMenu menuGameVariations
+ menuItemSetSubmenu menuGameVariations menuGameVariationsMenu
+
+ containerAdd menuGameVariationsMenu =<<
+ actionCreateMenuItem (Actions.myGameVariationsChildAction actions)
+ containerAdd menuGameVariationsMenu =<<
+ actionCreateMenuItem (Actions.myGameVariationsCurrentAction actions)
+ containerAdd menuGameVariationsMenu =<< separatorMenuItemNew
+ containerAdd menuGameVariationsMenu =<<
+ actionCreateMenuItem (Actions.myGameVariationsBoardMarkupOnAction actions)
+ containerAdd menuGameVariationsMenu =<<
+ actionCreateMenuItem (Actions.myGameVariationsBoardMarkupOffAction actions)
+
menuTool <- menuItemNewWithMnemonic "_Tool"
menuToolMenu <- menuNew
menuShellAppend menuBar menuTool
@@ -125,38 +168,38 @@
toolSep <- separatorToolItemNew
containerAdd menuToolMenu menuSep
containerAdd toolbar toolSep) $
+ catMaybes $
flip map toolOrdering $ \toolGroup ->
- forM_ toolGroup $ \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 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
menuView <- menuItemNewWithMnemonic "_View"
menuViewMenu <- menuNew
menuShellAppend menuBar menuView
menuItemSetSubmenu menuView menuViewMenu
- menuViewVariations <- menuItemNewWithMnemonic "_Variations"
- menuViewVariationsMenu <- menuNew
- containerAdd menuViewMenu menuViewVariations
- menuItemSetSubmenu menuViewVariations menuViewVariationsMenu
-
- containerAdd menuViewVariationsMenu =<<
- actionCreateMenuItem (Actions.myViewVariationsChildAction actions)
- containerAdd menuViewVariationsMenu =<<
- actionCreateMenuItem (Actions.myViewVariationsCurrentAction actions)
- containerAdd menuViewVariationsMenu =<< separatorMenuItemNew
- containerAdd menuViewVariationsMenu =<<
- actionCreateMenuItem (Actions.myViewVariationsBoardMarkupOnAction actions)
- containerAdd menuViewVariationsMenu =<<
- actionCreateMenuItem (Actions.myViewVariationsBoardMarkupOffAction actions)
-
containerAdd menuViewMenu =<<
actionCreateMenuItem (Actions.myViewHighlightCurrentMovesAction actions)
+ menuViewStones <- menuItemNewWithMnemonic "_Stones"
+ menuViewStonesMenu <- menuNew
+ containerAdd menuViewMenu menuViewStones
+ menuItemSetSubmenu menuViewStones menuViewStonesMenu
+
+ addActionsToMenu menuViewStonesMenu actions
+ [ toAction . Actions.myViewStonesRegularModeAction
+ , toAction . Actions.myViewStonesOneColorModeAction
+ , toAction . Actions.myViewStonesBlindModeAction
+ ]
+
menuHelp <- menuItemNewWithMnemonic "_Help"
menuHelpMenu <- menuNew
menuShellAppend menuBar menuHelp
@@ -164,7 +207,7 @@
addActionsToMenu menuHelpMenu actions [Actions.myHelpAboutAction]
infoLine <- InfoLine.create ui
- boxPackStart boardBox (InfoLine.myLabel infoLine) PackNatural 0
+ boxPackStart boardBox (InfoLine.myWidget infoLine) PackNatural 0
hPaned <- hPanedNew
boxPackStart boardBox hPaned PackGrow 0
@@ -176,13 +219,17 @@
panedSetPosition hPaned 400 -- (truncate (fromIntegral hPanedMax * 0.8))
goban <- Goban.create ui
- panedAdd1 hPaned $ Goban.myWidget goban
+ panedPack1 hPaned (Goban.myWidget goban) True True
controlsBook <- notebookNew
- panedAdd2 hPaned controlsBook
+ panedPack2 hPaned controlsBook False True
+ playPanel <- PlayPanel.create ui actions
gamePropertiesPanel <- GamePropertiesPanel.create ui
- notebookAppendPage controlsBook (GamePropertiesPanel.myWidget gamePropertiesPanel) "Properties"
+ nodePropertiesPanel <- NodePropertiesPanel.create ui
+ notebookAppendPage controlsBook (PlayPanel.myWidget playPanel) "Play"
+ notebookAppendPage controlsBook (GamePropertiesPanel.myWidget gamePropertiesPanel) "Game"
+ notebookAppendPage controlsBook (NodePropertiesPanel.myWidget nodePropertiesPanel) "Properties"
dirtyChangedHandler <- newIORef Nothing
filePathChangedHandler <- newIORef Nothing
@@ -190,15 +237,28 @@
let me = MainWindow { myUi = ui
, myWindow = window
, myActions = actions
- , myGamePropertiesPanel = gamePropertiesPanel
- , myGoban = goban
, myInfoLine = infoLine
+ , myGoban = goban
+ , myPlayPanel = playPanel
+ , myGamePropertiesPanel = gamePropertiesPanel
+ , myNodePropertiesPanel = nodePropertiesPanel
, myDirtyChangedHandler = dirtyChangedHandler
, myFilePathChangedHandler = filePathChangedHandler
}
initialize me
+ on window keyPressEvent $ do
+ key <- eventKeyName
+ mods <- eventModifier
+ let km = (key, mods)
+ case km of
+ -- Escape focuses the goban.
+ ("Escape", []) -> do
+ liftIO $ widgetGrabFocus $ Goban.myWidget goban
+ return True
+ _ -> return False
+
on window deleteEvent $ liftIO $ do
fileClose ui
return True
@@ -208,7 +268,7 @@
return me
-- | Initialization that must be done after the 'UiCtrl' is available.
-initialize :: UiCtrl ui => MainWindow ui -> IO ()
+initialize :: UiCtrl go ui => MainWindow ui -> IO ()
initialize me = do
let ui = myUi me
@@ -217,12 +277,14 @@
writeIORef (myFilePathChangedHandler me) =<<
liftM Just (registerFilePathChangedHandler ui "MainWindow" True $ \_ _ -> updateWindowTitle me)
-destroy :: UiCtrl ui => MainWindow ui -> IO ()
+destroy :: UiCtrl go ui => MainWindow ui -> IO ()
destroy me = do
Actions.destroy $ myActions me
- GamePropertiesPanel.destroy $ myGamePropertiesPanel me
- Goban.destroy $ myGoban me
InfoLine.destroy $ myInfoLine me
+ Goban.destroy $ myGoban me
+ PlayPanel.destroy $ myPlayPanel me
+ GamePropertiesPanel.destroy $ myGamePropertiesPanel me
+ NodePropertiesPanel.destroy $ myNodePropertiesPanel me
let ui = myUi me
F.mapM_ (unregisterDirtyChangedHandler ui) =<< readIORef (myDirtyChangedHandler me)
@@ -257,7 +319,7 @@
forM_ accessors $ \accessor ->
containerAdd menu =<< actionCreateMenuItem (accessor actions)
-updateWindowTitle :: UiCtrl ui => MainWindow ui -> IO ()
+updateWindowTitle :: UiCtrl go ui => MainWindow ui -> IO ()
updateWindowTitle me = do
let ui = myUi me
fileName <- getFileName ui
diff --git a/src/Game/Goatee/Ui/Gtk/NodePropertiesPanel.hs b/src/Game/Goatee/Ui/Gtk/NodePropertiesPanel.hs
new file mode 100644
--- /dev/null
+++ b/src/Game/Goatee/Ui/Gtk/NodePropertiesPanel.hs
@@ -0,0 +1,249 @@
+-- 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 .
+
+-- | A list widget that displays the current node's properties for viewing and editing.
+module Game.Goatee.Ui.Gtk.NodePropertiesPanel (
+ NodePropertiesPanel,
+ create,
+ destroy,
+ myWidget,
+ ) where
+
+import Control.Arrow ((+++))
+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 Game.Goatee.Lib.Board
+import Game.Goatee.Lib.Monad hiding (on)
+import Game.Goatee.Lib.Parser
+import Game.Goatee.Lib.Property
+import Game.Goatee.Lib.Renderer
+import Game.Goatee.Lib.Renderer.Tree
+import Game.Goatee.Ui.Gtk.Common
+import Graphics.UI.Gtk (
+ AttrOp ((:=)),
+ ListStore,
+ Packing (PackGrow, PackNatural),
+ PolicyType (PolicyAutomatic),
+ ResponseId (ResponseCancel, ResponseOk),
+ TreeViewColumnSizing (TreeViewColumnAutosize),
+ Widget,
+ WrapMode (WrapWord),
+ boxPackStart,
+ bufferChanged,
+ buttonActivated, buttonNewWithLabel,
+ cellLayoutSetAttributes, cellRendererTextNew, cellText,
+ containerAdd,
+ dialogAddButton, dialogGetUpper, dialogNew, dialogRun, dialogSetDefaultResponse,
+ get,
+ hBoxNew,
+ labelNew, labelText,
+ listStoreAppend, listStoreClear, listStoreNew, listStoreToList,
+ on,
+ scrolledWindowNew, scrolledWindowSetPolicy,
+ set,
+ stockAdd, stockCancel, stockEdit,
+ textBufferText,
+ textViewGetBuffer, textViewNew, textViewSetWrapMode,
+ toWidget,
+ treeSelectionGetSelectedRows,
+ treeViewAppendColumn, treeViewColumnNew, treeViewColumnSizing, treeViewColumnPackStart,
+ treeViewColumnTitle, treeViewGetSelection, treeViewNewWithModel,
+ vBoxNew,
+ widgetDestroy, widgetSetSensitive, widgetShowAll,
+ windowSetDefaultSize, windowSetTitle,
+ )
+import Text.ParserCombinators.Parsec (eof, parse, spaces)
+
+data NodePropertiesPanel ui = NodePropertiesPanel
+ { myUi :: ui
+ , myState :: ViewState
+ , myWidget :: Widget
+ , myModel :: ListStore Property
+ , myModelProperties :: IORef [Property]
+ -- ^ A list of properties in the same order as the rows in 'myModel'.
+ }
+
+instance UiCtrl go ui => UiView go ui (NodePropertiesPanel ui) where
+ viewName = const "NodePropertiesPanel"
+ viewCtrl = myUi
+ viewState = myState
+ viewUpdate = update
+
+create :: UiCtrl go ui => ui -> IO (NodePropertiesPanel ui)
+create ui = do
+ vBox <- vBoxNew False 0
+
+ buttonBox <- hBoxNew True 0
+ boxPackStart vBox buttonBox PackNatural 0
+ addButton <- buttonNewWithLabel "Add"
+ editButton <- buttonNewWithLabel "Edit"
+ deleteButton <- buttonNewWithLabel "Del"
+ mapM_ (containerAdd buttonBox) [addButton, editButton, deleteButton]
+
+ model <- listStoreNew []
+ modelProperties <- newIORef []
+ column <- treeViewColumnNew
+ set column [treeViewColumnSizing := TreeViewColumnAutosize,
+ treeViewColumnTitle := "Property"]
+ renderer <- cellRendererTextNew
+ treeViewColumnPackStart column renderer True
+ cellLayoutSetAttributes column renderer model $ \property ->
+ let name = propertyName property
+ value = case runRender $ propertyValueRendererPretty property property of
+ Left _ -> "(render error)" -- TODO Better error handling.
+ Right result -> result
+ in [cellText := name ++ " " ++ value]
+ view <- treeViewNewWithModel model
+ treeViewAppendColumn view column
+ selection <- treeViewGetSelection view
+ viewScroll <- scrolledWindowNew Nothing Nothing
+ scrolledWindowSetPolicy viewScroll PolicyAutomatic PolicyAutomatic
+ containerAdd viewScroll view
+ boxPackStart vBox viewScroll PackGrow 0
+
+ state <- viewStateNew
+
+ let me = NodePropertiesPanel { myUi = ui
+ , myState = state
+ , myWidget = toWidget vBox
+ , myModel = model
+ , myModelProperties = modelProperties
+ }
+
+ on addButton buttonActivated $ do
+ maybeProperty <- runPropertyEditDialog "Add property" stockAdd Nothing
+ Foldable.forM_ maybeProperty $ doUiGo ui . putProperty
+
+ on editButton buttonActivated $ do
+ rows <- map head <$> treeSelectionGetSelectedRows selection
+ case rows of
+ [] -> return ()
+ row:_ -> do
+ oldProperty <- (!! row) <$> readIORef modelProperties
+ maybeNewProperty <- runPropertyEditDialog "Edit property" stockEdit $ Just oldProperty
+ case maybeNewProperty of
+ Nothing -> return ()
+ Just newProperty -> doUiGo ui $ do
+ -- Need to delete the old property when the property type has
+ -- changed.
+ deleteProperty oldProperty
+ putProperty newProperty
+
+ on deleteButton buttonActivated $ do
+ rows <- map head <$> treeSelectionGetSelectedRows selection
+ properties <- readIORef modelProperties
+ unless (null rows) $
+ doUiGo ui $ forM_ rows $ deleteProperty . (properties !!)
+
+ register me
+ [ AnyEvent navigationEvent
+ , AnyEvent propertiesModifiedEvent
+ ]
+
+ viewUpdate me
+ return me
+
+destroy :: UiCtrl go ui => NodePropertiesPanel ui -> IO ()
+destroy = viewDestroy
+
+-- | Updates the 'ListStore' backing the view from the properties on the cursor.
+update :: UiCtrl go ui => NodePropertiesPanel ui -> IO ()
+update me = do
+ cursor <- readCursor $ myUi me
+ let model = myModel me
+ modelProperties = myModelProperties me
+ newProperties = sortBy (compare `Function.on` propertyName) $
+ cursorProperties cursor
+ oldProperties <- listStoreToList model
+ when (newProperties /= oldProperties) $ do
+ listStoreClear model
+ forM_ newProperties $ listStoreAppend model
+ writeIORef modelProperties newProperties
+
+-- | Opens a dialog for editing a property in serialized SGF format. The
+-- initial property may be absent, in which case the input box will start empty.
+-- This function will eiter return 'Nothing' if the edit was cancelled, or
+-- 'Just' a property if the user entered a valid property and chose to accept.
+runPropertyEditDialog :: String -- ^ Dialog title.
+ -> String -- ^ Accept button label.
+ -> Maybe Property -- ^ Initial property value.
+ -> IO (Maybe Property)
+runPropertyEditDialog dialogTitle acceptButtonLabel initialProperty = do
+ dialog <- dialogNew
+ windowSetTitle dialog dialogTitle
+ windowSetDefaultSize dialog 500 225
+ upper <- dialogGetUpper dialog
+
+ helpLabel <- labelNew $ Just "Enter a property in SGF notation."
+ boxPackStart upper helpLabel PackNatural 0
+
+ textView <- textViewNew
+ textViewSetWrapMode textView WrapWord
+ textScroll <- scrolledWindowNew Nothing Nothing
+ scrolledWindowSetPolicy textScroll PolicyAutomatic PolicyAutomatic
+ containerAdd textScroll textView
+ boxPackStart upper textScroll PackGrow 0
+ textBuffer <- textViewGetBuffer textView
+
+ errorLabel <- labelNew Nothing
+ boxPackStart upper errorLabel PackNatural 0
+
+ dialogAddButton dialog stockCancel ResponseCancel
+ acceptButton <- dialogAddButton dialog acceptButtonLabel ResponseOk
+ dialogSetDefaultResponse dialog ResponseOk
+
+ -- Either a parse error (an empty string if the input box is empty) or a
+ -- parsed property.
+ currentState <- newIORef (Left "" :: Either String Property)
+
+ let setState errorOrProperty =
+ case errorOrProperty of
+ Left errorMsg -> do
+ set errorLabel [labelText := errorMsg]
+ writeIORef currentState $ Left errorMsg
+ widgetSetSensitive acceptButton False
+ Right property -> do
+ set errorLabel [labelText := ""]
+ writeIORef currentState $ Right property
+ widgetSetSensitive acceptButton True
+ parseInput = do
+ text <- get textBuffer textBufferText
+ setState $
+ if null text
+ then Left ""
+ else (show +++ id) $
+ parse (spaces *> propertyParser <* spaces <* eof) "" text
+
+ set textBuffer [textBufferText :=
+ maybe "" (either (const "") id . runRender . renderProperty) initialProperty]
+ on textBuffer bufferChanged parseInput
+ parseInput
+
+ widgetShowAll dialog
+ response <- dialogRun dialog
+ widgetDestroy dialog
+ case response of
+ ResponseOk -> do
+ finalState <- readIORef currentState
+ case finalState of
+ Left _ -> return Nothing
+ Right property -> return $ Just property
+ _ -> return Nothing
diff --git a/src/Game/Goatee/Ui/Gtk/PlayPanel.hs b/src/Game/Goatee/Ui/Gtk/PlayPanel.hs
new file mode 100644
--- /dev/null
+++ b/src/Game/Goatee/Ui/Gtk/PlayPanel.hs
@@ -0,0 +1,131 @@
+-- This file is part of Goatee.
+--
+-- Copyright 2014 Bryan Gardiner
+--
+-- Goatee is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- Goatee is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with Goatee. If not, see .
+
+module Game.Goatee.Ui.Gtk.PlayPanel (
+ PlayPanel,
+ create,
+ destroy,
+ myWidget,
+ ) where
+
+import Control.Applicative ((<$>))
+import Control.Monad (void)
+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,
+ )
+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 (
+ Packing (PackGrow, PackNatural),
+ PolicyType (PolicyAutomatic),
+ TextView,
+ Widget,
+ WrapMode (WrapWord),
+ actionActivate,
+ boxPackStart,
+ buttonActivated, buttonNewWithLabel,
+ containerAdd,
+ hBoxNew,
+ on,
+ scrolledWindowNew, scrolledWindowSetPolicy,
+ textViewNew, textViewSetWrapMode,
+ toWidget,
+ vBoxNew,
+ )
+
+data PlayPanel ui = PlayPanel
+ { myUi :: ui
+ , myState :: ViewState
+ , myWidget :: Widget
+ , myComment :: TextView
+ , myCommentSetter :: String -> IO ()
+ }
+
+instance UiCtrl go ui => UiView go ui (PlayPanel ui) where
+ viewName = const "PlayPanel"
+ viewCtrl = myUi
+ viewState = myState
+ viewUpdate = update
+
+create :: UiCtrl go ui => ui -> Actions ui -> IO (PlayPanel ui)
+create ui actions = do
+ box <- vBoxNew False 0
+
+ navBox <- hBoxNew True 0
+ boxPackStart box navBox PackNatural 0
+ startButton <- buttonNewWithLabel "<<"
+ prevButton <- buttonNewWithLabel "<"
+ nextButton <- buttonNewWithLabel ">"
+ 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
+
+ passButton <- buttonNewWithLabel "Pass"
+ boxPackStart box passButton PackNatural 0
+ on passButton buttonActivated $ actionActivate $ Actions.myGamePassAction actions
+
+ comment <- textViewNew
+ textViewSetWrapMode comment WrapWord
+ commentScroll <- scrolledWindowNew Nothing Nothing
+ scrolledWindowSetPolicy commentScroll PolicyAutomatic PolicyAutomatic
+ containerAdd commentScroll comment
+ boxPackStart box commentScroll PackGrow 0
+
+ commentSetter <- textViewConfigure comment $ \value ->
+ doUiGo ui $ modifyPropertyString propertyC $ const value
+
+ state <- viewStateNew
+
+ let me = PlayPanel
+ { myUi = ui
+ , myState = state
+ , myWidget = toWidget box
+ , myComment = comment
+ , myCommentSetter = commentSetter
+ }
+
+ initialize me
+ return me
+
+initialize :: UiCtrl go ui => PlayPanel ui -> IO ()
+initialize me = do
+ register me
+ [ AnyEvent navigationEvent
+ , AnyEvent propertiesModifiedEvent
+ ]
+ viewUpdate me
+
+destroy :: UiCtrl go ui => PlayPanel ui -> IO ()
+destroy = viewDestroy
+
+update :: UiCtrl go ui => PlayPanel ui -> IO ()
+update me =
+ readCursor (myUi me) >>=
+ myCommentSetter me . maybe "" fromText . findPropertyValue propertyC . cursorNode
diff --git a/src/Game/Goatee/Ui/Gtk/Utils.hs b/src/Game/Goatee/Ui/Gtk/Utils.hs
--- a/src/Game/Goatee/Ui/Gtk/Utils.hs
+++ b/src/Game/Goatee/Ui/Gtk/Utils.hs
@@ -18,10 +18,30 @@
-- | General GTK utilities that don't exist in the Gtk2Hs.
module Game.Goatee.Ui.Gtk.Utils (
onEntryChange,
+ spinButtonGetValueAsBigfloat,
+ textViewConfigure
) where
-import Control.Monad (void)
-import Graphics.UI.Gtk (EditableClass, EntryClass, editableChanged, entryGetText, on)
+import Control.Applicative ((<$>))
+import Control.Monad (void, when)
+import qualified Game.Goatee.Common.Bigfloat as BF
+import Game.Goatee.Ui.Gtk.Latch
+import Graphics.UI.Gtk (
+ AttrOp ((:=)),
+ EditableClass,
+ EntryClass,
+ SpinButtonClass,
+ TextViewClass,
+ bufferChanged,
+ editableChanged,
+ entryGetText,
+ get,
+ on,
+ set,
+ spinButtonGetValue,
+ textBufferText,
+ textViewBuffer,
+ )
-- | Registers a handler to be called when the value contained in the entry's
-- buffer changes. The handler is called with the new value.
@@ -32,3 +52,35 @@
onEntryChange entry handler =
void $ on entry editableChanged runHandler
where runHandler = entryGetText entry >>= handler
+
+-- | Retrieves the current value of a spin button as a 'BF.Bigfloat' that's
+-- rounded to the number of digits the spin button is configured for.
+spinButtonGetValueAsBigfloat :: SpinButtonClass self => self -> IO BF.Bigfloat
+spinButtonGetValueAsBigfloat spin = BF.fromDouble <$> spinButtonGetValue spin
+
+-- | Configures event handlers on a 'TextView'.
+textViewConfigure :: TextViewClass self => self -> (String -> IO ()) -> IO (String -> IO ())
+textViewConfigure textView onViewChange = do
+ -- When a 'TextBuffer' is programatically assigned to, two change events are
+ -- fired, one to delete the old text and one to insert the new text. For text
+ -- views connected to models, we don't want to handle the intermediate value
+ -- by writing it back to the model because this triggers dirtyness (for
+ -- example, when moving between two adjacent game nodes with different
+ -- comments, firing the change handler with an empty comment will change the
+ -- node and make the UI dirty). So for convenience, we hold a latch on while
+ -- we are doing a model-to-view update in order to prevent the handler from
+ -- firing while we're doing the assignment, then manually fire the handler
+ -- afterward. This avoids the double-assignment problem.
+ buffer <- get textView textViewBuffer
+ latch <- newLatch
+ on buffer bufferChanged $ whenLatchOff latch $ do
+ newValue <- get buffer textBufferText
+ onViewChange newValue
+ let setValue value = do
+ oldValue <- get buffer textBufferText
+ when (value /= oldValue) $ do
+ withLatchOn latch $ set buffer [textBufferText := value]
+ -- Like other model-view widgets, we keep firing handlers in the view
+ -- and model, writing back and forth until synchronized.
+ onViewChange value
+ return setValue
diff --git a/src/Game/Goatee/Ui/Gtk/Widget.hs b/src/Game/Goatee/Ui/Gtk/Widget.hs
new file mode 100644
--- /dev/null
+++ b/src/Game/Goatee/Ui/Gtk/Widget.hs
@@ -0,0 +1,88 @@
+-- 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 .
+
+-- | Provides wrappers around regular GTK+ widgets, adding support for assigning
+-- to widget values without firing signal handlers.
+module Game.Goatee.Ui.Gtk.Widget (
+ -- * Entry
+ GoateeEntry, goateeEntryWidget, goateeEntryNew, goateeEntryGetText, goateeEntrySetText,
+ goateeEntryOnChange,
+ -- * Spin button
+ GoateeSpinButton, goateeSpinButtonNewWithRange, goateeSpinButtonWidget, goateeSpinButtonGetValue,
+ goateeSpinButtonSetValue, goateeSpinButtonOnSpinned,
+ ) where
+
+import Control.Applicative ((<$>), (<*>))
+import Control.Monad (void)
+import qualified Game.Goatee.Common.Bigfloat as BF
+import Game.Goatee.Ui.Gtk.Latch
+import Game.Goatee.Ui.Gtk.Utils
+import Graphics.UI.Gtk (
+ AttrOp ((:=)),
+ Entry,
+ SpinButton,
+ entryNew, entryText,
+ get,
+ onValueSpinned,
+ set,
+ spinButtonNewWithRange, spinButtonSetValue,
+ )
+
+data GoateeEntry = GoateeEntry Entry Latch
+
+goateeEntryNew :: IO GoateeEntry
+goateeEntryNew = GoateeEntry <$> entryNew <*> newLatch
+
+goateeEntryWidget :: GoateeEntry -> Entry
+goateeEntryWidget (GoateeEntry entry _) = entry
+
+goateeEntryGetText :: GoateeEntry -> IO String
+goateeEntryGetText (GoateeEntry entry _) = get entry entryText
+
+-- | Sets an entry's value without firing handlers registered through
+-- 'goateeEntryOnChange'.
+goateeEntrySetText :: GoateeEntry -> String -> IO ()
+goateeEntrySetText (GoateeEntry entry latch) value =
+ withLatchOn latch $ set entry [entryText := value]
+
+goateeEntryOnChange :: GoateeEntry -> (String -> IO ()) -> IO ()
+goateeEntryOnChange (GoateeEntry entry latch) handler =
+ onEntryChange entry $ \value -> whenLatchOff latch $ handler value
+
+data GoateeSpinButton = GoateeSpinButton SpinButton Latch
+
+goateeSpinButtonNewWithRange :: Double -> Double -> Double -> IO GoateeSpinButton
+goateeSpinButtonNewWithRange min max step =
+ GoateeSpinButton <$> spinButtonNewWithRange min max step <*> newLatch
+
+goateeSpinButtonWidget :: GoateeSpinButton -> SpinButton
+goateeSpinButtonWidget (GoateeSpinButton spinButton _) = spinButton
+
+goateeSpinButtonGetValue :: GoateeSpinButton -> IO BF.Bigfloat
+goateeSpinButtonGetValue (GoateeSpinButton spinButton _) =
+ spinButtonGetValueAsBigfloat spinButton
+
+-- | Sets a spin button's value without firing handlers registered through
+-- 'goateeSpinButtonOnSpinned'.
+goateeSpinButtonSetValue :: GoateeSpinButton -> BF.Bigfloat -> IO ()
+goateeSpinButtonSetValue (GoateeSpinButton spinButton latch) value =
+ withLatchOn latch $ spinButtonSetValue spinButton $ BF.toDouble value
+
+goateeSpinButtonOnSpinned :: GoateeSpinButton -> (BF.Bigfloat -> IO ()) -> IO ()
+goateeSpinButtonOnSpinned (GoateeSpinButton spinButton latch) handler =
+ void $ onValueSpinned spinButton $ whenLatchOff latch $
+ spinButtonGetValueAsBigfloat spinButton >>= handler
diff --git a/tests/Game/Goatee/Ui/Gtk/LatchTest.hs b/tests/Game/Goatee/Ui/Gtk/LatchTest.hs
--- a/tests/Game/Goatee/Ui/Gtk/LatchTest.hs
+++ b/tests/Game/Goatee/Ui/Gtk/LatchTest.hs
@@ -19,29 +19,27 @@
import Data.IORef (modifyIORef, newIORef, readIORef)
import Game.Goatee.Ui.Gtk.Latch
-import Test.Framework (testGroup)
-import Test.Framework.Providers.HUnit (testCase)
-import Test.HUnit ((@=?))
+import Test.HUnit ((~:), (@=?), Test (TestList))
{-# ANN module "HLint: ignore Reduce duplication" #-}
-tests = testGroup "Game.Goatee.Ui.Gtk.Latch" [
- testCase "a new latch is off" $ do
+tests = "Game.Goatee.Ui.Gtk.Latch" ~: TestList
+ [ "a new latch is off" ~: do
latch <- newLatch
ref <- newIORef 0
whenLatchOff latch $ modifyIORef ref (+ 1)
whenLatchOn latch $ modifyIORef ref (+ 2)
- (1 @=?) =<< readIORef ref,
+ (1 @=?) =<< readIORef ref
- testCase "a latch can be held on" $ do
+ , "a latch can be held on" ~: do
latch <- newLatch
ref <- newIORef 0
withLatchOn latch $ do
whenLatchOff latch $ modifyIORef ref (+ 1)
whenLatchOn latch $ modifyIORef ref (+ 2)
- (2 @=?) =<< readIORef ref,
+ (2 @=?) =<< readIORef ref
- testCase "a new latch returns to being off after it is released" $ do
+ , "a new latch returns to being off after it is released" ~: do
latch <- newLatch
ref <- newIORef 0
withLatchOn latch $ do
diff --git a/tests/Test.hs b/tests/Test.hs
--- a/tests/Test.hs
+++ b/tests/Test.hs
@@ -18,10 +18,16 @@
module Main (main) where
import qualified Game.Goatee.Ui.Gtk.LatchTest
-import Test.Framework (defaultMain)
+import System.Exit (exitFailure, exitSuccess)
+import Test.HUnit (Counts (errors, failures), Test (TestList), runTestTT)
-tests = [ Game.Goatee.Ui.Gtk.LatchTest.tests
- ]
+tests = TestList
+ [ Game.Goatee.Ui.Gtk.LatchTest.tests
+ ]
main :: IO ()
-main = defaultMain tests
+main = do
+ counts <- runTestTT tests
+ if errors counts > 0 || failures counts > 0
+ then exitFailure
+ else exitSuccess