goatee-gtk-0.3.0: src/Game/Goatee/Ui/Gtk/Goban.hs
-- This file is part of Goatee.
--
-- Copyright 2014-2015 Bryan Gardiner
--
-- Goatee is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- Goatee is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with Goatee. If not, see <http://www.gnu.org/licenses/>.
-- | A widget that renders an interactive Go board.
module Game.Goatee.Ui.Gtk.Goban (
Goban,
create,
destroy,
myWidget,
) where
import Control.Applicative ((<$>))
import Control.Monad ((<=<), liftM, unless, void, when)
import qualified Data.Foldable as F
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (fromJust, isJust)
import Data.Tree (drawTree, unfoldTree)
import Game.Goatee.Common
import Game.Goatee.Lib.Board hiding (isValidMove)
import Game.Goatee.Lib.Monad (
AnyEvent (..),
childAddedEvent,
childDeletedEvent,
goDown,
goLeft,
goRight,
goToRoot,
goUp,
navigationEvent,
propertiesModifiedEvent,
)
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),
Render,
arc,
closePath,
deviceToUser,
deviceToUserDistance,
fill,
fillPreserve,
liftIO,
lineTo,
moveTo,
paint,
paintWithAlpha,
popGroupToSource,
pushGroup,
rectangle,
rotate,
scale,
setAntialias,
setLineWidth,
setSourceRGB,
stroke,
translate,
userToDevice,
userToDeviceDistance,
)
import Graphics.UI.Gtk (
DrawingArea,
EventMask (ButtonPressMask, LeaveNotifyMask, PointerMotionMask),
Modifier (Shift),
MouseButton,
Widget,
buttonPressEvent, buttonReleaseEvent,
drawingAreaNew,
eventButton, eventCoordinates, eventKeyName, eventModifier,
exposeEvent,
keyPressEvent,
leaveNotifyEvent,
motionNotifyEvent,
on,
renderWithDrawable,
toWidget,
widgetAddEvents, widgetGetDrawWindow, widgetGetSize, widgetGrabFocus, widgetQueueDraw,
widgetSetCanFocus,
)
{-# ANN module "HLint: ignore Use camelCase" #-}
-- | If false, then the up and down keys will move toward and away
-- from the game tree root, and left and right will move between
-- siblings. If true, these are reversed.
useHorizontalKeyNavigation :: Bool
useHorizontalKeyNavigation = True
-- Key handler code below requires that these keys don't use modifiers.
keyNavActions :: UiCtrl go ui => Map String (ui -> IO ())
keyNavActions =
Map.fromList $
--map (fmap ((>> return ()) .)) -- Drop the booleans these actions return.
map (fmap $ \action ui -> doUiGo ui $ void action)
(if useHorizontalKeyNavigation
then [ ("Up", goLeft)
, ("Down", goRight)
, ("Left", goUp)
, ("Right", goDown 0)
]
else [ ("Up", goUp)
, ("Down", goDown 0)
, ("Left", goLeft)
, ("Right", goRight)
]) ++
[ ("Home", flip doUiGo goToRoot)
, ("End", flip doUiGo $ whileM (goDown 0) $ return ())
, ("Page_Up", flip doUiGo $ void $ andM $ replicate 10 goUp)
, ("Page_Down", flip doUiGo $ void $ andM $ replicate 10 $ goDown 0)
]
boardBgColor :: Rgb
boardBgColor = rgb255 229 178 58
blackStoneColor :: Rgb
blackStoneColor = rgb 0 0 0
blackStoneBorderColor :: Rgb
blackStoneBorderColor = rgb 1 1 1
whiteStoneColor :: Rgb
whiteStoneColor = rgb 1 1 1
whiteStoneBorderColor :: Rgb
whiteStoneBorderColor = rgb 0 0 0
stoneColor :: Color -> Rgb
stoneColor color = case color of
Black -> blackStoneColor
White -> whiteStoneColor
stoneBorderColor :: Color -> Rgb
stoneBorderColor color = case color of
Black -> blackStoneBorderColor
White -> whiteStoneBorderColor
-- | Percentage of coordinate size, in @[0, 1]@.
stoneBorderThickness :: Double
stoneBorderThickness = 0.03
-- | The radius of small circles that are overlaid on points to indicate that
-- move variations exist. Percentage of coordinate size, in @[0, 1]@.
stoneVariationRadius :: Double
stoneVariationRadius = 0.15
-- | The width of the border of a variation circle. Percentage of coordinate
-- size, in @[0, 1]@.
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
dimmedPointOpacity = 0.3
-- | Returns the color that should be used to draw a 'Mark' on either an empty
-- point, or one with a stone of the given color.
coordAnnotationStrokeColor :: Maybe Color -> Rgb
coordAnnotationStrokeColor = maybe blackStoneColor stoneBorderColor
-- | For line and arrow annotations, the width of the line. 1 is the width of a
-- stone.
boardAnnotationLineWidth :: Double
boardAnnotationLineWidth = 0.08
-- | For arrow annotations, the distance to pull back along the length of a line
-- before extending at right angles to form the arrowhead.
boardAnnotationArrowPullback :: Double
boardAnnotationArrowPullback = 0.2
-- | For arrow annotations, the distance to extend away from the baseline in
-- either direction to form the arrowhead.
boardAnnotationArrowWidth :: Double
boardAnnotationArrowWidth = 0.1
-- | A GTK widget that renders a Go board.
--
-- @ui@ should be an instance of 'UiCtrl'.
data Goban ui = Goban
{ myUi :: ui
, myState :: ViewState
, myWidget :: Widget
, myDrawingArea :: DrawingArea
, myModesChangedHandler :: IORef (Maybe Registration)
}
instance UiCtrl go ui => UiView go ui (Goban ui) where
viewName = const "Goban"
viewCtrl = myUi
viewState = myState
viewUpdate = update
-- | Creates a 'Goban' for rendering Go boards of the given size.
create :: UiCtrl go ui => ui -> IO (Goban ui)
create ui = do
drawingArea <- drawingAreaNew
widgetSetCanFocus drawingArea True
widgetAddEvents drawingArea [LeaveNotifyMask,
ButtonPressMask,
PointerMotionMask]
state <- viewStateNew
modesChangedHandler <- newIORef Nothing
let me = Goban { myUi = ui
, myState = state
, myWidget = toWidget drawingArea
, myDrawingArea = drawingArea
, myModesChangedHandler = modesChangedHandler
}
on drawingArea exposeEvent $ liftIO $ do
drawBoard me
return True
on drawingArea motionNotifyEvent $ do
mouseCoord <- fmap Just eventCoordinates
liftIO $ handleMouseMove me mouseCoord
return True
on drawingArea leaveNotifyEvent $ do
liftIO $ handleMouseMove me Nothing
return True
on drawingArea buttonPressEvent $ do
mouseButton <- eventButton
mouseCoord <- eventCoordinates
liftIO $ handleMouseDown me mouseButton mouseCoord
return True
on drawingArea buttonReleaseEvent $ do
mouseButton <- eventButton
mouseCoord <- eventCoordinates
liftIO $ handleMouseUp me mouseButton mouseCoord
return True
on drawingArea keyPressEvent $ do
key <- eventKeyName
mods <- eventModifier
let km = (key, mods)
let maybeAction = Map.lookup key keyNavActions
cond (return False)
[(null mods && isJust maybeAction,
liftIO $ fromJust maybeAction ui >> return True),
-- Write a list of the current node's properties to the console.
(km == ("t", []), liftIO $ do
cursor <- readCursor ui
print $ nodeProperties $ cursorNode cursor
return True),
-- Draw a tree rooted at the current node to the console.
(km == ("T", [Shift]), liftIO $ do
cursor <- readCursor ui
putStrLn $ drawTree $ flip unfoldTree (cursorNode cursor) $ \node ->
(show $ nodeProperties node, nodeChildren node)
return True)]
initialize me
return me
initialize :: UiCtrl go ui => Goban ui -> IO ()
initialize me = do
let ui = myUi me
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
destroy :: UiCtrl go ui => Goban ui -> IO ()
destroy me = do
let ui = myUi me
F.mapM_ (unregisterModesChangedHandler ui) =<< readIORef (myModesChangedHandler me)
viewDestroy me
update :: UiCtrl go ui => Goban ui -> IO ()
update me = do
fireGobanEvent me GobanInvalidate
redraw me
-- | Notifies the active tool that a mouse button was pressed down over the
-- board.
handleMouseDown :: UiCtrl go ui => Goban ui -> MouseButton -> (Double, Double) -> IO ()
handleMouseDown me mouseButton mouseCoord = do
widgetGrabFocus $ myDrawingArea me
maybeCoord <- gtkToBoardCoordinates me mouseCoord
fireGobanEvent me $ GobanClickStart mouseButton maybeCoord
-- | Notifies the active tool that a mouse click or drag that started with the
-- mouse being pressed down over the board has completed.
handleMouseUp :: UiCtrl go ui => Goban ui -> MouseButton -> (Double, Double) -> IO ()
handleMouseUp me mouseButton mouseCoord = do
maybeCoord <- gtkToBoardCoordinates me mouseCoord
fireGobanEvent me $ GobanClickFinish mouseButton maybeCoord
-- | notifies the active tool that the mouse has moved over the board.
handleMouseMove :: UiCtrl go ui => Goban ui -> Maybe (Double, Double) -> IO ()
handleMouseMove me maybeMouseCoord = do
maybeCoord <- maybe (return Nothing) (gtkToBoardCoordinates me) maybeMouseCoord
fireGobanEvent me $ GobanMouseMove maybeCoord
-- | Sends an event to the active tool.
fireGobanEvent :: UiCtrl go ui => Goban ui -> GobanEvent -> IO ()
fireGobanEvent me event = do
AnyTool tool <- readTool $ myUi me
doRedraw <- toolGobanHandleEvent tool event
when doRedraw $ redraw me
applyBoardCoordinates :: BoardState -> DrawingArea -> IO (Render ())
applyBoardCoordinates board drawingArea = do
(canvasWidth, canvasHeight) <- return . mapTuple fromIntegral =<< widgetGetSize drawingArea
let maxStoneWidth = canvasWidth / fromIntegral (boardWidth board)
maxStoneHeight = canvasHeight / fromIntegral (boardHeight board)
maxStoneLength = min maxStoneWidth maxStoneHeight
return $ do
-- Set user coordinates so that the top-left stone occupies the rectangle
-- from (0,0) to (1,1).
when (canvasWidth > canvasHeight) $ translate ((canvasWidth - canvasHeight) / 2) 0
when (canvasHeight > canvasWidth) $ translate 0 ((canvasHeight - canvasWidth) / 2)
scale maxStoneLength maxStoneLength
-- | Takes a GTK coordinate and, using a Cairo rendering context, returns the
-- corresponding board coordinate, or @Nothing@ if the GTK coordinate is not
-- over the board.
gtkToBoardCoordinates :: UiCtrl go ui => Goban ui -> (Double, Double) -> IO (Maybe (Int, Int))
gtkToBoardCoordinates me (x, y) = do
let ui = myUi me
drawingArea = myDrawingArea me
board <- cursorBoard <$> readCursor ui
drawWindow <- widgetGetDrawWindow drawingArea
changeCoords <- applyBoardCoordinates board drawingArea
result@(bx, by) <- fmap (mapTuple floor) $
renderWithDrawable drawWindow $
changeCoords >> deviceToUser x y
return $ if bx < 0 || bx >= boardWidth board ||
by < 0 || by >= boardHeight board
then Nothing
else Just result
-- | Schedules the goban to repaint.
redraw :: UiCtrl go ui => Goban ui -> IO ()
redraw = widgetQueueDraw . myDrawingArea
-- | Fully redraws the board based on the current controller and UI state.
drawBoard :: UiCtrl go ui => Goban ui -> IO ()
drawBoard me = do
let ui = myUi me
drawingArea = myDrawingArea me
cursor <- readCursor ui
modes <- readModes ui
AnyTool tool <- readTool ui
board <- toolGobanRenderGetBoard tool cursor
let variationMode = rootInfoVariationMode $ gameInfoRootInfo $ boardGameInfo $ cursorBoard cursor
variations :: [(Coord, Color)]
variations = if variationModeBoardMarkup variationMode
then cursorVariations (variationModeSource variationMode) cursor
else []
-- Positions of stones that have been played at the current node.
current :: [Coord]
current = if uiHighlightCurrentMovesMode modes
then concatMap (\prop -> case prop of
B (Just xy) -> [xy]
W (Just xy) -> [xy]
_ -> []) $
cursorProperties cursor
else []
-- | Performs processing at the individual coord level based on UI state.
preprocessCoord :: CoordState -> CoordState
preprocessCoord =
let applyStoneViewMode = case uiViewStonesMode modes of
ViewStonesRegularMode -> id
ViewStonesOneColorMode -> coerceStone $ uiViewStonesOneColorModeColor modes
ViewStonesBlindMode -> setStone Nothing
in applyStoneViewMode
-- | 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 }
-- The state of the board's points, with all data for rendering.
renderedCoords <-
toolGobanRenderModifyCoords tool board $
-- Add current moves.
(flip .)
foldr (\(x, y) grid ->
listUpdate (flip listUpdate x $
\renderedCoord -> renderedCoord { renderedCoordCurrent = True })
y
grid)
current $
-- Add variations.
foldr (\((x, y), color) grid ->
listUpdate (flip listUpdate x $
\renderedCoord -> renderedCoord { renderedCoordVariation = Just color })
y
grid)
(map (map $ (\state -> RenderedCoord state False Nothing) . preprocessCoord) $
boardCoordStates board)
variations
drawWindow <- widgetGetDrawWindow drawingArea
changeCoords <- applyBoardCoordinates board drawingArea
renderWithDrawable drawWindow $ do
changeCoords
-- Fill the background a nice woody shade.
setRgb boardBgColor
paint
-- Draw the grid and all points.
gridLineWidth <- fst <$> deviceToUserDistance 1 0
let drawCoord' = drawCoord board gridLineWidth (gridLineWidth * 2)
-- First draw points that are visible and not dimmed.
forIndexM_ renderedCoords $ \y row ->
forIndexM_ row $ \x renderedCoord -> do
let coord = renderedCoordState renderedCoord
when (coordVisible coord && not (coordDimmed coord)) $
drawCoord' x y renderedCoord
-- Then draw visible but dimmed points. This is performed under a single
-- Cairo group for performance reasons. (Having a group for each dimmed
-- point is *really* slow with a board full of dimmed points.)
pushGroup
forIndexM_ renderedCoords $ \y row ->
forIndexM_ row $ \x renderedCoord -> do
let coord = renderedCoordState renderedCoord
when (coordVisible coord && coordDimmed coord) $
drawCoord' x y renderedCoord
popGroupToSource
paintWithAlpha dimmedPointOpacity
-- Draw non-CoordState-based annotations.
unless (null (boardLines board) && null (boardArrows board)) $ do
setSourceRGB 0 0 0
setLineWidth boardAnnotationLineWidth
mapM_ (uncurry drawLine . lineToPair) $ boardLines board
mapM_ (uncurry drawArrow) $ boardArrows board
return ()
-- | Draws a single point on the board.
drawCoord :: BoardState
-- ^ The board being drawn.
-> Double
-- ^ The pixel width of the grid in the board's interior.
-> Double
-- ^ The pixel width of the grid on the board's border.
-> Int
-- ^ The x-index of the point to be drawn.
-> Int
-- ^ The y-index of the point to be drawn.
-> RenderedCoord
-- ^ The point to be drawn.
-> Render ()
drawCoord board gridWidth gridBorderWidth x y renderedCoord = do
let x' = fromIntegral x
y' = fromIntegral y
coord = renderedCoordState renderedCoord
current = renderedCoordCurrent renderedCoord
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 or star (if present), and mark (if present).
drawGrid board gridWidth gridBorderWidth x y
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
-- immediately recaptured ko. With @ShowCurrentVariations@ and a valid SGF
-- this case shouldn't happen.
(True, Just variation') -> do drawCurrent True
drawVariation variation' True
(True, _) -> drawCurrent False
(_, Just variation') -> drawVariation variation' False
_ -> return ()
-- Restore the coordinate system for the next stone.
translate (-x') (-y')
-- | Draws the gridlines for a single point on the board.
drawGrid :: BoardState -> Double -> Double -> Int -> Int -> Render ()
drawGrid board gridWidth gridBorderWidth x y = do
-- Draw the grid.
let atLeft = x == 0
atTop = y == 0
atRight = x == boardWidth board - 1
atBottom = y == boardHeight board - 1
gridX0 = if atLeft then 0.5 else 0
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 cy
lineTo gridX1 cy
stroke
setLineWidth $ if atLeft || atRight then gridBorderWidth else gridWidth
moveTo cx gridY0
lineTo cx gridY1
stroke
setAntialias AntialiasDefault
-- | Draws a stone from @(0, 0)@ to @(1, 1)@ in user coordinates.
drawStone :: Color -> Render ()
drawStone color = do
arc 0.5 0.5 (0.5 - stoneBorderThickness / 2) 0 pi_2
setRgb $ stoneColor color
fillPreserve
setLineWidth stoneBorderThickness
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 ()
drawMark stone mark = do
case mark of
MarkCircle -> arc 0.5 0.5 0.25 0 pi_2
MarkTriangle -> do moveTo trianglePoint1X trianglePoint1Y
lineTo trianglePoint2X trianglePoint2Y
lineTo trianglePoint3X trianglePoint3Y
closePath
MarkSquare -> do moveTo 0.25 0.25
lineTo 0.25 0.75
lineTo 0.75 0.75
lineTo 0.75 0.25
closePath
MarkX -> do moveTo 0.25 0.25
lineTo 0.75 0.75
moveTo 0.25 0.75
lineTo 0.75 0.25
MarkSelected -> do moveTo 0.2 0.5
lineTo 0.5 0.8
lineTo 0.8 0.5
lineTo 0.5 0.2
closePath
setRgb $ coordAnnotationStrokeColor stone
setLineWidth 0.1
stroke
-- The coordinates for inscribing a triangle within a unit circle centered about
-- @(0.5, 0.5)@, with radius @triangleRadius@.
triangleRadius, trianglePoint1X, trianglePoint1Y, trianglePoint2X, trianglePoint2Y :: Double
trianglePoint3X, trianglePoint3Y :: Double
triangleRadius = 0.3
trianglePoint1X = 0.5
trianglePoint1Y = 0.5 - triangleRadius
trianglePoint2X = 0.5 - triangleRadius * cos (pi / 6)
trianglePoint2Y = 0.5 + triangleRadius * 0.5 {-sin (pi / 6)-}
trianglePoint3X = 0.5 + triangleRadius * cos (pi / 6)
trianglePoint3Y = 0.5 + triangleRadius * 0.5 {-sin (pi / 6)-}
-- | Draws a line between the given board points. Expects the context to be
-- already set up to draw.
drawLine :: Coord -> Coord -> Render ()
drawLine (fromIntegral -> x0, fromIntegral -> y0)
(fromIntegral -> x1, fromIntegral -> y1) = do
moveTo (x0 + 0.5) (y0 + 0.5)
lineTo (x1 + 0.5) (y1 + 0.5)
stroke
-- | Draws an arrow from the first point to the second point. Expects the
-- context to be already set up to draw.
drawArrow :: Coord -> Coord -> Render ()
drawArrow (fromIntegral -> x0, fromIntegral -> y0)
(fromIntegral -> x1, fromIntegral -> y1) = do
let angle = atan ((y1 - y0) / (x1 - x0)) + if x0 <= x1 then 0 else pi
len = sqrt ((y1 - y0)**2 + (x1 - x0)**2) - boardAnnotationLineWidth
tx = x0 + 0.5
ty = y0 + 0.5
-- Set up user space so that we can draw the line from (0,0) to
-- (0,lineLength).
translate tx ty
rotate angle
moveTo 0 0
lineTo len 0
stroke
moveTo len 0
lineTo (len - boardAnnotationArrowPullback) boardAnnotationArrowWidth
lineTo (len - boardAnnotationArrowPullback) (-boardAnnotationArrowWidth)
closePath
stroke
rotate (-angle)
translate (-tx) (-ty)
-- | Draws a dot via 'drawSmallDot' to indicate that a variation is available
-- where the given player plays a stone here. The dot is of the given color.
-- If the boolean is true, then a semicircle is drawn that will not overlap with
-- a similar semicircle drawn by 'drawCurrent'.
drawVariation :: Color -> Bool -> Render ()
drawVariation stone half =
let angle0 = if half then pi_1_75 else 0
angle1 = if half then pi_0_75 else pi_2
in drawSmallDot (stoneColor stone) (stoneBorderColor stone) angle0 angle1
-- | Draws a dot via 'drawSmallDot' to indicate that the current coordinate was
-- played on in the current node. If the boolean is true, then a semicircle is
-- drawn that will not overlap with a similar semicircle drawn by
-- 'drawVariation'.
drawCurrent :: Bool -> Render ()
drawCurrent half =
let angle0 = if half then pi_0_75 else 0
angle1 = if half then pi_1_75 else pi_2
in drawSmallDot (0,0,1) (0,0,0) angle0 angle1
-- | Draws a small filled arc centered on the current coordinate being drawn.
drawSmallDot :: Rgb -> Rgb -> Double -> Double -> Render ()
drawSmallDot fill border angle0 angle1 = do
arc 0.5 0.5 stoneVariationRadius angle0 angle1
setRgb fill
fillPreserve
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)
rgb :: Double -> Double -> Double -> Rgb
rgb = (,,)
rgb255 :: Double -> Double -> Double -> Rgb
rgb255 r g b = (r / 255, g / 255, b / 255)
setRgb :: Rgb -> Render ()
setRgb (r, g, b) = setSourceRGB r g b
pi_0_75, pi_1_75, pi_2 :: Floating a => a
pi_0_75 = pi * 0.75
pi_1_75 = pi * 1.75
pi_2 = pi * 2