soegtk (empty) → 0.9.12.2
raw patch · 3 files changed
+607/−0 lines, 3 filesdep +basedep +cairodep +gtkbuild-type:Customsetup-changed
Dependencies added: base, cairo, gtk
Files
- Graphics/SOE/Gtk.hs +595/−0
- Setup.hs +2/−0
- soegtk.cabal +10/−0
+ Graphics/SOE/Gtk.hs view
@@ -0,0 +1,595 @@+-- -*-haskell-*-+-- SOE implementation based on Gtk and cairo.+-- 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,+ 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.Chan++import qualified System.Time+import qualified Graphics.UI.Gtk as Gtk++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 :: Chan Event+}++openWindow :: Title -> Size -> IO Window+openWindow title size =+ openWindowEx title Nothing (Just size) drawBufferedGraphic++openWindowEx :: Title -> Maybe Point -> Maybe Size -> RedrawMode -> IO Window+openWindowEx title position size (RedrawMode useDoubleBuffer) =+ Gtk.postGUISync $ do+ window <- Gtk.windowNew+ Gtk.windowSetTitle window title++ canvas <- Gtk.drawingAreaNew+ Gtk.containerAdd window canvas+ Gtk.widgetSetCanFocus canvas 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 <- newChan+ timerVar <- newMVar []++ -- 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++ Gtk.onExpose canvas $ \Gtk.Expose { Gtk.eventArea = eventArea,+ Gtk.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 writeChan eventsChan Closed+ Gtk.widgetHide window+ return True+ + Gtk.onMotionNotify canvas True $ \Gtk.Motion { Gtk.eventX=x, Gtk.eventY=y} ->+ writeChan eventsChan MouseMove {+ pt = (round x, round y)+ } >> return True+ + let mouseButtonHandler event@Gtk.Button { Gtk.eventX=x, Gtk.eventY=y } = do+ writeChan eventsChan Button {+ pt = (round x,round y),+ isLeft = Gtk.eventButton event == Gtk.LeftButton,+ isDown = case Gtk.eventClick event of+ Gtk.ReleaseClick -> False+ _ -> True+ }+ return True+ Gtk.onButtonPress canvas mouseButtonHandler+ Gtk.onButtonRelease canvas mouseButtonHandler++ let keyPressHandler Gtk.Key { Gtk.eventKeyChar = Nothing } = return True+ keyPressHandler Gtk.Key { Gtk.eventKeyChar = Just char, Gtk.eventRelease = release } =+ writeChan eventsChan Key {+ char = char,+ isDown = not release+ } >> return True+ Gtk.onKeyPress canvas keyPressHandler+ Gtk.onKeyRelease canvas keyPressHandler++ Gtk.onSizeAllocate canvas $ \_ -> writeChan eventsChan Resize++ return Window {+ window = window,+ canvas = canvas,+ graphicVar = graphicVar,+ eventsChan = eventsChan+ }++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 new 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 = readChan (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 <- isEmptyChan (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 on+ -- 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 <- readChan (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++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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ soegtk.cabal view
@@ -0,0 +1,10 @@+name: soegtk+version: 0.9.12.2+license: LGPL+author: Duncan Coutts <duncan@haskell.org>+maintainer: gtk2hs-devel@lists.sourceforge.net+stability: provisional+homepage: http://haskell.org/gtk2hs/+category: Graphics+build-depends: base, gtk >=0.9.12, cairo >=0.9.12+exposed-modules: Graphics.SOE.Gtk