diff --git a/Graphics/SOE/Gtk.chs b/Graphics/SOE/Gtk.chs deleted file mode 100644 --- a/Graphics/SOE/Gtk.chs +++ /dev/null @@ -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, . --- --- 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 diff --git a/Graphics/SOE/Gtk.hs b/Graphics/SOE/Gtk.hs new file mode 100644 --- /dev/null +++ b/Graphics/SOE/Gtk.hs @@ -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, . +-- +-- 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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 "" . 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 diff --git a/demo/BouncingBall.hs b/demo/BouncingBall.hs --- a/demo/BouncingBall.hs +++ b/demo/BouncingBall.hs @@ -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 diff --git a/demo/Demo1.hs b/demo/Demo1.hs --- a/demo/Demo1.hs +++ b/demo/Demo1.hs @@ -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 diff --git a/demo/Demo2.hs b/demo/Demo2.hs --- a/demo/Demo2.hs +++ b/demo/Demo2.hs @@ -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 diff --git a/demo/Snowflake.hs b/demo/Snowflake.hs --- a/demo/Snowflake.hs +++ b/demo/Snowflake.hs @@ -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 diff --git a/soegtk.cabal b/soegtk.cabal --- a/soegtk.cabal +++ b/soegtk.cabal @@ -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, = 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 -