soegtk 0.11.1 → 0.12.1
raw patch · 8 files changed
+702/−1167 lines, 8 filesdep +stmdep −arraydep −containersdep −glibdep ~cairodep ~gtksetup-changed
Dependencies added: stm
Dependencies removed: array, containers, glib, haskell98, mtl
Dependency ranges changed: cairo, gtk
Files
- Graphics/SOE/Gtk.chs +0/−776
- Graphics/SOE/Gtk.hs +625/−0
- Setup.hs +1/−333
- demo/BouncingBall.hs +39/−22
- demo/Demo1.hs +4/−4
- demo/Demo2.hs +10/−10
- demo/Snowflake.hs +8/−4
- soegtk.cabal +15/−18
− Graphics/SOE/Gtk.chs
@@ -1,776 +0,0 @@-{-# LANGUAGE CPP #-}--- -*-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,- Word32,- timeGetTime,- word32ToInt- ) where---- Cairo is always enabled since we're depending on gtk-0.11.0-#define USE_CAIRO--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.Gdk.Events as Events-import qualified Graphics.UI.Gtk.Gdk.GC as GC--#ifdef USE_CAIRO-import qualified Graphics.UI.Gtk.Cairo as Gtk.Cairo-import qualified Graphics.Rendering.Cairo as Cairo-import qualified Graphics.Rendering.Cairo.Matrix as Matrix-#else-import qualified System.IO-#endif------------------------ 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.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 <- newChan-- -- set up the fonts-#ifdef USE_CAIRO- pc <- Gtk.Cairo.cairoCreateContext Nothing-#else- pc <- Gtk.widgetCreatePangoContext canvas-#endif- fd <- Gtk.contextGetFontDescription pc- Gtk.fontDescriptionSetSize fd 12- Gtk.fontDescriptionSetFamily fd "Sans"- Gtk.contextSetFontDescription pc fd--#ifndef USE_CAIRO- win <- Gtk.widgetGetDrawWindow canvas- -- set up the graphics context- gc <- GC.gcNew win-#endif- Gtk.onExpose canvas $ \Events.Expose { Events.eventArea = eventArea,- Events.eventRegion = exposeRegion } -> do- Graphic graphic <- readMVar graphicVar- win <- Gtk.widgetGetDrawWindow canvas-#ifdef USE_CAIRO- 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-#else- --fill backgound with black- GC.gcSetValues gc GC.newGCValues { GC.foreground = colorToRGB Black }- case eventArea of- Gtk.Rectangle x y width height ->- Gtk.drawRectangle win gc True x y width height- --use white default colour- GC.gcSetValues gc GC.newGCValues { GC.foreground = colorToRGB White }-- -- actually do the drawing- graphic (Gtk.toDrawable win) gc pc-#endif- return True-- Gtk.onDelete window $ \_ -> do writeChan eventsChan Closed- Gtk.widgetHide window- return True- - Gtk.onMotionNotify canvas True $ \Events.Motion { Events.eventX=x, Events.eventY=y} ->- writeChan eventsChan MouseMove {- pt = (round x, round y)- } >> return True- - let mouseButtonHandler event@Events.Button { Events.eventX=x, Events.eventY=y } = do- writeChan 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 } =- 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--#ifdef USE_CAIRO------------------------------------------------------- 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--#else------------------------------------------------------- implementation using the old Gdk API-----newtype Graphic = Graphic (Gtk.Drawable -> GC.GC -> Gtk.PangoContext -> IO ())--emptyGraphic :: Graphic-emptyGraphic = Graphic (\_ _ _ -> return ())--overGraphic :: Graphic -> Graphic -> Graphic-overGraphic (Graphic over) (Graphic base) =- Graphic (\dw gc pc -> base dw gc pc >> over dw gc pc)--overGraphics :: [Graphic] -> Graphic-overGraphics = foldl1 overGraphic--colorToRGB :: Color -> Gtk.Color-colorToRGB Black = Gtk.Color 0 0 0-colorToRGB Blue = Gtk.Color 0 0 65535-colorToRGB Green = Gtk.Color 0 65535 0-colorToRGB Cyan = Gtk.Color 0 65535 65535-colorToRGB Red = Gtk.Color 65535 0 0-colorToRGB Magenta = Gtk.Color 65535 0 65535-colorToRGB Yellow = Gtk.Color 65535 65535 0-colorToRGB White = Gtk.Color 65535 65535 65535--withColor :: Color -> Graphic -> Graphic-withColor color (Graphic graphic) = Graphic $ \dw gc pc -> do- v <- GC.gcGetValues gc- GC.gcSetValues gc GC.newGCValues {- GC.foreground = colorToRGB color,- GC.lineWidth = 2- }- graphic dw gc pc- GC.gcSetValues gc GC.newGCValues {- GC.foreground = GC.foreground v,- GC.lineWidth = GC.lineWidth v- }--text :: Point -> String -> Graphic-text (x,y) str = Graphic $ \dw gc pc -> do- pl <- Gtk.layoutEmpty pc- Gtk.layoutSetText pl str- Gtk.drawLayout dw gc x y pl--type Point = (Int, Int)--ellipse :: Point -> Point -> Graphic-ellipse pt1 pt2 = Graphic $ \dw gc pc -> do- let (x,y,width,height) = normaliseBounds' pt1 pt2- Gtk.drawArc dw gc True x y width height 0 (360*64)--shearEllipse :: Point -> Point -> Point -> Graphic-shearEllipse (x1,y1) (x2,y2) (x3,y3) = Graphic $ \dw gc pc -> do- let avg a b = (a + b) `div` 2- x = avg x2 x3- y = avg y2 y3- dx1 = fromIntegral ((x2 - x1) `div` 2)- dy1 = fromIntegral ((y2 - y1) `div` 2)- dx2 = fromIntegral ((x3 - x1) `div` 2)- dy2 = fromIntegral ((y3 - y1) `div` 2)- ps = [ (x + round(cos a * dx1 + sin a * dx2)- ,y + round(cos a * dy1 + sin a * dy2))- | a <- take 60 [0, pi/30 .. ] ]- Gtk.drawPolygon dw gc True ps--line :: Point -> Point -> Graphic-line p1 p2 = Graphic $ \dw gc pc -> Gtk.drawLine dw gc p1 p2--polygon :: [Point] -> Graphic-polygon ps = Graphic $ \dw gc pc -> Gtk.drawPolygon dw gc True ps--polyline :: [Point] -> Graphic-polyline ps = Graphic $ \dw gc pc -> Gtk.drawLines dw gc ps--polyBezier :: [Point] -> Graphic-polyBezier ps = Graphic $ \dw gc pc -> do- System.IO.hPutStrLn System.IO.stderr $ "warning: polyBezier is only available "- ++ "in Grahpics.SOE.Gtk built with Gtk+ 2.8 or later -- using polyline instead"- Gtk.drawLines dw gc ps--arc :: Point -> Point -> Angle -> Angle -> Graphic-arc pt1 pt2 start extent = Graphic $ \dw gc pc -> do- let (x,y,width,height) = normaliseBounds' pt1 pt2- Gtk.drawArc dw gc True x y width height- (round $ start * 64)- (round $ (start+extent) * 64)--newtype Region = Region (IO Gtk.Region)--createRectangle :: Point -> Point -> Region-createRectangle pt1 pt2 =- let (x,y,width,height) = normaliseBounds' pt1 pt2 - region = Gtk.regionRectangle (Gtk.Rectangle x y width height)- in Region region--createEllipse :: Point -> Point -> Region-createEllipse (x1, y1) (x2, y2) =- let rx = (x2 - x1) `div` 2- ry = (y2 - y1) `div` 2- cx = x1 + rx- cy = y1 + ry- rx' = fromIntegral rx- ry' = fromIntegral ry- ps = [ (cx + round (rx' * cos a), cy + round (ry' * sin a))- | a <- take 60 [0, pi/30 .. ] ]- region = Gtk.regionPolygon ps Gtk.WindingRule- in Region region--createPolygon :: [Point] -> Region-createPolygon ps =- let region = Gtk.regionPolygon ps Gtk.WindingRule- in Region region--andRegion, orRegion, xorRegion, diffRegion :: Region -> Region -> Region-andRegion (Region a) (Region b) = Region $ do- regionA <- a- regionB <- b- Gtk.regionIntersect regionA regionB- return regionA-orRegion (Region a) (Region b) = Region $ do- regionA <- a- regionB <- b- Gtk.regionUnion regionA regionB- return regionA-xorRegion (Region a) (Region b) = Region $ do- regionA <- a- regionB <- b- Gtk.regionXor regionA regionB- return regionA-diffRegion (Region a) (Region b) = Region $ do- regionA <- a- regionB <- b- Gtk.regionSubtract regionA regionB- return regionA--drawRegion :: Region -> Graphic-drawRegion (Region mkRegion) = Graphic $ \dw gc pc -> do- region <- mkRegion- rects <- Gtk.regionGetRectangles region- mapM_ (\(Gtk.Rectangle x y width height) ->- Gtk.drawRectangle dw gc True x y width height)- rects--#endif--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
+ Graphics/SOE/Gtk.hs view
@@ -0,0 +1,625 @@+-- -*-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
Setup.hs view
@@ -1,334 +1,2 @@-{-# LANGUAGE CPP #-}--#define CABAL_VERSION_ENCODE(major, minor, micro) ( \- ((major) * 10000) \- + ((minor) * 100) \- + ((micro) * 1))--#define CABAL_VERSION_CHECK(major,minor,micro) \- (CABAL_VERSION >= CABAL_VERSION_ENCODE(major,minor,micro))---- now, this is bad, but Cabal doesn't seem to actually pass any information about--- its version to CPP, so guess the version depending on the version of GHC-#ifdef CABAL_VERSION_MINOR-#ifndef CABAL_VERSION_MAJOR-#define CABAL_VERSION_MAJOR 1-#endif-#ifndef CABAL_VERSION_MICRO-#define CABAL_VERSION_MICRO 0-#endif-#define CABAL_VERSION CABAL_VERSION_ENCODE( \- CABAL_VERSION_MAJOR, \- CABAL_VERSION_MINOR, \- CABAL_VERSION_MICRO)-#else-#warning Setup.hs is guessing the version of Cabal. If compilation of Setup.hs fails use -DCABAL_VERSION_MINOR=x for Cabal version 1.x.0 when building (prefixed by --ghc-option= when using the 'cabal' command)-#if (__GLASGOW_HASKELL__ >= 612)-#define CABAL_VERSION CABAL_VERSION_ENCODE(1,8,0)-#else-#define CABAL_VERSION CABAL_VERSION_ENCODE(1,6,0)-#endif-#endif---- | Build a Gtk2hs package.--- import Distribution.Simple-import Distribution.Simple.PreProcess-import Distribution.InstalledPackageInfo ( importDirs )-import Distribution.Simple.PackageIndex (-#if CABAL_VERSION_CHECK(1,8,0)- lookupInstalledPackageId-#else- lookupPackageId-#endif- )-import Distribution.PackageDescription as PD ( PackageDescription(..),- updatePackageDescription,- BuildInfo(..),- emptyBuildInfo, allBuildInfo,- Library(..),- libModules)-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..),- InstallDirs(..),-#if CABAL_VERSION_CHECK(1,8,0)- componentPackageDeps,-#else- packageDeps,-#endif- absoluteInstallDirs)-import Distribution.Simple.Compiler ( Compiler(..) )-import Distribution.Simple.Program (- Program(..), ConfiguredProgram(..),- rawSystemProgramConf, rawSystemProgramStdoutConf,- c2hsProgram, pkgConfigProgram,- simpleProgram, lookupProgram, rawSystemProgramStdout, ProgArg)-import Distribution.ModuleName ( ModuleName, components, toFilePath )-import Distribution.Simple.Utils-import Distribution.Simple.Setup (CopyFlags(..), InstallFlags(..), CopyDest(..),- defaultCopyFlags, ConfigFlags(configVerbosity),- fromFlag, toFlag)-import Distribution.Simple.BuildPaths ( autogenModulesDir )-import Distribution.Text ( simpleParse, display )-import System.FilePath-import System.Directory ( doesFileExist )-import Distribution.Version (Version(..))-import Distribution.Verbosity-import Control.Monad (unless)-import Data.Maybe (fromMaybe)-import Data.List (isPrefixOf, nub)-import Data.Char (isAlpha)-import qualified Data.Map as M-import qualified Data.Set as S----- the name of the c2hs pre-compiled header file-precompFile = "precompchs.bin"--main = defaultMainWithHooks simpleUserHooks {- hookedPrograms = [typeGenProgram, signalGenProgram, c2hsLocal],- hookedPreProcessors = [("chs", ourC2hs)],- confHook = \pd cf ->- confHook simpleUserHooks pd cf >>= return . adjustLocalBuildInfo,- postConf = \args cf pd lbi -> do- genSynthezisedFiles (fromFlag (configVerbosity cf)) pd lbi- postConf simpleUserHooks args cf pd lbi,- buildHook = \pd lbi uh bf -> fixDeps pd >>= \pd ->- (buildHook simpleUserHooks) pd lbi uh bf,- copyHook = \pd lbi uh flags -> (copyHook simpleUserHooks) pd lbi uh flags >>- installCHI pd lbi (fromFlag (copyVerbosity flags)) (fromFlag (copyDest flags)),- instHook = \pd lbi uh flags -> (instHook simpleUserHooks) pd lbi uh flags >>- installCHI pd lbi (fromFlag (installVerbosity flags)) NoCopyDest- }---- This is a hack for Cabal-1.8, It is not needed in Cabal-1.9.1 or later-adjustLocalBuildInfo :: LocalBuildInfo -> LocalBuildInfo-adjustLocalBuildInfo lbi =- let extra = (Just libBi, [])- libBi = emptyBuildInfo { includeDirs = [ autogenModulesDir lbi- , buildDir lbi ] }- in lbi { localPkgDescr = updatePackageDescription extra (localPkgDescr lbi) }--ourC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor-ourC2hs bi lbi = PreProcessor {- platformIndependent = False,- runPreProcessor = runC2HS bi lbi-}--runC2HS :: BuildInfo -> LocalBuildInfo ->- (FilePath, FilePath) -> (FilePath, FilePath) -> Verbosity -> IO ()-runC2HS bi lbi (inDir, inFile) (outDir, outFile) verbosity = do- -- have the header file name if we don't have the precompiled header yet- header <- case lookup "x-c2hs-header" (customFieldsBI bi) of- Just h -> return h- Nothing -> die ("Need x-c2hs-Header definition in the .cabal Library section "++- "that sets the C header file to process .chs.pp files.")-- -- c2hs will output files in out dir, removing any leading path of the input file.- -- Thus, append the dir of the input file to the output dir.- let (outFileDir, newOutFile) = splitFileName outFile- let newOutDir = outDir </> outFileDir- -- additional .chi files might be needed that other packages have installed;- -- we assume that these are installed in the same place as .hi files- let chiDirs = [ dir |-#if CABAL_VERSION_CHECK(1,8,0)- ipi <- maybe [] (map fst . componentPackageDeps) (libraryConfig lbi),- dir <- maybe [] importDirs (lookupInstalledPackageId (installedPkgs lbi) ipi) ]-#else- ipi <- packageDeps lbi,- dir <- maybe [] importDirs (lookupPackageId (installedPkgs lbi) ipi) ]-#endif- rawSystemProgramConf verbosity c2hsLocal (withPrograms lbi) $- map ("--include=" ++) (outDir:chiDirs)- ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi]- ++ ["--output-dir=" ++ newOutDir,- "--output=" ++ newOutFile,- "--precomp=" ++ buildDir lbi </> precompFile,- header, inDir </> inFile]--getCppOptions :: BuildInfo -> LocalBuildInfo -> [String]-getCppOptions bi lbi- = nub $- ["-I" ++ dir | dir <- PD.includeDirs bi]- ++ [opt | opt@('-':c:_) <- (PD.cppOptions bi ++ PD.ccOptions bi), c `elem` "DIU"]--installCHI :: PackageDescription -- ^information from the .cabal file- -> LocalBuildInfo -- ^information from the configure step- -> Verbosity -> CopyDest -- ^flags sent to copy or install- -> IO ()-installCHI pkg@PD.PackageDescription { library = Just lib } lbi verbosity copydest = do- let InstallDirs { libdir = libPref } = absoluteInstallDirs pkg lbi copydest- -- cannot use the recommended 'findModuleFiles' since it fails if there exists- -- a modules that does not have a .chi file- mFiles <- mapM (findFileWithExtension' ["chi"] [buildDir lbi])- (map toFilePath-#if CABAL_VERSION_CHECK(1,8,0)- (PD.libModules lib)-#else- (PD.libModules pkg)-#endif- )- let files = [ f | Just f <- mFiles ]-#if CABAL_VERSION_CHECK(1,8,0)- installOrdinaryFiles verbosity libPref files-#else- copyFiles verbosity libPref files-#endif-- -installCHI _ _ _ _ = return ()----------------------------------------------------------------------------------- Generating the type hierarchy and signal callback .hs files.---------------------------------------------------------------------------------typeGenProgram :: Program-typeGenProgram = (simpleProgram "gtk2hsTypeGen")--signalGenProgram :: Program-signalGenProgram = (simpleProgram "gtk2hsHookGenerator")--c2hsLocal :: Program-c2hsLocal = (simpleProgram "gtk2hsC2hs")--genSynthezisedFiles :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()-genSynthezisedFiles verb pd lbi = do-- cPkgs <- getPkgConfigPackages verb lbi pd-- let xList = maybe [] (customFieldsBI . libBuildInfo) (library pd)- ++customFieldsPD pd- typeOpts :: [ProgArg]- typeOpts = concat [ map (\val -> '-':'-':drop 8 field++'=':val) (words content)- | (field,content) <- xList,- "x-types-" `isPrefixOf` field,- field /= "x-types-file"]- ++ [ "--tag=" ++ tag- | PackageIdentifier name (Version (major:minor:_) _) <- cPkgs- , let name' = filter isAlpha (display name)- , tag <- name'- : [ name' ++ "-" ++ show major ++ "." ++ show digit- | digit <- [0,2..minor] ]- ]-- genFile :: Program -> [ProgArg] -> FilePath -> IO ()- genFile prog args outFile = do- res <- rawSystemProgramStdoutConf verb prog (withPrograms lbi) args- rewriteFile outFile res-- case lookup "x-types-file" xList of- Nothing -> return ()- Just f -> do- info verb ("Ensuring that class hierarchy in "++f++" is up-to-date.")- genFile typeGenProgram typeOpts f-- case (lookup "x-signals-file" xList,- lookup "x-signals-modname" xList) of- (Just _, Nothing) -> die "You need to specify the module name (X-Signals-ModName) \- \to generate a signal file."- (Just f, Just mod) -> do- info verb ("Ensuring that callback hooks in "++f++" are up-to-date.")- genFile signalGenProgram [mod] f- (_,_) -> return ()----FIXME: Cabal should tell us the selected pkg-config package versions in the--- LocalBuildInfo or equivalent.--- In the mean time, ask pkg-config again.--getPkgConfigPackages :: Verbosity -> LocalBuildInfo -> PackageDescription -> IO [PackageId]-getPkgConfigPackages verbosity lbi pkg =- sequence- [ do version <- pkgconfig ["--modversion", display pkgname]- case simpleParse version of- Nothing -> die $ "parsing output of pkg-config --modversion failed"- Just v -> return (PackageIdentifier pkgname v)- | Dependency pkgname _ <- concatMap pkgconfigDepends (allBuildInfo pkg) ]- where- pkgconfig = rawSystemProgramStdoutConf verbosity- pkgConfigProgram (withPrograms lbi)----------------------------------------------------------------------------------- Dependency calculation amongst .chs files.----------------------------------------------------------------------------------- Given all files of the package, find those that end in .chs and extract the--- .chs files they depend upon. Then return the PackageDescription with these--- files rearranged so that they are built in a sequence that files that are--- needed by other files are built first.-fixDeps :: PackageDescription -> IO PackageDescription-fixDeps pd@PD.PackageDescription {- PD.library = Just lib@PD.Library {- PD.exposedModules = expMods,- PD.libBuildInfo = bi@PD.BuildInfo {- PD.hsSourceDirs = srcDirs,- PD.otherModules = othMods- }}} = do- let findModule m = findFileWithExtension [".chs.pp",".chs"] srcDirs- (joinPath (components m))- mExpFiles <- mapM findModule expMods- mOthFiles <- mapM findModule othMods-- -- tag all exposed files with True so we throw an error if we need to build- -- an exposed module before an internal modules (we cannot express this)- let modDeps = zipWith (ModDep True []) expMods mExpFiles++- zipWith (ModDep False []) othMods mOthFiles- modDeps <- mapM extractDeps modDeps- let (expMods, othMods) = span mdExposed $ sortTopological modDeps- badOther = map (fromMaybe "<no file>" . mdLocation) $- filter (not . mdExposed) expMods- unless (null badOther) $- die ("internal chs modules "++intercalate "," badOther++- " depend on exposed chs modules; cabal needs to build internal modules first")- return pd { PD.library = Just lib {- PD.exposedModules = map mdOriginal expMods,- PD.libBuildInfo = bi { PD.otherModules = map mdOriginal othMods }- }}--data ModDep = ModDep {- mdExposed :: Bool,- mdRequires :: [ModuleName],- mdOriginal :: ModuleName,- mdLocation :: Maybe FilePath-}--instance Show ModDep where- show x = show (mdLocation x)--instance Eq ModDep where- ModDep { mdOriginal = m1 } == ModDep { mdOriginal = m2 } = m1==m2-instance Ord ModDep where- compare ModDep { mdOriginal = m1 } ModDep { mdOriginal = m2 } = compare m1 m2---- Extract the dependencies of this file. This is intentionally rather naive as it--- ignores CPP conditionals. We just require everything which means that the--- existance of a .chs module may not depend on some CPP condition. -extractDeps :: ModDep -> IO ModDep-extractDeps md@ModDep { mdLocation = Nothing } = return md-extractDeps md@ModDep { mdLocation = Just f } = withFileContents f $ \con -> do- let findImports acc (('{':'#':xs):xxs) = case (dropWhile ((==) ' ') xs) of- ('i':'m':'p':'o':'r':'t':' ':ys) ->- case simpleParse (takeWhile ((/=) '#') ys) of- Just m -> findImports (m:acc) xxs - Nothing -> die ("cannot parse chs import in "++f++":\n"++- "offending line is {#"++xs)- -- no more imports after the first non-import hook- _ -> return acc- findImports acc (_:xxs) = findImports acc xxs- findImports acc [] = return acc- mods <- findImports [] (lines con)- return md { mdRequires = mods }---- Find a total order of the set of modules that are partially sorted by their--- dependencies on each other. The function returns the sorted list of modules--- together with a list of modules that are required but not supplied by this--- in the input set of modules.-sortTopological :: [ModDep] -> [ModDep]-sortTopological ms = reverse $ fst $ foldl visit ([], S.empty) (map mdOriginal ms)- where- set = M.fromList (map (\m -> (mdOriginal m, m)) ms)- visit (out,visited) m- | m `S.member` visited = (out,visited)- | otherwise = case m `M.lookup` set of- Nothing -> (out, m `S.insert` visited)- Just md -> (md:out', visited')- where- (out',visited') = foldl visit (out, m `S.insert` visited) (mdRequires md)+main = defaultMain
demo/BouncingBall.hs view
@@ -5,26 +5,43 @@ import Graphics.SOE.Gtk -main = runGraphics $- do w <- openWindowEx "Bouncing Ball" Nothing (Just (300, 300)) drawBufferedGraphic- let loop x y xd yd- = do setGraphic w $ withColor Yellow $- ellipse (x-5,y-5) (x+5,y+5)- (xmax, ymax) <- getWindowSize w- let x' = x + xd + 5- y' = y + yd + 5- xd' | x' >= xmax || x' < 0 = -xd- | otherwise = xd- yd' | y' >= ymax || y' < 0 = -yd- | otherwise = yd- x'' = x + xd'- y'' = y + yd'- x''' | x'' + 5 > xmax = xmax `div` 2- | otherwise = x''- y''' | y'' + 5 > ymax = ymax `div` 2- | otherwise = y''- e <- getWindowEvent w- case e of Closed -> return ()- _ -> loop x''' y''' xd' yd'- loop 300 100 5 5+main =+ runGraphics $ do+ w <- openWindowEx "Bouncing Ball" Nothing+ (Just (300, 300)) drawBufferedGraphic+ (Just 20) --20ms timer+ loop w 300 100 5 5 ++loop w x y xd yd = do+ setGraphic w $ withColor Yellow $+ ellipse (x-5,y-5) (x+5,y+5)+ (xmax, ymax) <- getWindowSize w+ let x' = x + xd + 5+ y' = y + yd + 5+ xd' | x' >= xmax || x' < 0 = -xd+ | otherwise = xd+ yd' | y' >= ymax || y' < 0 = -yd+ | otherwise = yd+ x'' = x + xd'+ y'' = y + yd'+ x''' | x'' + 5 > xmax = xmax `div` 2+ | otherwise = x''+ y''' | y'' + 5 > ymax = ymax `div` 2+ | otherwise = y''++ let nextEvent = do+ e <- maybeGetWindowEvent w+ case e of++ -- stop when the user closes the window+ Just Closed -> return ()++ -- ignore mouse and other button events+ Just _ -> nextEvent++ -- if there's no events pending, wait for the timer+ -- then go round again+ Nothing -> do getWindowTick w+ loop w x''' y''' xd' yd'+ nextEvent
demo/Demo1.hs view
@@ -12,12 +12,12 @@ drawInWindow w $ polygon [(60,60), (60,90), (80,90)] drawInWindow w $ withColor Yellow $ ellipse (290, 190) (150, 150)- drawInWindow w $ arc (20,190) (90,130) (45) (390)- drawInWindow w $ withColor Blue $ line (20,190) (90,130)- drawInWindow w $ withColor Yellow $+ drawInWindow w $ arc (20,190) (90,130) (45) (390)+ drawInWindow w $ withColor Blue $ line (20,190) (90,130)+ drawInWindow w $ withColor Yellow $ shearEllipse (140, 10) (160, 90) (190, 50) loopEvents w- closeWindow w+ closeWindow w loopEvents w = loop where loop = do e <- getWindowEvent w
demo/Demo2.hs view
@@ -7,18 +7,18 @@ main = runGraphics $ do w <- openWindow "Testing" (200, 200) drawInWindow w $ text (10,180) "Hello"- drawInWindow w $ withColor Blue $- polyline [(20,20), (20,150), (150,150), (150,20), (20,20)]- let region = createRectangle (20,20) (100,100)+ drawInWindow w $ withColor Blue $+ polyline [(20,20), (20,150), (150,150), (150,20), (20,20)]+ let region = createRectangle (20,20) (100,100) `orRegion` createRectangle (50,50) (150,150)- `diffRegion` createRectangle (100,100) (150,150)- drawInWindow w $ withColor Blue $- polyline [(20,20), (20,100), (100,100), (100,20), (20,20)]- drawInWindow w $ withColor Blue $- polyline [(50,50), (50,150), (150,150), (150,50), (50,50)]- drawInWindow w $ withColor Green $ drawRegion region+ `diffRegion` createRectangle (100,100) (150,150)+ drawInWindow w $ withColor Blue $+ polyline [(20,20), (20,100), (100,100), (100,20), (20,20)]+ drawInWindow w $ withColor Blue $+ polyline [(50,50), (50,150), (150,150), (150,50), (50,50)]+ drawInWindow w $ withColor Green $ drawRegion region loopEvents w- closeWindow w+ closeWindow w loopEvents w = loop where loop = do e <- getWindowEvent w
demo/Snowflake.hs view
@@ -53,7 +53,7 @@ r = v2 <+> (0.5 .* dir) <+> ((1/3) .* ort) s = v2 <+> (0.5 .* dir) <+> ((-1/3) .* ort) in --(v2,p) : (q,v1) : gen ((p,r) : (q,r) : (p,s) : (q,s) : ls)- gen ((v2,p) : (q,v1) : (p,r) : (q,r) : (p,s) : (q,s) : ls)+ gen ((v2,p) : (q,v1) : (p,r) : (q,r) : (p,s) : (q,s) : ls) -- kauniimpi kuva (mutta tehtävänannon vastainen) tulee -- korvaamalla edellinen lauseke seuraavalla: -- gen ((v2,p) : (q,v1) : (p,r) : (q,r) : (p,s) : (q,s) : ls)@@ -72,8 +72,12 @@ ls = gen [((1/8 * xmax, 1/2 * ymax), (7/8 * xmax, 1/2 * ymax))] setGraphic w (draw ls)- e <- getWindowEvent w- case e of Resize -> loop w- _ -> return ()+ nextEvent w++ nextEvent w = do+ e <- getWindowEvent w+ case e of Closed -> return ()+ Resize -> loop w+ _ -> nextEvent w main = test
soegtk.cabal view
@@ -1,25 +1,25 @@ Name: soegtk-Version: 0.11.1+Version: 0.12.1 License: LGPL-2.1 License-file: COPYING Copyright: (c) 2001-2010 The Gtk2Hs Team Author: Duncan Coutts, Paul Liu-Maintainer: gtk2hs-users@sourceforge.net-Build-Type: Custom-Cabal-Version: >= 1.6.0+Maintainer: gtk2hs-users@lists.sourceforge.net+Build-Type: Simple+Cabal-Version: >= 1.8 Stability: provisional-homepage: http://www.haskell.org/gtk2hs/+homepage: http://projects.haskell.org/gtk2hs/ bug-reports: http://hackage.haskell.org/trac/gtk2hs/ Synopsis: GUI functions as used in the book "The Haskell School of Expression". Description: An alternative implementation of the graphics library used in the book The Haskell School of Expression, by Paul Hudak, <http://www.haskell.org/soe/ This library builds on top of Gtk+.- + Category: Graphics-Tested-With: GHC == 6.12.1+Tested-With: GHC == 6.10.4, GHC == 6.12.3, GHC == 7.0.3, GHC == 7.2.1 -Data-Dir: demo-Data-Files: BouncingBall.hs+Data-Dir: demo+Data-Files: BouncingBall.hs Demo1.hs Demo2.hs Makefile@@ -30,15 +30,12 @@ location: http://code.haskell.org/soegtk/ Library- build-depends: base >= 4 && < 5, array, containers, haskell98, mtl,- glib >= 0.11 && < 0.12, - cairo >= 0.11 && < 0.12,- gtk >= 0.11 && < 0.12, + build-depends: base >= 4 && < 5,+ cairo >= 0.12 && < 0.13,+ gtk >= 0.12 && < 0.13,+ stm >= 2.0 && < 3.0, old-time >= 1.0.0.2- + exposed-modules:- Graphics.SOE.Gtk + Graphics.SOE.Gtk - x-c2hs-Header: gtk/gtk.h- pkgconfig-depends: gtk+-2.0-