soegtk-0.12.1: Graphics/SOE/Gtk.hs
-- -*-haskell-*-
-- SOE implementation based on Gtk and cairo (or Gdk).
-- Some code borrowed from SOE implementation based on OpenGL and GLFW by
-- Paul Liu, http://www.haskell.org/soe/
--
-- Author : Duncan Coutts
--
-- Created: 10 October 2005
--
-- Copyright (C) 2005-2007 Duncan Coutts
-- Copyright (C) 2007 Paul Liu
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library 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
-- Lesser General Public License for more details.
--
-- |
-- Maintainer : gtk2hs-devel@lists.sourceforge.net
-- Stability : stable
-- Portability : portable (depends on GHC)
--
-- An alternative implementation of the graphics library used in The Haskell
-- School of Expression, by Paul Hudak, <http://www.haskell.org/soe/>.
--
-- It has exaclty the same interface as the original implementation
-- "Graphics.SOE". See the original for an API reference.
--
module Graphics.SOE.Gtk (
runGraphics,
Title,
Size,
Window,
openWindow,
getWindowSize,
clearWindow,
drawInWindow,
drawInWindowNow,
setGraphic,
closeWindow,
openWindowEx,
RedrawMode,
drawGraphic,
drawBufferedGraphic,
Graphic,
emptyGraphic,
overGraphic ,
overGraphics,
Color (..),
withColor,
text,
Point,
ellipse,
shearEllipse,
line,
polygon,
polyline,
polyBezier,
Angle,
arc,
Region,
createRectangle,
createEllipse,
createPolygon,
andRegion,
orRegion,
xorRegion,
diffRegion,
drawRegion,
getKey,
getLBP,
getRBP,
Event (..),
maybeGetWindowEvent,
getWindowEvent,
getWindowTick,
Word32,
timeGetTime,
word32ToInt
) where
import Data.List (foldl')
import Data.Ix (Ix)
import Data.Word (Word32)
import Data.IORef (newIORef, readIORef, writeIORef)
import Control.Concurrent (forkIO, yield, rtsSupportsBoundThreads)
import Control.Concurrent.MVar
import Control.Concurrent.STM
import Control.Concurrent.STM.TChan
import qualified System.Time
import qualified Graphics.UI.Gtk as Gtk
import qualified Graphics.UI.Gtk.Gdk.Events as Events
import qualified Graphics.UI.Gtk.Gdk.GC as GC
import qualified Graphics.UI.Gtk.Cairo as Gtk.Cairo
import qualified Graphics.Rendering.Cairo as Cairo
import qualified Graphics.Rendering.Cairo.Matrix as Matrix
-------------------
-- Window Functions
-------------------
runGraphics :: IO () -> IO ()
runGraphics main
| rtsSupportsBoundThreads = do
Gtk.unsafeInitGUIForThreadedRTS
forkIO (main >> Gtk.postGUIAsync Gtk.mainQuit)
Gtk.mainGUI
| otherwise = do
Gtk.initGUI
quitVar <- newIORef False
forkIO (main >> writeIORef quitVar True)
let loop = do
yield
Gtk.mainIteration
quit <- readIORef quitVar
if quit then return ()
else loop
loop
-- give any windows a chance to close
Gtk.flush
type Title = String
type Size = (Int, Int)
data Window = Window {
window :: Gtk.Window,
canvas :: Gtk.DrawingArea,
graphicVar :: MVar Graphic,
eventsChan :: TChan Event,
tickVar :: MVar Tick
}
openWindow :: Title -> Size -> IO Window
openWindow title size =
openWindowEx title Nothing (Just size) drawBufferedGraphic Nothing
openWindowEx :: Title -> Maybe Point -> Maybe Size -> RedrawMode ->
Maybe Time -> IO Window
openWindowEx title position size (RedrawMode useDoubleBuffer) tick =
Gtk.postGUISync $ do
window <- Gtk.windowNew
Gtk.windowSetTitle window title
canvas <- Gtk.drawingAreaNew
Gtk.containerAdd window canvas
Gtk.set canvas [Gtk.widgetCanFocus Gtk.:= True]
Gtk.widgetSetRedrawOnAllocate canvas False
Gtk.widgetSetDoubleBuffered canvas useDoubleBuffer
case position of
Nothing -> return ()
Just (x, y) -> Gtk.windowMove window x y
case size of
Nothing -> return ()
Just (width, height) -> Gtk.windowSetDefaultSize window width height
Gtk.widgetShowAll window
graphicVar <- newMVar emptyGraphic
eventsChan <- atomically $ newTChan
tickVar <- newEmptyMVar
-- set up the fonts
pc <- Gtk.Cairo.cairoCreateContext Nothing
fd <- Gtk.contextGetFontDescription pc
Gtk.fontDescriptionSetSize fd 12
Gtk.fontDescriptionSetFamily fd "Sans"
Gtk.contextSetFontDescription pc fd
win <- Gtk.widgetGetDrawWindow canvas
Gtk.onExpose canvas $ \Events.Expose { Events.eventArea = eventArea,
Events.eventRegion = exposeRegion } -> do
Graphic graphic <- readMVar graphicVar
win <- Gtk.widgetGetDrawWindow canvas
Gtk.Cairo.renderWithDrawable win $ do
-- clip to the exposed region
Gtk.Cairo.region exposeRegion
Cairo.clip
Cairo.paint --fill backgound with black
Cairo.setSourceRGB 1 1 1 --use white default colour
Cairo.setLineWidth 1.5
-- actually do the drawing
graphic pc
return True
Gtk.onDelete window $ \_ -> do atomically $ writeTChan eventsChan Closed
Gtk.widgetHide window
return True
case tick of
Just frequency -> do
let resetTick = do
_ <- tryTakeMVar tickVar
putMVar tickVar ()
Gtk.timeoutAddFull (resetTick >> return True)
Gtk.priorityDefaultIdle frequency
return ()
Nothing -> return ()
Gtk.onMotionNotify canvas True $ \Events.Motion { Events.eventX=x, Events.eventY=y} ->
atomically $ writeTChan eventsChan MouseMove {
pt = (round x, round y)
} >> return True
let mouseButtonHandler event@Events.Button { Events.eventX=x, Events.eventY=y } = do
atomically $ writeTChan eventsChan Button {
pt = (round x,round y),
isLeft = Events.eventButton event == Gtk.LeftButton,
isDown = case Events.eventClick event of
Gtk.ReleaseClick -> False
_ -> True
}
return True
Gtk.onButtonPress canvas mouseButtonHandler
Gtk.onButtonRelease canvas mouseButtonHandler
let keyPressHandler Events.Key { Events.eventKeyChar = Nothing } = return True
keyPressHandler Events.Key { Events.eventKeyChar = Just char, Events.eventRelease = release } =
atomically $ writeTChan eventsChan Key {
char = char,
isDown = not release
} >> return True
Gtk.onKeyPress canvas keyPressHandler
Gtk.onKeyRelease canvas keyPressHandler
Gtk.onSizeAllocate canvas $ \_ -> atomically $ writeTChan eventsChan Resize
return Window {
window = window,
canvas = canvas,
graphicVar = graphicVar,
eventsChan = eventsChan,
tickVar = tickVar
}
getWindowSize :: Window -> IO Size
getWindowSize win = Gtk.postGUISync $ Gtk.widgetGetSize (canvas win)
clearWindow :: Window -> IO ()
clearWindow win = setGraphic win emptyGraphic
drawInWindow :: Window -> Graphic -> IO ()
drawInWindow win graphic = do
modifyMVar_ (graphicVar win) (return . overGraphic graphic)
Gtk.postGUIAsync $ Gtk.widgetQueueDraw (canvas win)
drawInWindowNow :: Window -> Graphic -> IO ()
drawInWindowNow = drawInWindow
setGraphic :: Window -> Graphic -> IO ()
setGraphic win graphic = do
modifyMVar_ (graphicVar win) (\_ -> return graphic)
Gtk.postGUIAsync $ Gtk.widgetQueueDraw (canvas win)
closeWindow :: Window -> IO ()
closeWindow win = Gtk.postGUIAsync $ Gtk.widgetHide (window win)
--------------------
-- Drawing Functions
--------------------
newtype RedrawMode = RedrawMode Bool
drawGraphic :: RedrawMode
drawGraphic = RedrawMode False
drawBufferedGraphic :: RedrawMode
drawBufferedGraphic = RedrawMode True
data Color = Black
| Blue
| Green
| Cyan
| Red
| Magenta
| Yellow
| White
deriving (Eq, Ord, Bounded, Enum, Ix, Show, Read)
type Angle = Float
--------------------------------------------------
-- implementation using the cairo API
--
newtype Graphic = Graphic (Gtk.PangoContext -> Cairo.Render ())
emptyGraphic :: Graphic
emptyGraphic = Graphic (\_ -> return ())
overGraphic :: Graphic -> Graphic -> Graphic
overGraphic (Graphic over) (Graphic base) = Graphic (\pc -> base pc >> over pc)
overGraphics :: [Graphic] -> Graphic
overGraphics = foldl1 overGraphic
colorToRGB :: Color -> (Double, Double, Double)
colorToRGB Black = (0, 0, 0)
colorToRGB Blue = (0, 0, 1)
colorToRGB Green = (0, 1, 0)
colorToRGB Cyan = (0, 1, 1)
colorToRGB Red = (1, 0, 0)
colorToRGB Magenta = (1, 0, 1)
colorToRGB Yellow = (1, 1, 0)
colorToRGB White = (1, 1, 1)
withColor :: Color -> Graphic -> Graphic
withColor color (Graphic graphic) = Graphic $ \pc -> do
Cairo.save
case colorToRGB color of
(r,g,b) -> Cairo.setSourceRGB r g b
-- for some reason the SOE withColor uses a line width of 2,
-- though the default line width outside of withColor is 1.
Cairo.setLineWidth 2
graphic pc
Cairo.restore
text :: Point -> String -> Graphic
text (x,y) str = Graphic $ \pc -> do
layout <- Cairo.liftIO $ Gtk.layoutEmpty pc
Gtk.Cairo.updateLayout layout
Cairo.liftIO $ Gtk.layoutSetText layout str
Cairo.moveTo (fromIntegral x) (fromIntegral y)
Gtk.Cairo.showLayout layout
type Point = (Int, Int)
ellipse :: Point -> Point -> Graphic
ellipse pt1 pt2 = Graphic $ \pc -> case normaliseBounds pt1 pt2 of
Nothing -> return ()
Just (x,y,width,height) -> do
Cairo.save
Cairo.translate (x + width / 2) (y + height / 2)
Cairo.scale (width / 2) (height / 2)
Cairo.arc 0 0 1 0 (2*pi)
Cairo.fill
Cairo.restore
shearEllipse :: Point -> Point -> Point -> Graphic
shearEllipse (x1,y1) (x2,y2) (x3,y3) = Graphic $ \pc -> do
let x = fromIntegral x1
y = fromIntegral y1
scalex = fromIntegral $ abs $ x1 - x3
scaley = fromIntegral $ abs $ y1 - y2
shearx = fromIntegral $ abs $ x1 - x2
sheary = fromIntegral $ abs $ y1 - y3
Cairo.save
Cairo.transform (Matrix.Matrix scalex sheary shearx scaley x y)
Cairo.arc 0.5 0.5 0.5 0 (2 * pi)
Cairo.fill
Cairo.restore
line :: Point -> Point -> Graphic
line (x1, y1) (x2, y2) = Graphic $ \pc -> do
Cairo.moveTo (fromIntegral x1) (fromIntegral y1)
Cairo.lineTo (fromIntegral x2) (fromIntegral y2)
Cairo.stroke
polygon :: [Point] -> Graphic
polygon [] = Graphic (\_ -> return ())
polygon ((x,y):ps) = Graphic $ \pc -> do
Cairo.moveTo (fromIntegral x) (fromIntegral y)
sequence_ [ Cairo.lineTo (fromIntegral x) (fromIntegral y)
| (x,y) <- ps ]
Cairo.fill
polyline :: [Point] -> Graphic
polyline [] = Graphic (\_ -> return ())
polyline ((x,y):ps) = Graphic $ \pc -> do
Cairo.moveTo (fromIntegral x) (fromIntegral y)
sequence_ [ Cairo.lineTo (fromIntegral x) (fromIntegral y)
| (x,y) <- ps ]
Cairo.stroke
polyBezier :: [Point] -> Graphic
polyBezier [] = Graphic (\_ -> return ())
polyBezier ((x,y):ps) = Graphic $ \pc -> do
Cairo.moveTo (fromIntegral x) (fromIntegral y)
let loop ((x1,y1):(x2,y2):(x3,y3):ps) = do
Cairo.curveTo (fromIntegral x1) (fromIntegral y1)
(fromIntegral x2) (fromIntegral y2)
(fromIntegral x3) (fromIntegral y3)
loop ps
loop _ = return ()
loop ps
Cairo.stroke
arc :: Point -> Point -> Angle -> Angle -> Graphic
arc pt1 pt2 start_ extent_ = Graphic $ \pc -> case normaliseBounds pt1 pt2 of
Nothing -> return ()
Just (x,y,width,height) -> do
Cairo.save
Cairo.translate (x + width / 2) (y + height / 2)
Cairo.scale (width / 2) (height / 2)
Cairo.moveTo 0 0
Cairo.arcNegative 0 0 1 (-start * pi / 180) (-(start+extent) * pi / 180)
Cairo.fill
Cairo.restore
where start = realToFrac start_
extent = realToFrac extent_
-------------------
-- Region Functions
-------------------
data Region = Region {
regionGraphic :: Int -> Int -> Cairo.Render (),
regionOriginX :: !Int,
regionOriginY :: !Int,
regionWidth :: !Int,
regionHeight :: !Int
}
createRectangle :: Point -> Point -> Region
createRectangle pt1 pt2 =
let (x,y,width,height) = normaliseBounds' pt1 pt2
drawing x y = do
Cairo.rectangle (fromIntegral x) (fromIntegral y)
(fromIntegral width) (fromIntegral height)
Cairo.fill
in Region drawing x y width height
createEllipse :: Point -> Point -> Region
createEllipse pt1 pt2 =
let (x0,y0,width,height) = normaliseBounds' pt1 pt2
drawing x y | width==0 || height==0 = return ()
| otherwise = do
Cairo.save
Cairo.translate (fromIntegral x + fromIntegral width / 2)
(fromIntegral y + fromIntegral height / 2)
Cairo.scale (fromIntegral width / 2) (fromIntegral height / 2)
Cairo.arc 0 0 1 0 (2*pi)
Cairo.fill
Cairo.restore
in Region drawing x0 y0 width height
createPolygon :: [Point] -> Region
createPolygon [] = Region (\_ _ -> return ()) 0 0 0 0
createPolygon (p@(x0,y0):ps) =
let minMax (minx,maxx,miny,maxy) (x,y) =
let minx' = min minx x
maxx' = max maxx x
miny' = min miny y
maxy' = max maxy y
in seq minx' $ seq maxx' $ seq miny' $ seq maxy' $
(minx',maxx',miny',maxy')
(minx,maxx,miny,maxy) = foldl' minMax (x0,x0,y0,y0) (p:ps)
drawing x y = do
Cairo.save
Cairo.translate (fromIntegral (x-minx)) (fromIntegral (y-miny))
Cairo.moveTo (fromIntegral x0) (fromIntegral y0)
sequence_ [ Cairo.lineTo (fromIntegral x) (fromIntegral y)
| (x,y) <- ps ]
Cairo.fill
Cairo.restore
in Region drawing minx miny (maxx - minx) (maxy - miny)
andRegion, orRegion, xorRegion, diffRegion :: Region -> Region -> Region
andRegion = combineRegion Cairo.OperatorIn
orRegion = combineRegion Cairo.OperatorOver
xorRegion = combineRegion Cairo.OperatorXor
diffRegion = combineRegion Cairo.OperatorDestOut
drawRegion :: Region -> Graphic
drawRegion Region { regionGraphic = graphic,
regionOriginX = x,
regionOriginY = y
} = Graphic $ \_ -> do
graphic x y
combineRegion :: Cairo.Operator -> Region -> Region -> Region
combineRegion operator a b =
let x = min (regionOriginX a) (regionOriginX b)
y = min (regionOriginY a) (regionOriginY b)
x' = max (regionOriginX a + regionWidth a) (regionOriginX b + regionWidth b)
y' = max (regionOriginY a + regionHeight a) (regionOriginY b + regionHeight b)
width = x' - x
height = y' - y
drawing x'' y'' = do
Cairo.renderWithSimilarSurface Cairo.ContentAlpha width height $
\surface -> do
Cairo.renderWith surface $ do
Cairo.setSourceRGBA 0 0 0 1
regionGraphic a (regionOriginX a - x)
(regionOriginY a - y)
Cairo.setOperator operator
regionGraphic b (regionOriginX b - x)
(regionOriginY b - y)
Cairo.maskSurface surface (fromIntegral x'') (fromIntegral y'')
in Region drawing x y width height
normaliseBounds :: Point -> Point -> Maybe (Double,Double,Double,Double)
normaliseBounds (x1,y1) (x2,y2) =
if x1==x2 || y1==y2 then Nothing else Just (x, y, width, height)
where x = fromIntegral $ min x1 x2
y = fromIntegral $ min y1 y2
width = fromIntegral $ abs $ x1 - x2
height = fromIntegral $ abs $ y1 - y2
normaliseBounds' :: Point -> Point -> (Int,Int,Int,Int)
normaliseBounds' (x1,y1) (x2,y2) = (x, y, width, height)
where x = min x1 x2
y = min y1 y2
width = abs $ x1 - x2
height = abs $ y1 - y2
---------------------------
-- Event Handling Functions
---------------------------
data Event = Key {
char :: Char,
isDown :: Bool
}
| Button {
pt :: Point,
isLeft :: Bool,
isDown :: Bool
}
| MouseMove {
pt :: Point
}
| Resize
| Closed
deriving Show
getWindowEvent_ :: Window -> IO Event
getWindowEvent_ win = atomically $ readTChan (eventsChan win)
getWindowEvent :: Window -> IO Event
getWindowEvent win = do
event <- getWindowEvent_ win
-- this says we are ready for another mouse move event
-- (this is part of the pointer move event flood prevention system)
case event of
MouseMove _ -> Gtk.postGUIAsync $
Gtk.widgetGetDrawWindow (canvas win)
>>= Gtk.drawWindowGetPointer
>> return ()
_ -> return ()
return event
maybeGetWindowEvent :: Window -> IO (Maybe Event)
maybeGetWindowEvent win = do
noEvents <- atomically $ isEmptyTChan (eventsChan win)
if noEvents then -- Sync with the main GUI loop or we can end up spinning on
-- maybeGetWindowEvent and prevent the screen redrawing.
-- We also introduce a very short delay here of 5ms. This
-- prevents the program from using 100% cpu and redrawing
-- constantly. This actually makes animation much smoother
-- since the process gets treated as interactive rather than
-- as a CPU hog so the scheduler gives us the benefit of
-- latency. Even with a 5ms delay here we can animate at up
-- to 200fps.
do syncVar <- newEmptyMVar
Gtk.timeoutAddFull (putMVar syncVar () >> return False)
Gtk.priorityDefaultIdle 10
takeMVar syncVar
return Nothing
else do event <- atomically $ readTChan (eventsChan win)
case event of
MouseMove _ -> Gtk.postGUIAsync $
Gtk.widgetGetDrawWindow (canvas win)
>>= Gtk.drawWindowGetPointer
>> return ()
_ -> return ()
return (Just event)
getKeyEx :: Window -> Bool -> IO Char
getKeyEx win down = loop
where loop = do e <- getWindowEvent_ win
case e of
(Key { char = ch, isDown = d })
| d == down -> return ch
Closed -> return '\x0'
_ -> loop
getKey :: Window -> IO Char
getKey win = do
ch <- getKeyEx win True
if ch == '\x0' then return ch
else getKeyEx win False
getButton :: Window -> Int -> Bool -> IO Point
getButton win but down = loop
where loop = do e <- getWindowEvent_ win
case e of
(Button { pt = pt, isDown = id })
| id == down -> return pt
_ -> loop
getLBP :: Window -> IO Point
getLBP w = getButton w 1 True
getRBP :: Window -> IO Point
getRBP w = getButton w 2 True
---------------------------------
-- Window Tick Handling Functions
---------------------------------
type Time = Int
type Tick = ()
getWindowTick :: Window -> IO ()
getWindowTick w = takeMVar (tickVar w)
timeGetTime :: IO Word32
timeGetTime = do
System.Time.TOD sec psec <- System.Time.getClockTime
return (fromIntegral $ sec * 1000 + psec `div` 1000000000)
word32ToInt :: Word32 -> Int
word32ToInt = fromIntegral