module Game.Goatee.Ui.Gtk.Tool.Line (
LineTool, create,
LinelikeDescriptor, arrowDescriptor, lineDescriptor,
) where
import Data.List (delete)
import Game.Goatee.Lib.Board
import Game.Goatee.Lib.Monad
import Game.Goatee.Lib.Property
import Game.Goatee.Lib.Types
import Game.Goatee.Ui.Gtk.Common
data LineTool ui = LineTool
{ myUi :: ui
, myViewState :: ViewState
, myToolState :: ToolState
, myDescriptor :: AnyLinelikeDescriptor
}
data LinelikeDescriptor v = LinelikeDescriptor
{ linelikeDescriptor :: ValuedPropertyInfo [v]
, linelikeLift :: (Coord, Coord) -> v
}
data AnyLinelikeDescriptor = forall v. Eq v => AnyLinelikeDescriptor (LinelikeDescriptor v)
arrowDescriptor :: AnyLinelikeDescriptor
arrowDescriptor = AnyLinelikeDescriptor LinelikeDescriptor
{ linelikeDescriptor = propertyAR
, linelikeLift = id
}
lineDescriptor :: AnyLinelikeDescriptor
lineDescriptor = AnyLinelikeDescriptor LinelikeDescriptor
{ linelikeDescriptor = propertyLN
, linelikeLift = uncurry Line
}
instance UiCtrl go ui => UiView go ui (LineTool ui) where
viewName me = case myDescriptor me of
AnyLinelikeDescriptor descriptor ->
"LineTool(" ++ propertyName (linelikeDescriptor descriptor) ++ ")"
viewCtrl = myUi
viewState = myViewState
viewUpdate = const $ return ()
instance UiCtrl go ui => UiTool go ui (LineTool ui) where
toolState = myToolState
toolGobanClickComplete me (Just from) (Just to) | from /= to = case myDescriptor me of
AnyLinelikeDescriptor linelike ->
doUiGo (myUi me) $
modifyPropertyList (linelikeDescriptor linelike) $
toggleInList $ linelikeLift linelike (from, to)
toolGobanClickComplete _ _ _ = return ()
toolGobanRenderGetBoard me cursor = do
state <- toolGetGobanState me
case state of
ToolGobanDragging _ (Just startCoord) (Just endCoord) | startCoord /= endCoord ->
case myDescriptor me of
AnyLinelikeDescriptor linelike ->
return $ cursorBoard $ flip execGo cursor $
modifyPropertyList (linelikeDescriptor linelike) $
toggleInList $ linelikeLift linelike (startCoord, endCoord)
_ -> return $ cursorBoard cursor
create :: UiCtrl go ui => ui -> AnyLinelikeDescriptor -> ToolState -> IO (LineTool ui)
create ui descriptor toolState = do
viewState <- viewStateNew
return LineTool
{ myUi = ui
, myViewState = viewState
, myToolState = toolState
, myDescriptor = descriptor
}
toggleInList :: Eq a => a -> [a] -> [a]
toggleInList x xs = (if x `elem` xs then delete else (:)) x xs