HGL-3.2.0.2/0000755000514200001600000000000011274041443011116 5ustar cxltomcatHGL-3.2.0.2/LICENSE0000644000514200001600000000255011274041443012125 0ustar cxltomcatThe Haskell Graphics Library is Copyright (c) Alastair Reid, 1996-2003, All rights reserved, and is distributed as free software under the following license. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Neither name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. HGL-3.2.0.2/Setup.hs0000644000514200001600000000012711274041443012552 0ustar cxltomcatmodule Main (main) where import Distribution.Simple main :: IO () main = defaultMain HGL-3.2.0.2/Graphics/0000755000514200001600000000000011274041443012656 5ustar cxltomcatHGL-3.2.0.2/Graphics/HGL/0000755000514200001600000000000011274041443013270 5ustar cxltomcatHGL-3.2.0.2/Graphics/HGL/X11/0000755000514200001600000000000011274041443013641 5ustar cxltomcatHGL-3.2.0.2/Graphics/HGL/X11/DC.hs0000644000514200001600000000361411274041443014467 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.X11.DC -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : internal -- Portability : non-portable (requires concurrency) -- -- A simple graphics library. -- ----------------------------------------------------------------------------- -- #hide module Graphics.HGL.X11.DC ( drawUnbuffered, drawBuffered, erase ) where import Graphics.HGL.X11.Types import qualified Graphics.X11.Xlib as X import Data.IORef( IORef, readIORef, writeIORef ) import Control.Concurrent( readMVar ) import Graphics.HGL.Internals.Draw ---------------------------------------------------------------- -- Draw ---------------------------------------------------------------- drawUnbuffered :: DC -> Draw () -> IO () drawUnbuffered dc p = do unDraw erase dc unDraw p dc drawBuffered :: DC -> Draw () -> X.GC -> Int -> IORef (Maybe X.Pixmap) -> IO () drawBuffered dc p gc depth ref_mbuffer = do (_,(width,height)) <- readMVar (ref_rect dc) -- Note: The buffer is deallocated whenever the window size changes! mbuffer <- readIORef ref_mbuffer buffer <- case mbuffer of Nothing -> X.createPixmap (disp dc) (drawable dc) width height (fromIntegral depth) Just buffer -> return buffer X.fillRectangle (disp dc) buffer gc 0 0 width height unDraw p dc{drawable=buffer} X.copyArea (disp dc) buffer (drawable dc) (paintGC dc) 0 0 width height 0 0 writeIORef ref_mbuffer (Just buffer) erase :: Draw () erase = mkDraw (\ dc -> X.clearWindow (disp dc) (drawable dc)) ---------------------------------------------------------------- -- End ---------------------------------------------------------------- HGL-3.2.0.2/Graphics/HGL/X11/Timer.hs0000644000514200001600000000701711274041443015262 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.X11.Timer -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : internal -- Portability : non-portable (requires concurrency) -- -- A simple graphics library. -- ----------------------------------------------------------------------------- -- #hide module Graphics.HGL.X11.Timer ( Timer, new, stop , Timers, newTimers, clearTimers, nextTick, fireTimers ) where import Control.Concurrent ( MVar, newMVar, takeMVar, putMVar, readMVar ) import Graphics.HGL.Internals.Utilities( modMVar_ ) import Graphics.HGL.Internals.Types ---------------------------------------------------------------- -- Interface ---------------------------------------------------------------- data Timer = Timer { period :: Time -- how often does it fire , action :: IO () -- what to do when it does , tag :: MVar () -- something that supports an equality test } -- A standard timer implementation using a list of (delta-time,timer) pairs. type Timers = MVar [(Time, Timer)] newTimers :: IO Timers clearTimers :: Timers -> IO () nextTick :: Timers -> IO (Maybe Time) fireTimers :: Timers -> Time -> IO () new :: Timers -> Time -> IO () -> IO Timer stop :: Timers -> Timer -> IO () ---------------------------------------------------------------- -- Implementation ---------------------------------------------------------------- newTimers = do newMVar [] -- This will only work if the mvar is non-empty. -- Fortunately, all operations on timers do atomic updates (modMVar) -- so this should be true. clearTimers ts = do modMVar_ ts (const []) fireTimers timers t = do xs <- takeMVar timers let (ts,xs') = firedTimers t xs xs'' = foldr insert xs' ts putMVar timers xs'' mapM_ action ts where insert :: Timer -> [(Time,Timer)] -> [(Time,Timer)] insert timer = insertTimer (period timer) timer nextTick timers = do ts <- readMVar timers case ts of ((t,_):_) -> return (Just t) _ -> return Nothing new timers t a = do tag <- newMVar () let timer = Timer{period=t, action=a, tag=tag} modMVar_ timers (insertTimer t timer) return timer stop timers timer = do modMVar_ timers (deleteTimer timer) instance Eq Timer where t1 == t2 = tag t1 == tag t2 insertTimer :: Time -> Timer -> [(Time,Timer)] -> [(Time,Timer)] insertTimer t timer [] = [(t,timer)] insertTimer t timer (x@(t',timer'):xs) | t <= t' = (t,timer) : (t'-t, timer') : xs | otherwise = x : insertTimer (t-t') timer xs deleteTimer :: Timer -> [(Time,Timer)] -> [(Time,Timer)] deleteTimer timer [] = [] deleteTimer timer (x@(t',timer'):xs) | timer == timer' = case xs of [] -> [] (t'', timer''):xs' -> (t'+t'', timer''):xs' | otherwise = x : deleteTimer timer xs -- we could try to avoid timer drift by returning how "late" we are -- in firing the timer -- Maybe a better approach is to make use of the real-time clock provided -- by the OS and stay in sync with that? firedTimers :: Time -> [(Time,Timer)] -> ([Timer],[(Time,Timer)]) firedTimers t [] = ([],[]) firedTimers t ((t',timer):xs) | t < t' = ([], (t'-t,timer):xs) | otherwise = let (timers, xs') = firedTimers (t-t') xs in (timer : timers, xs') ---------------------------------------------------------------- -- End ---------------------------------------------------------------- HGL-3.2.0.2/Graphics/HGL/X11/Window.hs0000644000514200001600000005400011274041443015443 0ustar cxltomcat{-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.X11.Window -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : internal -- Portability : non-portable (requires concurrency) -- -- A simple graphics library. -- ----------------------------------------------------------------------------- -- #hide module Graphics.HGL.X11.Window ( runGraphicsEx -- :: String -> IO () -> IO () , Window(events, graphic) , openWindowEx -- :: Title -> Maybe Point -> Size -> -- RedrawMode -> Maybe Time -> IO Window , closeWindow -- :: Window -> IO () , getWindowRect -- :: Window -> IO (Point,Point) , redrawWindow -- :: Window -> IO () , directDraw -- :: Window -> Graphic -> IO () , sendTicks, findWindow, showEvent ) where import Graphics.HGL.Internals.Types import Graphics.HGL.Internals.Draw (Graphic, Draw, unDraw) import Graphics.HGL.Internals.Event import qualified Graphics.HGL.Internals.Utilities as Utils import qualified Graphics.HGL.Internals.Events as E import Graphics.HGL.X11.Types import Graphics.HGL.X11.Display import Graphics.HGL.X11.DC import qualified Graphics.HGL.X11.Timer as T import qualified Graphics.X11.Xlib as X import Control.Concurrent (forkIO, yield) import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, readMVar) import Control.Exception (finally) import Control.Monad (when) import Data.Bits import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Maybe (isJust, fromJust, fromMaybe) import System.IO.Unsafe (unsafePerformIO) ---------------------------------------------------------------- -- Interface ---------------------------------------------------------------- data Window = MkWindow { wnd :: X.Window -- the real window , ref_dc :: MVar (Maybe DC) -- "device context" , exposed :: IORef Bool -- have we had an expose event yet? , events :: E.Events -- the event stream , graphic :: MVar Graphic -- the current graphic , redraw :: RedrawStuff , timer :: Maybe T.Timer } openWindowEx :: Title -> Maybe Point -> Size -> RedrawMode -> Maybe Time -> IO Window closeWindow :: Window -> IO () getWindowRect :: Window -> IO (Point,Point) redrawWindow :: Window -> IO () directDraw :: Window -> Graphic -> IO () ---------------------------------------------------------------- -- Implementation ---------------------------------------------------------------- ---------------------------------------------------------------- -- Windows ---------------------------------------------------------------- closeWindow' :: Bool -> Window -> IO () closeWindow' destroyXWindow w = do mb_dc <- takeMVar (ref_dc w) case mb_dc of Just dc -> do putMVar (ref_dc w) Nothing -- mark it for dead X.freeGC (disp dc) (textGC dc) X.freeGC (disp dc) (paintGC dc) X.freeGC (disp dc) (brushGC dc) case (redraw w) of UnbufferedStuff -> return () BufferedStuff gc _ ref_mbuffer -> do X.freeGC (disp dc) gc removeBuffer dc ref_mbuffer when destroyXWindow $ do X.destroyWindow (disp dc) (drawable dc) -- ths dc had better hold a window! minor_eloop (disp dc) Nothing -> do putMVar (ref_dc w) Nothing removeBuffer :: DC -> IORef (Maybe X.Pixmap) -> IO () removeBuffer dc ref_mbuffer = do mbuffer <- readIORef ref_mbuffer case mbuffer of Nothing -> return () Just buffer -> X.freePixmap (disp dc) buffer writeIORef ref_mbuffer Nothing removeDeadWindows :: IO () removeDeadWindows = do ws <- takeMVar wnds ws' <- remove ws [] putMVar wnds ws' where remove [] r = return r remove (w:ws) r = do mb_dc <- readMVar (ref_dc w) if (isJust mb_dc) then remove ws (w:r) else remove ws r closeAllWindows :: IO () closeAllWindows = do ws <- readMVar wnds mapM_ (closeWindow' True) ws removeDeadWindows -- bring out your dead sendTicks :: IO () sendTicks = do ws <- readMVar wnds sequence_ [ E.sendTick (events w) | w <- ws ] -- persistent list of open windows wnds :: MVar [Window] wnds = unsafePerformIO (newMVar []) -- persistent list of timers timers :: T.Timers timers = unsafePerformIO T.newTimers runGraphicsEx :: String -> IO () -> IO () runGraphicsEx host m = do when threaded $ do X.initThreads; return () X.setDefaultErrorHandler display <- openDisplay host closeAllWindows T.clearTimers timers -- color_map <- X.getStandardColormap display root X.a_RGB_BEST_MAP -- HN 2001-01-30 -- There is a race condition here since the event loop terminates if it -- encounters an empty window list (in the global, imperative, variable -- wnds). Thus, if m has not yet opened a window (assuming it will!) -- when the event_loop is entered, it will exit immediately. -- Solution: wait until either the window list is non-empty, or until -- m exits (in case it does not open a window for some reason). mDone <- newIORef False forkIO (catchErrors m `finally` writeIORef mDone True) let loop = do yield ws <- readMVar wnds d <- readIORef mDone if not (null ws) then main_eloop display else if not d then loop else return () catchErrors loop -- X.sync display True closeAllWindows -- X.sync display True -- A final yield to make sure there's no threads thinking of -- accessing the display yield closeDisplay #ifdef __GLASGOW_HASKELL__ foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool #else threaded = False #endif catchErrors :: IO () -> IO () catchErrors m = do r <- Utils.safeTry m case r of Left e -> do -- putStr "Uncaught Error: " print e Right _ -> return () return () ---------------------------------------------------------------- -- Implementation ---------------------------------------------------------------- openWindowEx name pos size redrawMode tickRate = do display <- getDisplay let corner@(X.Point x y) = fromPoint (fromMaybe (0,0) pos) (w,h) = fromSize size let screen = X.defaultScreenOfDisplay display fg_color = X.whitePixelOfScreen screen bg_color = X.blackPixelOfScreen screen depth = X.defaultDepthOfScreen screen root = X.rootWindowOfScreen screen visual = X.defaultVisualOfScreen screen -- ToDo: resurrect the old code for constructing attribute sets window <- X.allocaSetWindowAttributes $ \ attributes -> do X.set_background_pixel attributes bg_color let event_mask = ( X.buttonPressMask .|. X.buttonReleaseMask .|. X.keyPressMask .|. X.keyReleaseMask .|. X.pointerMotionMask .|. X.exposureMask .|. X.structureNotifyMask ) X.set_event_mask attributes event_mask -- We use backing store to reduce the number of expose events due to -- raising/lowering windows. X.set_backing_store attributes X.whenMapped -- We use bit-gravity to avoid generating exposure events when a window is -- made smaller (they can't be avoided when the window is enlarged). -- The choice of NW is somewhat arbitrary but hopefully works often -- enough to be worth it. X.set_bit_gravity attributes X.northWestGravity let attrmask = X.cWBackPixel .|. X.cWEventMask .|. X.cWBackingStore .|. X.cWBitGravity X.createWindow display root x y -- x, y w h -- width, height 1 -- border_width depth -- use CopyFromParent?? X.inputOutput visual -- use CopyFromParent?? attrmask attributes -- AC, 1/9/2000: Tell the window manager that we want to use the -- DELETE_WINDOW protocol delWinAtom <- X.internAtom display "WM_DELETE_WINDOW" False X.setWMProtocols display window [delWinAtom] X.setTextProperty display window name X.wM_ICON_NAME X.setTextProperty display window name X.wM_NAME X.mapWindow display window X.raiseWindow display window text_gc <- X.createGC display window X.setBackground display text_gc bg_color X.setForeground display text_gc fg_color pen_gc <- X.createGC display window X.setBackground display pen_gc bg_color X.setForeground display pen_gc fg_color brush_gc <- X.createGC display window X.setBackground display brush_gc bg_color X.setForeground display brush_gc fg_color redraw <- case redrawMode of Unbuffered -> return UnbufferedStuff DoubleBuffered -> do gc <- X.createGC display window X.setForeground display gc bg_color -- gc for clearing the screen ref_mbuffer <- newIORef Nothing return (BufferedStuff gc (fromIntegral depth) ref_mbuffer) win <- newWindow display window fg_color text_gc pen_gc brush_gc (corner,(w,h)) redraw tickRate -- It might be some time till we get back to the event loop -- so we try to process as many events as possible now. -- This is a bit of a hack and partly aimed at avoiding the bug that -- directDraw might try to draw something before the first expose event -- is processed. -- To make the hack even more effective, we wait a short time (allegedly -- 1uS) and synchronise before looking for the event. -- -- NB: -- This whole thing is based on the implicit notion that the server thread -- is "lower priority" than the user threads. That is, the server thread -- will only run when no user threads are runnable. -- -- Or, more concretely, only the server thread calls yield so it's safe -- to call the minor_eloop (which doesn't yield or block) but not the -- major_eloop because, amongst other things, it may yield or block. X.waitForEvent display 1 X.sync display False minor_eloop display return win closeWindow w = do closeWindow' True w removeDeadWindows -- bring out your dead getWindowRect w = do mb_dc <- readMVar (ref_dc w) case mb_dc of Just dc -> do (pt,sz) <- readMVar (ref_rect dc) return (toPoint pt, toSize sz) Nothing -> return ((0,0),(0,0)) -- ToDo? -- main_eloop :: X.Display -> IO () -- main_eloop d = -- X.allocaXEvent $ \ xevent -> do -- let loop = do -- -- X.sync d False -- wild attempt to fix the broken X connection problem -- count <- X.pending d -- if (count > 0) then do -- -- X.sync d False -- wild attempt to fix the broken X connection problem -- X.nextEvent d xevent -- window <- X.get_Window xevent -- wnd <- findWindow window -- etype <- X.get_EventType xevent -- -- print (window,etype) -- dispatchEvent wnd etype xevent -- ws <- readMVar wnds -- unless (null ws) loop -- else -- loop -- loop -- This is the main event loop in the program main_eloop :: X.Display -> IO () main_eloop d = X.allocaXEvent $ \ xevent -> do let handleEvent = do count <- X.pending d next <- T.nextTick timers if (count > 0 || not (isJust next)) then do -- Event in queue or no tick pending. X.nextEvent d xevent window <- X.get_Window xevent etype <- X.get_EventType xevent -- showEvent etype withWindow window $ \ wnd -> do dispatchEvent d wnd etype xevent else do -- No event and tick pending. let delay = fromJust next t0 <- getTime timedOut <- X.waitForEvent d (fromIntegral (delay * 1000)) t1 <- getTime T.fireTimers timers (t1 - t0) let loop = do -- We yield at this point because we're (potentially) -- about to block so we should give other threads a chance -- to run. yield ws <- readMVar wnds if (null ws) then return () else do handleEvent loop loop -- This event loop is the same as above except that it is -- non-blocking: it only handles those events that have already arrived. -- And this is important because it means we don't have to yield which -- means it can safely be called by user code (see comment in openWindowEx). minor_eloop :: X.Display -> IO () minor_eloop d = X.allocaXEvent $ \ xevent -> do let handleEvent = do X.nextEvent d xevent window <- X.get_Window xevent etype <- X.get_EventType xevent -- print etype withWindow window $ \ wnd -> do dispatchEvent d wnd etype xevent return () loop = do ws <- readMVar wnds if null ws then return () else do -- Note: _do not_ call pending if null ws count <- X.pending d if count == 0 then return () else do handleEvent loop loop -- The DC is wrapped inside (MVar (Maybe ...)) so that we can mark -- windows as being dead the moment they die and so that we don't -- try to keep writing to them afterwards. -- The events remain valid after the window dies. -- It might be wiser to clear all events(???) and start returning -- Closed whenever events are read - or (more GC friendly?), when -- first read occurs but block thereafter? data RedrawStuff = UnbufferedStuff | BufferedStuff X.GC -- GC with foreground = background_color Int -- depth (IORef (Maybe X.Pixmap)) -- The buffer, allocated on demand -- drawBuffered. drawOnDC :: DC -> Draw () -> RedrawStuff -> IO () drawOnDC dc p redraw = case redraw of UnbufferedStuff -> drawUnbuffered dc p BufferedStuff gc depth ref_mbuffer -> drawBuffered dc p gc depth ref_mbuffer newWindow :: X.Display -> X.Window -> X.Pixel -> X.GC -> X.GC -> X.GC -> (X.Point,(X.Dimension,X.Dimension)) -> RedrawStuff -> Maybe Time -> IO Window newWindow display window fg_color tgc pgc bgc rect redraw tickRate = do es <- E.newEvents pic <- newMVar (return ()) -- failed attempts to find the default font -- f' <- X.fontFromGC display tgc -- f <- X.queryFont display f' -- Since we can't ask the server what default font it chooses to bless -- us with, we have to set an explicit font. f <- X.loadQueryFont display "9x15" -- a random choice X.setFont display tgc (X.fontFromFontStruct f) bits <- newMVar DC_Bits { textColor = RGB 255 255 255 , bkColor = RGB 0 0 0 , bkMode = Transparent , textAlignment = (Left',Top) , brush = Brush (RGB 255 255 255) , pen = defaultPen fg_color , font = Font f } ref_rect <- newMVar rect dc <- newMVar (Just MkDC{disp=display,drawable=window,textGC=tgc,paintGC=pgc,brushGC=bgc,ref_rect=ref_rect,ref_bits=bits}) timer <- case tickRate of Just t -> T.new timers t (E.sendTick es) >>= return.Just Nothing -> return Nothing ref_exposed <- newIORef False let wnd = MkWindow{wnd=window,ref_dc=dc,exposed=ref_exposed,events=es,graphic=pic,redraw=redraw,timer=timer} Utils.modMVar wnds (wnd:) return wnd redrawWindow w = do canDraw <- readIORef (exposed w) when canDraw $ do mb_dc <- readMVar (ref_dc w) case mb_dc of Just dc -> do p <- readMVar (graphic w) drawOnDC dc p (redraw w) Nothing -> return () directDraw w p = do mb_dc <- readMVar (ref_dc w) canDraw <- readIORef (exposed w) when canDraw $ do case mb_dc of Just dc -> unDraw p dc Nothing -> return () findWindow :: X.Window -> IO Window findWindow xw = do ws <- readMVar wnds return (head [ w | w <- ws, xw == wnd w ]) -- ToDo: don't use head withWindow :: X.Window -> (Window -> IO ()) -> IO () withWindow xw k = do ws <- readMVar wnds case [ w | w <- ws, xw == wnd w ] of (w:_) -> k w _ -> return () send :: Window -> Event -> IO () send w e = E.sendEvent (events w) e dispatchEvent :: X.Display -> Window -> X.EventType -> X.XEventPtr -> IO () dispatchEvent display w etype xevent | etype == X.graphicsExpose || etype == X.expose = paint | etype == X.motionNotify = mouseMove | etype == X.buttonPress = button True | etype == X.buttonRelease = button False | etype == X.keyPress = key True | etype == X.keyRelease = key False | etype == X.configureNotify = reconfig | etype == X.destroyNotify = destroy -- AC, 1/9/2000: treat a ClientMesage as a destroy event -- TODO: really need to examine the event in more detail, -- and ensure that xevent.xclient.message_type==ATOM_WM_PROTOCOLS && -- xevent.xclient.data.l[0]==ATOM_WM_DELETE_WINDOW -- where ATOM_XXX is obtained from XInternAtom(dpy,"XXX",False) | etype == X.clientMessage = destroy -- ToDo: consider printing a warning message | otherwise = return () where -- Redrawing is awkward because the request comes as a number of -- separate events. We need to do one of the following (we currently -- do a combination of (1) and (3)): -- 1) Do a single redraw of the entire window but first delete all other -- expose events for this window from the queue. -- 2) Use all expose events for this window to build a Region object -- and use that to optimise redraws. -- 3) When double-buffering, use the buffer and information about -- whether it is up to date to serve redraws from the buffer. -- When single-buffering, use the server's backing store to reduce -- the number of expose events. (Combine with bit-gravity info to -- handle resize requests.) paint :: IO () paint = do let stompOnExposeEvents = do -- X.get_ExposeEvent xevent >>= print gotOne <- X.checkTypedWindowEvent display (wnd w) X.expose xevent when gotOne stompOnExposeEvents writeIORef (exposed w) True -- now safe to draw directly stompOnExposeEvents p <- readMVar (graphic w) mb_dc <- readMVar (ref_dc w) case mb_dc of Just dc -> drawOnDC dc p (redraw w) Nothing -> return () button :: Bool -> IO () button isDown = do (_,_,_,x,y,_,_,_,b,_) <- X.get_ButtonEvent xevent let isLeft = b == 1 -- assume that button 1 = left button send w Button{pt = (fromIntegral x, fromIntegral y), isLeft=isLeft, isDown=isDown} -- An X KeySym is *not* a character; not even a Unicode character! And -- since characters in Hugs only are 8-bit, we get a runtime error -- below. There is an underlying assumption that key events only -- involve characters. But of course there are function keys, arrow -- keys, etc. too. While this will be a problem if one wants to get at -- e.g. arrow keys (e.g. for some drawing application) or at -- dead/multi-keys for doing proper input, we'll ignore them -- completely for now. Furthermore, one really needs to call -- XlookupString (not XkeysymToString!) to do the processing! We'll -- ignore that too, and do a static mapping of just a few keysyms. key :: Bool -> IO () key isDown = do -- Should really use XmbLookupString here to make compose work. -- It's OK to call X.lookupString both on key up and down events. -- Not true for X.mbLookupString. In that case, use e.g. X.lookup -- on key up events. (mks, s) <- X.lookupString (X.asKeyEvent xevent) case mks of Just ks -> send w (Key {keysym = MkKey ks, isDown = isDown}) Nothing -> return () if isDown then (mapM_ (\c -> send w (Char {char = c})) s) else return () mouseMove ::IO () mouseMove = do (_,_,_,x,y,_,_,_,_,_) <- X.get_MotionEvent xevent send w MouseMove{ pt = (fromIntegral x, fromIntegral y) } reconfig :: IO () reconfig = do (x,y,width,height) <- X.get_ConfigureEvent xevent mb_dc <- readMVar (ref_dc w) case mb_dc of Just dc -> do Utils.modMVar (ref_rect dc) (const ((X.Point x y),(width,height))) case (redraw w) of UnbufferedStuff -> return () BufferedStuff _ _ ref_mbuffer -> removeBuffer dc ref_mbuffer Nothing -> return () -- don't send new size, it may be out of date by the time we -- get round to reading the event send w Resize destroy :: IO () destroy = do -- putStrLn "Window Destroyed" -- todo closeWindow' True w removeDeadWindows -- bring out your dead send w Closed ---------------------------------------------------------------- -- Utilities ---------------------------------------------------------------- -- Only for debugging showEvent :: X.EventType -> IO () showEvent etype | etype == X.keyPress = putStrLn "keyPress" | etype == X.keyRelease = putStrLn "keyRelease" | etype == X.buttonPress = putStrLn "buttonPress" | etype == X.buttonRelease = putStrLn "buttonRelease" | etype == X.motionNotify = putStrLn "motionNotify" | etype == X.enterNotify = putStrLn "enterNotify" | etype == X.leaveNotify = putStrLn "leaveNotify" | etype == X.focusIn = putStrLn "focusIn" | etype == X.focusOut = putStrLn "focusOut" | etype == X.keymapNotify = putStrLn "keymapNotify" | etype == X.expose = putStrLn "expose" | etype == X.graphicsExpose = putStrLn "graphicsExpose" | etype == X.noExpose = putStrLn "noExpose" | etype == X.visibilityNotify = putStrLn "visibilityNotify" | etype == X.createNotify = putStrLn "createNotify" | etype == X.destroyNotify = putStrLn "destroyNotify" | etype == X.unmapNotify = putStrLn "unmapNotify" | etype == X.mapNotify = putStrLn "mapNotify" | etype == X.mapRequest = putStrLn "mapRequest" | etype == X.reparentNotify = putStrLn "reparentNotify" | etype == X.configureNotify = putStrLn "configureNotify" | etype == X.configureRequest = putStrLn "configureRequest" | etype == X.gravityNotify = putStrLn "gravityNotify" | etype == X.resizeRequest = putStrLn "resizeRequest" | etype == X.circulateNotify = putStrLn "circulateNotify" | etype == X.circulateRequest = putStrLn "circulateRequest" | etype == X.propertyNotify = putStrLn "propertyNotify" | etype == X.selectionClear = putStrLn "selectionClear" | etype == X.selectionRequest = putStrLn "selectionRequest" | etype == X.selectionNotify = putStrLn "selectionNotify" | etype == X.colormapNotify = putStrLn "colormapNotify" | etype == X.clientMessage = putStrLn "clientMessage" | etype == X.mappingNotify = putStrLn "mappingNotify" | etype == X.lASTEvent = putStrLn "lASTEvent" | otherwise = putStrLn ("Unknown X event type: " ++ show etype) ---------------------------------------------------------------- -- End ---------------------------------------------------------------- HGL-3.2.0.2/Graphics/HGL/X11/Display.hs0000644000514200001600000000271311274041443015605 0ustar cxltomcat-- #hide module Graphics.HGL.X11.Display ( getDisplayName , openDisplay , closeDisplay , getDisplay ) where import Graphics.HGL.Internals.Utilities (modMVar) import qualified Graphics.X11.Xlib as X import Control.Concurrent.MVar (MVar, newMVar, readMVar, takeMVar, putMVar) import Control.Monad (when) import Data.Maybe (isJust) import System.Environment (getEnv) import System.IO.Error (try) import System.IO.Unsafe (unsafePerformIO) getDisplayName :: IO String getDisplayName = do disp <- try (getEnv "DISPLAY") return (either (const ":0.0") id disp) displayRef :: MVar (Maybe X.Display) displayRef = unsafePerformIO (newMVar Nothing) openDisplay :: String -> IO () -> IO X.Display openDisplay host cleanup = do mb_display <- readMVar displayRef when (isJust mb_display) cleanup openDisplay' where openDisplay' = do display <- X.openDisplay host `catch` \ err -> ioError (userError ("Unable to open X display " ++ host)) modMVar displayRef (const $ Just display) return display closeDisplay :: IO () closeDisplay = do mb_display <- takeMVar displayRef case mb_display of Nothing -> do putMVar displayRef Nothing Just display -> do X.closeDisplay display putMVar displayRef Nothing getDisplay :: IO X.Display getDisplay = do mb_display <- readMVar displayRef case mb_display of Nothing -> ioError $ userError "Display not opened yet" Just display -> return display HGL-3.2.0.2/Graphics/HGL/X11/Types.hs0000644000514200001600000000550211274041443015303 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.X11.Types -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : internal -- Portability : non-portable (requires concurrency) -- -- Basic types for a simple graphics library. -- ----------------------------------------------------------------------------- -- #hide module Graphics.HGL.X11.Types ( DC(..) , DC_Bits(..) , Font(Font), Brush(Brush), Pen(Pen), defaultPen , Key(MkKey) , fromPoint, toPoint , fromSize, toSize , lookupColor ) where import Graphics.HGL.Internals.Types import qualified Graphics.X11.Xlib as X import Control.Concurrent.MVar (MVar) import Data.Bits import Data.Word (Word8) ---------------------------------------------------------------- -- Units ---------------------------------------------------------------- fromPoint :: Point -> X.Point toPoint :: X.Point -> Point fromSize :: Size -> (X.Dimension, X.Dimension) toSize :: (X.Dimension, X.Dimension) -> Size fromPoint (x,y) = X.Point (fromIntegral x) (fromIntegral y) toPoint (X.Point x y) = (fromIntegral x, fromIntegral y) fromSize (x,y) = (fromIntegral x, fromIntegral y) toSize (x,y) = (fromIntegral x, fromIntegral y) ---------------------------------------------------------------- -- Device Context (simulates Win32 Device Contexts) ---------------------------------------------------------------- data DC = MkDC { disp :: X.Display , drawable :: X.Drawable , textGC :: X.GC , paintGC :: X.GC , brushGC :: X.GC , ref_rect :: MVar (X.Point,(X.Dimension, X.Dimension)) , ref_bits :: MVar DC_Bits } data DC_Bits = DC_Bits { textColor :: RGB , bkColor :: RGB , bkMode :: BkMode , textAlignment :: Alignment , brush :: Brush , pen :: Pen , font :: Font } newtype Key = MkKey X.KeySym deriving Show newtype Font = Font X.FontStruct newtype Brush = Brush RGB data Pen = Pen Style Int X.Pixel defaultPen :: X.Pixel -> Pen defaultPen col = Pen Solid 0 col lookupColor :: X.Display -> RGB -> IO X.Pixel lookupColor display col = (do (X.Color p _ _ _ _) <- X.allocColor display color_map (X.Color 0 r g b xcolor_flags) return p) `catch` \ err -> print err >> return 0 -- ioError (userError ("Error: " ++ show err -- ++ "\nUnable to allocate colo[u]r " ++ show (r,g,b) -- ++ " - I'll bet you're running Netscape.")) where screen = X.defaultScreenOfDisplay display color_map = X.defaultColormapOfScreen screen RGB r' g' b' = col (r,g,b) = ((fromIntegral r') * 256, (fromIntegral g') * 256, (fromIntegral b')*256) xcolor_flags :: Word8 xcolor_flags = X.doRed .|. X.doGreen .|. X.doBlue HGL-3.2.0.2/Graphics/HGL/Draw/0000755000514200001600000000000011274041443014165 5ustar cxltomcatHGL-3.2.0.2/Graphics/HGL/Draw/Brush.hs0000644000514200001600000000554511274041443015615 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.Draw.Brush -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : non-portable (requires concurrency) -- -- Brushes, used for filling shapes. -- ----------------------------------------------------------------------------- module Graphics.HGL.Draw.Brush ( Brush , createBrush , deleteBrush , selectBrush -- :: Brush -> Draw Brush , mkBrush -- , blackBrush, whiteBrush ) where import Graphics.HGL.Draw.Text (RGB(..)) import Graphics.HGL.Draw.Monad (Draw) import Graphics.HGL.Internals.Draw (mkDraw) #if !X_DISPLAY_MISSING import Graphics.HGL.X11.Types import qualified Graphics.X11.Xlib as X import Control.Concurrent (takeMVar, putMVar) #else import Graphics.HGL.Draw.Monad (ioToDraw, bracket) import qualified Graphics.Win32 as Win32 #endif ---------------------------------------------------------------- -- The interface ---------------------------------------------------------------- #if X_DISPLAY_MISSING newtype Brush = MkBrush Win32.HBRUSH #endif -- | Create a 'Brush'. createBrush :: RGB -> IO Brush -- | Destroy a 'Brush' created with 'createBrush'. deleteBrush :: Brush -> IO () -- | Set the 'Brush' for subsequent drawing, returning the previous setting. selectBrush :: Brush -> Draw Brush -- | Create a 'Brush' locally to a drawing. mkBrush :: RGB -> (Brush -> Draw a) -> Draw a ---------------------------------------------------------------- -- The implementation ---------------------------------------------------------------- #if !X_DISPLAY_MISSING createBrush col = return (Brush col) deleteBrush _ = return () -- ToDo: how do I set background colour for brush and pen? selectBrush b@(Brush x) = mkDraw $ \ dc -> do bs <- takeMVar (ref_bits dc) putMVar (ref_bits dc) bs{brush=b} p <- lookupColor (disp dc) x X.setForeground (disp dc) (brushGC dc) p return (brush bs) mkBrush c g = g (Brush c) #else /* X_DISPLAY_MISSING */ createBrush (RGB r g b) = do b <- Win32.createSolidBrush (Win32.rgb r g b) return (MkBrush b) deleteBrush (MkBrush b) = Win32.deleteBrush b selectBrush (MkBrush b) = mkDraw $ \hdc -> do b' <- Win32.selectBrush hdc b return (MkBrush b') mkBrush color = bracket (ioToDraw $ createBrush color) (ioToDraw . deleteBrush) ---------------------------------------------------------------- -- -- -- special cases - these should _never_ be deleted -- blackBrush :: IO Brush -- whiteBrush :: IO Brush -- -- blackBrush = Win32.getStockBrush Win32.bLACK_BRUSH >>= return . MkBrush -- whiteBrush = Win32.getStockBrush Win32.wHITE_BRUSH >>= return . MkBrush -- ---------------------------------------------------------------- #endif /* X_DISPLAY_MISSING */ HGL-3.2.0.2/Graphics/HGL/Draw/Monad.hs0000644000514200001600000000142111274041443015555 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.Draw.Monad -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : non-portable (requires concurrency) -- -- The 'Draw' monad, with graphical objects as a special case. -- ----------------------------------------------------------------------------- module Graphics.HGL.Draw.Monad ( Graphic -- = Draw () , Draw , ioToDraw -- :: IO a -> Draw a , bracket -- :: Draw a -> (a -> Draw b) -> (a -> Draw c) -> Draw c , bracket_ -- :: Draw a -> (a -> Draw b) -> Draw c -> Draw c ) where import Graphics.HGL.Internals.Draw HGL-3.2.0.2/Graphics/HGL/Draw/Pen.hs0000644000514200001600000000725511274041443015254 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.Draw.Pen -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : non-portable (requires concurrency) -- -- Pens, used for drawing lines. -- -- Portability notes: -- -- * On Win32, the pen is also used to draw a line round all the filled -- shapes --- so the pen color also affects how polygons, ellipses -- and regions are drawn. -- -- * On Win32, the 'Style' is ignored (i.e. treated as 'Solid') for pens -- of width greater than 1. This problem does not apply to X11. -- ----------------------------------------------------------------------------- module Graphics.HGL.Draw.Pen ( Pen , Style(Solid, Dash, Dot, DashDot, DashDotDot, Null, InsideFrame) , createPen -- :: Style -> Int -> RGB -> IO Pen , deletePen , selectPen -- :: Pen -> Draw Pen , mkPen -- :: Style -> Int -> RGB -> (Pen -> Draw a) -> Draw a ) where import Graphics.HGL.Draw.Text (RGB) import Graphics.HGL.Draw.Monad (Draw, ioToDraw) import Graphics.HGL.Internals.Types (Style(..)) import Graphics.HGL.Internals.Draw (mkDraw) #if !X_DISPLAY_MISSING import Graphics.HGL.X11.Types import Graphics.HGL.X11.Display import qualified Graphics.X11.Xlib as X import Control.Concurrent (takeMVar, putMVar) #else import Graphics.HGL.Win32.Types import qualified Graphics.Win32 as Win32 import Graphics.HGL.Draw.Monad (bracket) #endif ---------------------------------------------------------------- #if X_DISPLAY_MISSING newtype Pen = Pen Win32.HPEN #endif -- | Create a 'Pen'. createPen :: Style -> Int -> RGB -> IO Pen -- | Destroy a 'Pen' created with 'createPen'. deletePen :: Pen -> IO () -- | Set the 'Pen' for subsequent drawing, returning the previous setting. selectPen :: Pen -> Draw Pen -- | Create a 'Pen' locally to a drawing. mkPen :: Style -> Int -> RGB -> (Pen -> Draw a) -> Draw a ---------------------------------------------------------------- #if !X_DISPLAY_MISSING ---------------------------------------------------------------- -- Pens -- -- Used to draw lines and boundaries of filled shapes ---------------------------------------------------------------- createPen style width col = do display <- getDisplay pixel <- lookupColor display col return (Pen style width pixel) deletePen _ = return () -- ToDo: how do I set background colour for brush and pen? selectPen p@(Pen _ lwidth c) = mkDraw $ \ dc -> do bs <- takeMVar (ref_bits dc) putMVar (ref_bits dc) bs{pen=p} X.setForeground (disp dc) (paintGC dc) c X.setLineAttributes (disp dc) (paintGC dc) (fromIntegral lwidth) X.lineSolid X.capButt X.joinMiter return (pen bs) mkPen style width color g = do p <- ioToDraw $ createPen style width color g p #else /* X_DISPLAY_MISSING */ style :: Style -> Win32.PenStyle style Solid = Win32.pS_SOLID style Dash = Win32.pS_DASH style Dot = Win32.pS_DOT style DashDot = Win32.pS_DASHDOT style DashDotDot = Win32.pS_DASHDOTDOT style Null = Win32.pS_NULL style InsideFrame = Win32.pS_INSIDEFRAME createPen sty width c = Win32.createPen (style sty) (fromIntegral width) (fromRGB c) >>= return . Pen deletePen (Pen pen) = Win32.deletePen pen selectPen (Pen p) = mkDraw (\hdc -> do p' <- Win32.selectPen hdc p return (Pen p')) mkPen sty width c = bracket (ioToDraw $ createPen sty width c) (ioToDraw . deletePen) #endif /* X_DISPLAY_MISSING */ ---------------------------------------------------------------- -- The end ---------------------------------------------------------------- HGL-3.2.0.2/Graphics/HGL/Draw/Region.hs0000644000514200001600000001411111274041443015742 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.Draw.Region -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : non-portable (requires concurrency) -- -- An efficient representation of sets of pixels. -- ----------------------------------------------------------------------------- module Graphics.HGL.Draw.Region ( Region #if !X_DISPLAY_MISSING , emptyRegion -- :: Region #endif , rectangleRegion -- :: Point -> Point -> Region , ellipseRegion -- :: Point -> Point -> Region , polygonRegion -- :: [Point] -> Region , intersectRegion -- :: Region -> Region -> Region , unionRegion -- :: Region -> Region -> Region , subtractRegion -- :: Region -> Region -> Region , xorRegion -- :: Region -> Region -> Region , regionToGraphic -- :: Region -> Graphic ) where import Foreign.C.Types import Graphics.HGL.Units (Point, Angle) import Graphics.HGL.Draw.Monad (Graphic) import Graphics.HGL.Internals.Draw (mkDraw) #if !X_DISPLAY_MISSING import Graphics.HGL.X11.Types (DC(..), fromPoint) import qualified Graphics.X11.Xlib as X #else import Graphics.HGL.Win32.Types import qualified Graphics.Win32 as Win32 #endif import System.IO.Unsafe( unsafePerformIO ) ---------------------------------------------------------------- -- The Interface (SOE, p136) -- -- Note that Win32 does not include emptyRegion (SOE, p140). -- The obvious Win32 implementation (an empty rectangle) could create problems -- when you calculate the bounding box -- (This could be fixed by implementing Empty Regions explicitly in Haskell -- at the (small) cost of an extra test on every region operation.) ---------------------------------------------------------------- #if !X_DISPLAY_MISSING newtype Region = MkRegion X.Region #else newtype Region = MkRegion Win32.HRGN #endif #if !X_DISPLAY_MISSING -- | An empty region. This is not supported on Win32. -- It is possible to use an empty rectangle region instead. emptyRegion :: Region #endif -- | A rectangular region, with the given points as opposite corners. rectangleRegion :: Point -> Point -> Region -- | An elliptical region that fits in the rectangle with the given points -- as opposite corners. ellipseRegion :: Point -> Point -> Region -- | A polygonal region defined by a list of 'Point's. polygonRegion :: [Point] -> Region -- | The intersection of two regions. intersectRegion :: Region -> Region -> Region -- | The union of two regions. unionRegion :: Region -> Region -> Region -- | The part of the first region that is not also in the second. subtractRegion :: Region -> Region -> Region -- | The symmetric difference of two regions. xorRegion :: Region -> Region -> Region -- | Fill a 'Region' using the current 'Graphics.HGL.Draw.Brush'. regionToGraphic :: Region -> Graphic ---------------------------------------------------------------- -- The Implementation ---------------------------------------------------------------- #if !X_DISPLAY_MISSING emptyXRegion = unsafePerformIO X.createRegion emptyRegion = MkRegion emptyXRegion rectangleRegion (x0,y0) (x1,y1) = polygonRegion [(x0,y0),(x0,y1),(x1,y1),(x1,y0)] ellipseRegion p0 p1 = MkRegion $ unsafePerformIO $ do X.polygonRegion pts X.evenOddRule where X.Point x0 y0 = fromPoint p0 X.Point x1 y1 = fromPoint p1 rx = (x1 - x0) `div` 2 ry = (y1 - y0) `div` 2 cx = x0 + rx cy = y0 + ry rx' = fromIntegral rx ry' = fromIntegral ry pts = [ X.Point (cx + round (rx' * c)) (cy + round (ry' * s)) | (c,s) <- cos'n'sins ] cos'n'sins :: [(Double,Double)] cos'n'sins = [ (cos a, sin a) | a <- angles ] angles :: [Angle] angles = take 40 [0, pi/20 .. ] polygonRegion pts = MkRegion $ unsafePerformIO $ do X.polygonRegion (map fromPoint pts) X.evenOddRule intersectRegion = combine X.intersectRegion unionRegion = combine X.unionRegion subtractRegion = combine X.subtractRegion xorRegion = combine X.xorRegion type XRegionOp = X.Region -> X.Region -> X.Region -> IO CInt combine :: XRegionOp -> Region -> Region -> Region combine op (MkRegion r1) (MkRegion r2) = unsafePerformIO $ do r <- X.createRegion op r1 r2 r return (MkRegion r) regionToGraphic (MkRegion r) = mkDraw $ \ dc -> do X.setRegion (disp dc) (brushGC dc) r X.fillRectangle (disp dc) (drawable dc) (brushGC dc) 0 0 (-1) (-1) -- entire window (in 2s complement!) X.setRegion (disp dc) (brushGC dc) emptyXRegion return () #else /* X_DISPLAY_MISSING */ rectangleRegion pt0 pt1 = unsafePerformIO $ do r <- Win32.createRectRgn x0 y0 x1 y1 return (MkRegion r) where (x0,y0) = fromPoint pt0 (x1,y1) = fromPoint pt1 -- Sigh! createEllipticRgn raises an exception if either dimension -- of the ellipse is empty. We hack around this by using rectangleRegion -- in the problematic case (since createRectRgn behaves sensibly). ellipseRegion pt0 pt1 | x0 /= x1 && y0 /= y1 = unsafePerformIO $ do r <- Win32.createEllipticRgn x0 y0 x1 y1 return (MkRegion r) | otherwise = rectangleRegion pt0 pt1 where (x0,y0) = fromPoint pt0 (x1,y1) = fromPoint pt1 polygonRegion pts = unsafePerformIO $ do r <- Win32.createPolygonRgn (map fromPoint pts) Win32.wINDING return (MkRegion r) -- combine :: Win32.ClippingMode -> Region -> Region -> Region -> IO () -- combine mode (MkRegion r1) (MkRegion r2) (MkRegion result) = do -- Win32.combineRgn result r1 r2 mode -- return () combine :: Win32.ClippingMode -> Region -> Region -> Region combine mode (MkRegion r1) (MkRegion r2) = unsafePerformIO $ do r <- Win32.createRectRgn 0 0 0 0 Win32.combineRgn r r1 r2 mode return (MkRegion r) regionToGraphic (MkRegion r) = mkDraw (\hdc -> Win32.paintRgn hdc r) intersectRegion = combine Win32.rGN_AND unionRegion = combine Win32.rGN_OR xorRegion = combine Win32.rGN_XOR subtractRegion = combine Win32.rGN_DIFF #endif /* X_DISPLAY_MISSING */ ---------------------------------------------------------------- -- End ---------------------------------------------------------------- HGL-3.2.0.2/Graphics/HGL/Draw/Text.hs0000644000514200001600000001626111274041443015453 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.Draw.Text -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : non-portable (requires concurrency) -- -- Drawing text. -- ----------------------------------------------------------------------------- module Graphics.HGL.Draw.Text ( -- * Drawing text text -- ToDo: add textInfo to Win32 #if !X_DISPLAY_MISSING , textInfo #endif -- * Color , RGB(RGB) , setTextColor -- :: RGB -> Draw RGB , setBkColor -- :: RGB -> Draw RGB , BkMode(Opaque, Transparent) , setBkMode -- :: BkMode -> Draw BkMode -- * Alignment , Alignment -- = (HAlign, VAlign) , HAlign(Left', Center, Right') , VAlign(Top, Baseline, Bottom) , setTextAlignment -- :: Alignment -> Draw Alignment ) where #if !X_DISPLAY_MISSING import qualified Graphics.X11.Xlib as X import Graphics.HGL.X11.Types import Control.Concurrent.MVar (readMVar, takeMVar, putMVar) #else import qualified Graphics.Win32 as Win32 import Graphics.HGL.Win32.Types import Data.Bits #endif import Graphics.HGL.Units (Point, Size) import Graphics.HGL.Draw.Monad (Graphic, Draw) import Graphics.HGL.Internals.Draw (mkDraw) import Graphics.HGL.Internals.Types (RGB(..), BkMode(..), Alignment, HAlign(..), VAlign(..)) ---------------------------------------------------------------- -- The Interface (SOE, p50) ---------------------------------------------------------------- -- | Render a 'String' positioned relative to the specified 'Point'. text :: Point -> String -> Graphic -- filled #if !X_DISPLAY_MISSING -- | @'textInfo' s@ returns: -- -- (1) The offset at which the string would be drawn according to the -- current text alignment (e.g., @('Center', 'Baseline')@ will result -- in an offset of (-width\/2,0)) -- -- (2) The size at which the text would be drawn using the current font. -- textInfo :: String -> Draw (Point,Size) #endif -- | Set the foreground color for drawing text, returning the previous value. setTextColor :: RGB -> Draw RGB -- | Set the background color for drawing text, returning the previous value. -- The background color is ignored when the mode is 'Transparent'. setBkColor :: RGB -> Draw RGB -- | Set the background mode for drawing text, returning the previous value. setBkMode :: BkMode -> Draw BkMode -- | Set the alignment for drawing text, returning the previous value. setTextAlignment :: Alignment -> Draw Alignment ---------------------------------------------------------------- -- The Implementation ---------------------------------------------------------------- #if !X_DISPLAY_MISSING text p s = mkDraw (\ dc -> do bs <- readMVar (ref_bits dc) let Font f = font bs (halign, valign) = textAlignment bs width = X.textWidth f s ascent = X.ascentFromFontStruct f descent = X.descentFromFontStruct f x' = case halign of Left' -> x Center -> x - width `div` 2 Right' -> x - width + 1 y' = case valign of Top -> y + ascent Baseline -> y Bottom -> y - descent + 1 draw (bkMode bs) (disp dc) (drawable dc) (textGC dc) x' y' s ) where X.Point x y = fromPoint p -- Win32's DeviceContext has a BkMode in it. In X, we call two different -- routines depending on what mode we want. draw Transparent = X.drawString draw Opaque = X.drawImageString textInfo s = mkDraw $ \ dc -> do bs <- readMVar (ref_bits dc) let Font f = font bs (halign, valign) = textAlignment bs width = X.textWidth f s ascent = X.ascentFromFontStruct f descent = X.descentFromFontStruct f x1 = case halign of Left' -> 0 Center -> - width `div` 2 Right' -> - width + 1 y1 = case valign of Top -> ascent Baseline -> 0 Bottom -> - descent + 1 x2 = x1 + width y2 = y1 + ascent + descent (x1',x2') = (min x1 x2, max x1 x2) (y1',y2') = (min y1 y2, max y1 y2) return (toPoint (X.Point x1 y1), toSize (fromIntegral (x2'-x1'), fromIntegral (y2'-y1'))) setTextColor x = mkDraw $ \ dc -> do bs <- takeMVar (ref_bits dc) putMVar (ref_bits dc) bs{textColor=x} p <- lookupColor (disp dc) x X.setForeground (disp dc) (textGC dc) p return (textColor bs) setBkColor x = mkDraw $ \ dc -> do bs <- takeMVar (ref_bits dc) putMVar (ref_bits dc) bs{bkColor=x} p <- lookupColor (disp dc) x X.setBackground (disp dc) (textGC dc) p return (bkColor bs) setBkMode x = mkDraw $ \ dc -> do bs <- takeMVar (ref_bits dc) putMVar (ref_bits dc) bs{bkMode=x} return (bkMode bs) setTextAlignment x = mkDraw $ \ dc -> do bs <- takeMVar (ref_bits dc) putMVar (ref_bits dc) bs{textAlignment=x} return (textAlignment bs) #else /* X_DISPLAY_MISSING */ type TextAlignment = Win32.TextAlignment fromAlignment :: Alignment -> TextAlignment fromAlignment (ha,va) = hAlign ha .|. vAlign va hAlign :: HAlign -> TextAlignment hAlign Left' = Win32.tA_LEFT hAlign Center = Win32.tA_CENTER hAlign Right' = Win32.tA_RIGHT vAlign :: VAlign -> TextAlignment vAlign Top = Win32.tA_TOP vAlign Baseline = Win32.tA_BASELINE vAlign Bottom = Win32.tA_BOTTOM toAlignment :: TextAlignment -> Alignment toAlignment x = (toHAlign (x .&. hmask), toVAlign (x .&. vmask)) toHAlign x | x == Win32.tA_LEFT = Left' | x == Win32.tA_CENTER = Center | x == Win32.tA_RIGHT = Right' | otherwise = Center -- safe(?) default toVAlign x | x == Win32.tA_TOP = Top | x == Win32.tA_BASELINE = Baseline | x == Win32.tA_BOTTOM = Bottom | otherwise = Baseline -- safe(?) default -- Win32 doesn't seem to provide the masks I need - these ought to work. hmask = Win32.tA_LEFT .|. Win32.tA_CENTER .|. Win32.tA_RIGHT vmask = Win32.tA_TOP .|. Win32.tA_BASELINE .|. Win32.tA_BOTTOM fromBkMode :: BkMode -> Win32.BackgroundMode fromBkMode Opaque = Win32.oPAQUE fromBkMode Transparent = Win32.tRANSPARENT toBkMode :: Win32.BackgroundMode -> BkMode toBkMode x | x == Win32.oPAQUE = Opaque | x == Win32.tRANSPARENT = Transparent -- ToDo: add an update mode for these constants -- (not required at the moment since we always specify exactly where -- the text is to go) -- tA_NOUPDATECP :: TextAlignment -- tA_UPDATECP :: TextAlignment text (x,y) s = mkDraw $ \ hdc -> Win32.textOut hdc (fromDimension x) (fromDimension y) s setTextColor c = mkDraw (\hdc -> do c' <- Win32.setTextColor hdc (fromRGB c) return (toRGB c')) setBkColor c = mkDraw (\hdc -> do c' <- Win32.setBkColor hdc (fromRGB c) return (toRGB c')) setBkMode m = mkDraw (\hdc -> do m' <- Win32.setBkMode hdc (fromBkMode m) return (toBkMode m')) setTextAlignment new_alignment = mkDraw (\hdc -> do old <- Win32.setTextAlign hdc (fromAlignment new_alignment) return (toAlignment old) ) #endif /* X_DISPLAY_MISSING */ ---------------------------------------------------------------- -- End ---------------------------------------------------------------- HGL-3.2.0.2/Graphics/HGL/Draw/Font.hs0000644000514200001600000001213111274041443015425 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.Draw.Font -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : non-portable (requires concurrency) -- -- Text fonts. -- -- Portability notes: -- -- * X11 does not directly support font rotation so 'createFont' and -- 'mkFont' always ignore the rotation angle argument in the X11 -- implementation of this library. -- -- * Many of the font families typically available on Win32 are not -- available on X11 (and /vice-versa/). In our experience, the font -- families /courier/, /helvetica/ and /times/ are somewhat portable. -- ----------------------------------------------------------------------------- module Graphics.HGL.Draw.Font ( Font , createFont , deleteFont , selectFont -- :: Font -> Draw Font , mkFont ) where #if !X_DISPLAY_MISSING import qualified Graphics.HGL.Internals.Utilities as Utils import Graphics.HGL.X11.Types (Font(Font), DC(..), DC_Bits(..)) import Graphics.HGL.X11.Display (getDisplay) import qualified Graphics.X11.Xlib as X import Control.Concurrent.MVar (takeMVar, putMVar) #else import Graphics.HGL.Win32.Types import qualified Graphics.Win32 as Win32 #endif import Graphics.HGL.Units (Size, Angle) import Graphics.HGL.Draw.Monad (Draw, bracket, ioToDraw) import Graphics.HGL.Internals.Draw (mkDraw) ---------------------------------------------------------------- -- Interface ---------------------------------------------------------------- #if X_DISPLAY_MISSING newtype Font = MkFont Win32.HFONT #endif -- | Create a font. -- The rotation angle is ignored if the font is not a \"TrueType\" font -- (e.g., a @System@ font on Win32). createFont :: Size -- ^ size of character glyphs in pixels -> Angle -- ^ rotation angle -> Bool -- ^ bold font? -> Bool -- ^ italic font? -> String -- ^ font family -> IO Font -- | Delete a font created with 'createFont'. deleteFont :: Font -> IO () -- | Set the font for subsequent text, and return the previous font. selectFont :: Font -> Draw Font -- | Generate a font for use in a drawing, and delete it afterwards. -- The rotation angle is ignored if the font is not a \"TrueType\" font -- (e.g., a @System@ font on Win32). mkFont :: Size -- ^ size of character glyphs in pixels -> Angle -- ^ rotation angle -> Bool -- ^ bold font? -> Bool -- ^ italic font? -> String -- ^ font family -> (Font -> Draw a) -> Draw a ---------------------------------------------------------------- -- Implementation ---------------------------------------------------------------- mkFont size angle bold italic family = bracket (ioToDraw $ createFont size angle bold italic family) (ioToDraw . deleteFont) #if !X_DISPLAY_MISSING createFont (width, height) escapement bold italic family = do display <- getDisplay -- print fontName r <- Utils.safeTry (X.loadQueryFont display fontName) case r of Left e -> ioError (userError $ "Unable to load font " ++ fontName) Right f -> return (Font f) where fontName = concatMap ('-':) fontParts fontParts = [ foundry , family , weight , slant , sWdth , adstyl , pxlsz , ptSz , resx , resy , spc , avgWidth , registry , encoding ] foundry = "*" -- eg "adobe" -- family = "*" -- eg "courier" weight = if bold then "bold" else "medium" slant = if italic then "i" else "r" sWdth = "normal" adstyl = "*" pxlsz = show height ptSz = "*" resx = "75" resy = "75" spc = "*" avgWidth = show (width*10) -- not sure what unit they use registry = "*" encoding = "*" deleteFont (Font f) = do display <- getDisplay X.freeFont display f selectFont f@(Font x) = mkDraw $ \ dc -> do bs <- takeMVar (ref_bits dc) putMVar (ref_bits dc) bs{font=f} X.setFont (disp dc) (textGC dc) (X.fontFromFontStruct x) return (font bs) #else /* X_DISPLAY_MISSING */ createFont (width, height) escapement bold italic family = Win32.createFont (fromDimension height) (fromDimension width) (round (escapement * 1800/pi)) 0 -- orientation weight italic False False -- italic, underline, strikeout Win32.aNSI_CHARSET Win32.oUT_DEFAULT_PRECIS Win32.cLIP_DEFAULT_PRECIS Win32.dEFAULT_QUALITY Win32.dEFAULT_PITCH family >>= return . MkFont where weight | bold = Win32.fW_BOLD | otherwise = Win32.fW_NORMAL deleteFont (MkFont f) = Win32.deleteFont f selectFont (MkFont f) = mkDraw (\hdc -> do f' <- Win32.selectFont hdc f return (MkFont f')) #endif /* X_DISPLAY_MISSING */ ---------------------------------------------------------------- -- End ---------------------------------------------------------------- HGL-3.2.0.2/Graphics/HGL/Draw/Picture.hs0000644000514200001600000001471411274041443016143 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.Draw.Picture -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : non-portable (requires concurrency) -- -- Drawing various shapes. -- ----------------------------------------------------------------------------- module Graphics.HGL.Draw.Picture ( arc, ellipse, shearEllipse , line, polyline, polygon , polyBezier -- becomes error message and polyline in X11 ) where #if !X_DISPLAY_MISSING import Graphics.HGL.X11.Types import qualified Graphics.X11.Xlib as X import System.IO.Unsafe(unsafePerformIO) import System.IO(stderr, hPutStrLn) #else import Graphics.HGL.Win32.Types import qualified Graphics.Win32 as Win32 #endif import Graphics.HGL.Draw.Monad(Graphic) import Graphics.HGL.Internals.Draw(mkDraw) import Graphics.HGL.Units ---------------------------------------------------------------- -- The Interface (SOE, p50) ---------------------------------------------------------------- -- | A filled arc from an ellipse. arc :: Point -- ^ a corner of the rectangle bounding the ellipse. -> Point -- ^ the opposite corner of the rectangle bounding the ellipse. -> Angle -- ^ the start angle of the arc, measured counter-clockwise -- from the horizontal. -> Angle -- ^ the extent of the arc, measured counter-clockwise from -- the start angle. -> Graphic -- ^ a filled shape -- | A filled ellipse that fits inside a rectangle defined by two -- 'Point's on the window. ellipse :: Point -- ^ a corner of the rectangle bounding the ellipse. -> Point -- ^ the opposite corner of the rectangle bounding the ellipse. -> Graphic -- ^ a filled shape -- | A filled sheared ellipse that fits inside a parallelogram defined -- by three 'Point's on the window. This function is implemented using -- polygons on both Win32 and X11. shearEllipse :: Point -- ^ a corner of the bounding parallelogram. -> Point -- ^ another corner of the parallelogram, adjacent to the first. -> Point -- ^ another corner of the parallelogram, adjacent to the first -- and thus opposite to the second. -> Graphic -- ^ a filled shape -- | A filled polygon defined by a list of 'Point's. polygon :: [Point] -> Graphic -- filled -- | A line between two 'Point's. line :: Point -> Point -> Graphic -- unfilled -- | A series of lines through a list of 'Point's. polyline :: [Point] -> Graphic -- unfilled -- | A series of (unfilled) Bezier curves defined by a list of 3/n/+1 -- control 'Point's. This function is not supported on X11 (it yields -- an error message and a 'polyline'). polyBezier :: [Point] -> Graphic -- unfilled ---------------------------------------------------------------- -- The Implementation ---------------------------------------------------------------- #if !X_DISPLAY_MISSING arc (x0,y0) (x1,y1) s e = mkDraw (\ dc -> X.fillArc (disp dc) (drawable dc) (paintGC dc) x' y' w' h' s' e') where (x,w) = minAndDelta x0 x1 (y,h) = minAndDelta y0 y1 x' = fromIntegral x y' = fromIntegral y w' = fromIntegral w h' = fromIntegral h s' = round (s * 64) e' = round (e * 64) ellipse (x0,y0) (x1,y1) = mkDraw (\ dc -> X.fillArc (disp dc) (drawable dc) (brushGC dc) x' y' w' h' 0 threeSixty) where (x,w) = minAndDelta x0 x1 (y,h) = minAndDelta y0 y1 x' = fromIntegral x y' = fromIntegral y w' = fromIntegral w h' = fromIntegral h -- X measures angles in 64ths of a degree threeSixty :: X.Angle threeSixty = 360*64 shearEllipse p0 p1 p2 = mkDraw (\ dc -> X.fillPolygon (disp dc) (drawable dc) (brushGC dc) pts X.convex X.coordModeOrigin) where X.Point x0 y0 = fromPoint p0 X.Point x1 y1 = fromPoint p1 X.Point x2 y2 = fromPoint p2 x = avg x1 x2 -- centre of parallelogram y = avg y1 y2 dx1 = fromIntegral ((x1 - x0) `div` 2) -- distance to corners from centre dy1 = fromIntegral ((y1 - y0) `div` 2) dx2 = fromIntegral ((x2 - x0) `div` 2) dy2 = fromIntegral ((y2 - y0) `div` 2) pts = [ X.Point (x + round(c*dx1 + s*dx2)) (y + round(c*dy1 + s*dy2)) | (c,s) <- cos'n'sins ] cos'n'sins :: [(Double,Double)] cos'n'sins = [ (cos a, sin a) | a <- angles ] angles :: [Angle] angles = take 40 [0, pi/20 .. ] line p0 p1 = mkDraw (\ dc -> X.drawLine (disp dc) (drawable dc) (paintGC dc) x0 y0 x1 y1) where X.Point x0 y0 = fromPoint p0 X.Point x1 y1 = fromPoint p1 polyline pts = mkDraw (\ dc -> X.drawLines (disp dc) (drawable dc) (paintGC dc) (map fromPoint pts) X.coordModeOrigin) polygon pts = mkDraw (\ dc -> X.fillPolygon (disp dc) (drawable dc) (brushGC dc) (map fromPoint pts) X.complex X.coordModeOrigin) polyBezier = unsafePerformIO $ do hPutStrLn stderr "warning: polyBezier is unavailable in X11 -- using polyline instead" return polyline ---------------------------------------------------------------- -- Utilities ---------------------------------------------------------------- -- delta is always +ve minAndDelta :: Int -> Int -> (Int,Int) minAndDelta a b | a <= b = (a, b-a) | otherwise = (b, a-b) -- avg :: Int32 -> Int32 -> Int32 avg :: Integral a => a -> a -> a avg a b = (a + b) `div` 2 #else /* X_DISPLAY_MISSING */ arc p0 p1 start end = mkDraw (\ hdc -> Win32.arc hdc x0 y0 x1 y1 xs ys xe ye) where (x0,y0) = fromPoint p0 (x1,y1) = fromPoint p1 x = (x0 + x1) `div` 2 y = (y0 + y1) `div` 2 start' = 2 * pi * start / 360 end' = 2 * pi * end / 360 xs = x + round (100 * cos start') ys = y + round (100 * sin start') xe = x + round (100 * cos end') ye = y + round (100 * sin end') ellipse p0 p1 = mkDraw (\ hdc -> Win32.ellipse hdc x0 y0 x1 y1) where (x0,y0) = fromPoint p0 (x1,y1) = fromPoint p1 shearEllipse p0 p1 p2 = mkDraw (\ hdc -> Win32.transformedEllipse hdc (fromPoint p0) (fromPoint p1) (fromPoint p2)) line p0 p1 = mkDraw (\ hdc -> Win32.moveToEx hdc x0 y0 >> Win32.lineTo hdc x1 y1) where (x0,y0) = fromPoint p0 (x1,y1) = fromPoint p1 polyline pts = mkDraw (\ hdc -> Win32.polyline hdc (map fromPoint pts)) polygon pts = mkDraw (\ hdc -> Win32.polygon hdc (map fromPoint pts)) polyBezier pts = mkDraw (\ hdc -> Win32.polyBezier hdc (map fromPoint pts)) #endif /* X_DISPLAY_MISSING */ ---------------------------------------------------------------- -- End ---------------------------------------------------------------- HGL-3.2.0.2/Graphics/HGL/Win32/0000755000514200001600000000000011274041443014172 5ustar cxltomcatHGL-3.2.0.2/Graphics/HGL/Win32/WND.hs0000644000514200001600000002405311274041443015162 0ustar cxltomcat-- #hide module Graphics.HGL.Win32.WND ( WND, mkWND, openWND, closeWND, redrawWND , handleEvents, closeAllHWNDs , beginGraphics, endGraphics , wndRect , getHWND , drawWND ) where import Graphics.HGL.Units (Point) import Graphics.HGL.Internals.Event( Event(..) ) import Graphics.HGL.Internals.Draw (Draw, unDraw) import Graphics.HGL.Internals.Events( Events, sendEvent, sendTick ) import Graphics.HGL.Internals.Utilities(safeTry, Exception) import Graphics.HGL.Win32.Draw( DrawFun, setDefaults, withDC ) import Graphics.HGL.Win32.Types( Key(MkKey), toPoint ) import Control.Concurrent( yield ) import Control.Monad(liftM2,when) import Data.Bits import Data.IORef import Data.Maybe(isJust) import System.IO.Unsafe(unsafePerformIO) import Graphics.Win32 import System.Win32 (getModuleHandle) ---------------------------------------------------------------- -- Once a window has been closed, we want to detect any further -- operations on the window - so all access is via a mutable Maybe ---------------------------------------------------------------- newtype WND = MkWND (IORef (Maybe HWND)) closeWND :: WND -> IO () closeWND wnd@(MkWND hwndref) = do mb_hwnd <- readIORef hwndref writeIORef hwndref Nothing -- mark it as closed case mb_hwnd of Just hwnd -> do removeHWND hwnd -- added by Ulf Norell yield -- added by Ulf destroyWindow hwnd Nothing -> return () getHWND :: WND -> IO HWND getHWND (MkWND hwndref) = do mb_hwnd <- readIORef hwndref case mb_hwnd of Just hwnd -> return hwnd Nothing -> ioError (userError "Attempted to act on closed window") redrawWND :: WND -> IO () redrawWND wnd = do hwnd <- getHWND wnd invalidateRect (Just hwnd) Nothing False drawWND :: WND -> Draw () -> IO () drawWND wnd p = do hwnd <- getHWND wnd withDC (Just hwnd) (\ hdc -> setDefaults hdc >> unDraw p hdc) wndRect :: WND -> IO (Point, Point) wndRect wnd = do hwnd <- getHWND wnd (l,t,r,b) <- getClientRect hwnd return (toPoint (l,t), toPoint (r,b)) mkWND :: HWND -> IO WND mkWND hwnd = fmap MkWND (newIORef (Just hwnd)) openWND :: String -> Maybe POINT -> Maybe POINT -> Events -- where to send the events -> DrawFun -- how to redraw the picture -> Maybe MilliSeconds -- time between timer ticks -> IO WND openWND name pos size events draw tickRate = do checkInitialised clAss <- newClass hwnd <- createWND name wndProc pos size wS_OVERLAPPEDWINDOW Nothing show hwnd False updateWindow hwnd maybe (return ()) (\ rate -> setWinTimer hwnd 1 rate >> return ()) tickRate fmap MkWND (newIORef (Just hwnd)) where wndProc hwnd msg wParam lParam = do -- print msg rs <- safeTry $ do r <- windowProc (sendEvent events) draw (\ wParam -> sendTick events) hwnd msg wParam lParam r `seq` return r -- force it inside the try! case rs of Right a -> return a Left e -> uncaughtError e >> return 0 -- Let's hope this works ok show hwnd iconified = if iconified then do showWindow hwnd sW_SHOWNORMAL -- open "iconified" return () else do showWindow hwnd sW_RESTORE -- open "restored" (ie normal size) bringWindowToTop hwnd -- Note that this code uses a single (static) MSG throughout the whole -- system - let's hope this isn't a problem handleEvents :: IO Bool -> IO () handleEvents userQuit = do -- first wait for a window to be created or for the user prog to quit -- this avoids the race condition that we might quit (for lack of -- any windows) before the user's thread has even had a chance to run. safeTry $ while (fmap not (liftM2 (||) userQuit (fmap not noMoreWindows))) yield -- Ulf uses this instead of handleEvent -- then wait for all windows to be shut down or user to quit safeTry $ while (fmap not (liftM2 (||) userQuit systemQuit)) handleEvent return () where while p s = do { c <- p; if c then s >> while p s else return () } handleEvent :: IO () handleEvent = do yield -- always yield before any blocking operation nowin <- noMoreWindows when (not nowin) $ allocaMessage $ \ lpmsg -> do getMessage lpmsg Nothing translateMessage lpmsg dispatchMessage lpmsg return () ---------------------------------------------------------------- -- The grotty details - opening WNDs, creating classes, etc ---------------------------------------------------------------- className = mkClassName "Graphics.HGL.Win32.WND" newClass :: IO ATOM newClass = do icon <- loadIcon Nothing iDI_APPLICATION cursor <- loadCursor Nothing iDC_ARROW whiteBrush <- getStockBrush wHITE_BRUSH mainInstance <- getModuleHandle Nothing atom <- registerClass ( (cS_HREDRAW .|. cS_VREDRAW), -- redraw if window size Changes mainInstance, (Just icon), (Just cursor), (Just whiteBrush), Nothing, className) --return atom return (maybe undefined id atom) createWND :: String -> WindowClosure -> Maybe POINT -> Maybe POINT -> WindowStyle -> Maybe HMENU -> IO HWND createWND name wndProc posn size style menu = do mainInstance <- getModuleHandle Nothing mbSize <- calcSize size hwnd <- createWindowEx 0 -- Win32.wS_EX_TOPMOST className name style (fmap (fromIntegral.fst) posn) -- x (fmap (fromIntegral.snd) posn) -- y (fmap (fromIntegral.fst) mbSize) -- w (fmap (fromIntegral.snd) mbSize) -- h Nothing -- parent menu mainInstance wndProc addHWND hwnd return hwnd where calcSize :: Maybe POINT -> IO (Maybe POINT) calcSize = maybe (return Nothing) (\ (width, height) -> do (l,t,r,b) <- adjustWindowRect (0,0,width,height) style (isJust menu) return $ Just (r-l, b-t)) windowProc :: (Event -> IO ()) -> -- Event Handler DrawFun -> -- Picture redraw (WPARAM -> IO ()) -> -- tick (HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT) windowProc send redraw tick hwnd msg wParam lParam | msg == wM_PAINT = paint | msg == wM_MOUSEMOVE = mouseMove lParam | msg == wM_LBUTTONDOWN || msg == wM_LBUTTONDBLCLK = button lParam True True | msg == wM_LBUTTONUP = button lParam True False | msg == wM_RBUTTONDOWN || msg == wM_RBUTTONDBLCLK = button lParam False True | msg == wM_RBUTTONUP = button lParam False False | msg == wM_KEYDOWN = key wParam True | msg == wM_KEYUP = key wParam False | msg == wM_CHAR = char wParam | msg == wM_TIMER = timer wParam | msg == wM_SIZE = resize {- | msg == wM_MOUSEACTIVATE = do hwnd' <- setFocus hwnd if hwnd `eqHWND` hwnd' then return mA_NOACTIVATE -- already had input focus else return mA_ACTIVATEANDEAT -} | msg == wM_DESTROY = destroy | otherwise = defWindowProc (Just hwnd) msg wParam lParam where paint :: IO LRESULT paint = paintWith hwnd (\hdc lpps -> do redraw hwnd hdc return 0 ) button :: LPARAM -> Bool -> Bool -> IO LRESULT button lParam isLeft isDown = do let (y,x) = lParam `divMod` 65536 send (Button {pt = toPoint (x,y), isLeft=isLeft, isDown=isDown}) return 0 key :: WPARAM -> Bool -> IO LRESULT key wParam isDown = do send (Key { keysym = MkKey wParam, isDown = isDown }) -- by returning 1 we let it get translated into a char too return 1 char :: WPARAM -> IO LRESULT char wParam = do send (Char { char = toEnum (fromIntegral wParam) }) return 0 mouseMove :: LPARAM -> IO LRESULT mouseMove lParam = do let (y,x) = lParam `divMod` 65536 send (MouseMove { pt = toPoint (x,y) }) return 0 timer :: WPARAM -> IO LRESULT timer wParam = do tick wParam return 0 resize :: IO LRESULT resize = do -- don't send new size, it may be out of date by the time we -- get round to reading the event send Resize return 0 destroy :: IO LRESULT destroy = do removeHWND hwnd send Closed return 0 paintWith :: HWND -> (HDC -> LPPAINTSTRUCT -> IO a) -> IO a paintWith hwnd p = allocaPAINTSTRUCT $ \ lpps -> do hdc <- beginPaint hwnd lpps a <- p hdc lpps endPaint hwnd lpps return a ---------------------------------------------------------------- -- The open window list ---------------------------------------------------------------- -- It's very important that we close any windows - even if the -- Haskell application fails to do so (or aborts for some reason). -- Therefore we keep a list of open windows and close them all at the -- end. -- persistent list of open windows windows :: IORef [HWND] windows = unsafePerformIO (newIORef []) initialised :: IORef Bool initialised = unsafePerformIO (newIORef False) noMoreWindows :: IO Bool noMoreWindows = fmap null (readIORef windows) -- It's also important that we abort cleanly if an uncaught IOError -- occurs - this flag keeps track of such things hadUncaughtError :: IORef Bool hadUncaughtError = unsafePerformIO (newIORef False) -- We call this if an uncaught error has occured uncaughtError :: Exception -> IO () uncaughtError e = do putStr "Uncaught Error: " print e writeIORef hadUncaughtError True systemQuit :: IO Bool systemQuit = liftM2 (||) (readIORef hadUncaughtError) noMoreWindows beginGraphics :: IO () beginGraphics = do closeAllHWNDs -- just in case any are already open! writeIORef initialised True checkInitialised :: IO () checkInitialised = do init <- readIORef initialised if init then return () else ioError (userError msg) where msg = "Graphics library uninitialised: perhaps you forgot to use runGraphics?" endGraphics :: IO () endGraphics = do closeAllHWNDs writeIORef initialised False closeAllHWNDs :: IO () closeAllHWNDs = do hwnds <- readIORef windows mapM_ destroyWindow hwnds writeIORef windows [] writeIORef hadUncaughtError False -- clear the system addHWND :: HWND -> IO () addHWND hwnd = do hwnds <- readIORef windows writeIORef windows (hwnd:hwnds) -- remove a HWND from windows list removeHWND :: HWND -> IO () removeHWND hwnd = do hwnds <- readIORef windows writeIORef windows (filter (/= hwnd) hwnds) HGL-3.2.0.2/Graphics/HGL/Win32/Draw.hs0000644000514200001600000001257311274041443015433 0ustar cxltomcat-- #hide module Graphics.HGL.Win32.Draw ( DrawFun, drawGraphic, drawBufferedGraphic, drawBufferedGraphicBC , saveGraphic , withBitmap , setDefaults , createCompatibleBitmap, withCompatibleBitmap, withCompatibleDC, withDC , createBitmapFile ) where import Graphics.HGL.Units import Graphics.HGL.Internals.Draw import Graphics.HGL.Win32.Types import qualified Graphics.HGL.Internals.Utilities as Utils import qualified Graphics.Win32 as Win32 import Data.Int type DrawFun = Win32.HWND -> Win32.HDC -> IO () drawGraphic :: Draw () -> DrawFun drawBufferedGraphic :: Draw () -> DrawFun drawBufferedGraphicBC :: Win32.COLORREF -> Draw () -> DrawFun saveGraphic :: String -> Point -> Draw () -> IO () createBitmapFile :: Win32.HDC -> String -> Bitmap -> IO () createCompatibleDC :: Win32.HDC -> IO Win32.HDC deleteDC :: Win32.HDC -> IO () createCompatibleBitmap :: Win32.HDC -> Int32 -> Int32 -> IO Bitmap withCompatibleDC :: Win32.HDC -> (Win32.HDC -> IO a) -> IO a withBitmap :: Win32.HDC -> Bitmap -> IO a -> IO a withDC :: Maybe Win32.HWND -> (Win32.HDC -> IO a) -> IO a withCompatibleBitmap :: Win32.HDC -> Int32 -> Int32 -> (Bitmap -> IO a) -> IO a ---------------------------------------------------------------- drawGraphic p = \ hwnd hdc -> do (w,h) <- windowSize hwnd Win32.bitBlt hdc 0 0 w h hdc 0 0 backgroundColor setDefaults hdc unDraw p hdc drawBufferedGraphic = drawBufferedGraphicBC backgroundColor drawBufferedGraphicBC bgColor p = \ hwnd hdc -> do (w,h) <- windowSize hwnd withBuffer (Just hwnd) w h bgColor $ \ buffer _ -> do setDefaults buffer unDraw p buffer Win32.bitBlt hdc 0 0 w h buffer 0 0 Win32.sRCCOPY saveGraphic fileName size p = withBuffer Nothing w h backgroundColor $ \ buffer bmp -> do setDefaults buffer unDraw p buffer createBitmapFile buffer fileName bmp where (w,h) = fromPoint size backgroundColor = Win32.bLACKNESS setDefaults :: Win32.HDC -> IO () setDefaults hdc = do setDefaultPen hdc setDefaultBrush hdc setDefaultText hdc return () setDefaultPen :: Win32.HDC -> IO () setDefaultPen = \ hdc -> do whitePen <- Win32.getStockPen Win32.wHITE_PEN Win32.selectPen hdc whitePen return () setDefaultBrush :: Win32.HDC -> IO () setDefaultBrush = \ hdc -> do whiteBrush <- Win32.getStockBrush Win32.wHITE_BRUSH Win32.selectBrush hdc whiteBrush return () setDefaultText :: Win32.HDC -> IO () setDefaultText = \ hdc -> do Win32.setTextColor hdc white -- We omit this because it should be redundant (since mode is transparent) -- And because it causes some examples to crash. -- Maybe you're not allowed to set a color if the mode is transparent? -- Win32.setBkColor hdc black Win32.setBkMode hdc Win32.tRANSPARENT return () white :: Win32.COLORREF white = Win32.rgb 255 255 255 black :: Win32.COLORREF black = Win32.rgb 0 0 0 ---------------------------------------------------------------- -- Note that we create a bitmap which is compatible with the hdc -- onto which we are going to zap the Graphic. It might seem that -- it would be enough for it to be compatible with the buffer - -- but, sadly, this isn't the case. The problem is that the buffer -- is initially 0 pixels wide, 0 pixels high and 1 bit deep -- (ie it looks monochrome); it only becomes n-bits deep when you -- select in a bitmap which is n-bits deep. -- -- If it wasn't for that, we'd have swapped these two lines: -- -- withCompatibleBitmap w h $ \ bitmap -> -- withCompatibleDC $ \ hdc -> -- withBuffer :: Maybe Win32.HWND -> Int32 -> Int32 -> Win32.COLORREF -> (Win32.HDC -> Bitmap -> IO a) -> IO a withBuffer mbhwnd w h bgColor p = withDC mbhwnd $ \ hdc -> withCompatibleBitmap hdc w h $ \ bitmap -> withCompatibleDC hdc $ \ buffer -> withBitmap buffer bitmap $ do Win32.bitBlt buffer 0 0 w h buffer 0 0 bgColor p buffer bitmap ---------------------------------------------------------------- -- Get the width and height of a window's client area, in pixels. windowSize :: Win32.HWND -> IO (Win32.LONG,Win32.LONG) windowSize hwnd = Win32.getClientRect hwnd >>= \ (l',t',r',b') -> return (r' - l', b' - t') -- Note that this DC is only "1 bit" in size - you have to call -- "createCompatibleBitmap" before it is big enough to hold the bitmap -- you want. createCompatibleDC hdc = Win32.createCompatibleDC (Just hdc) deleteDC = Win32.deleteDC createCompatibleBitmap hdc w h = do bmp <- Win32.createCompatibleBitmap hdc w h return (MkBitmap bmp) withBitmap hdc bmp = Utils.bracket_ (selectBitmap hdc bmp) (selectBitmap hdc) withDC mhwnd = Utils.bracket (Win32.getDC mhwnd) (Win32.releaseDC mhwnd) -- Note that this DC is only "1 bit" in size - you have to call -- "createCompatibleBitmap" before it is big enough to hold the bitmap -- you want. withCompatibleDC hdc = Utils.bracket (createCompatibleDC hdc) deleteDC withCompatibleBitmap hdc w h = Utils.bracket (createCompatibleBitmap hdc w h) deleteBitmap deleteBitmap (MkBitmap bmp) = Win32.deleteBitmap bmp selectBitmap hdc (MkBitmap bmp) = do bmp' <- Win32.selectBitmap hdc bmp return (MkBitmap bmp) createBitmapFile hdc fileName (MkBitmap bmp) = Win32.createBMPFile fileName bmp hdc ---------------------------------------------------------------- -- End ---------------------------------------------------------------- HGL-3.2.0.2/Graphics/HGL/Win32/Bitmap.hs0000644000514200001600000001316711274041443015752 0ustar cxltomcat-- #hide module Graphics.HGL.Win32.Bitmap ( Bitmap , load, read, delete , draw, drawStretched, drawSheared , getBitmapSize , createBitmapFile ) where import Graphics.HGL.Units (Point) import Graphics.HGL.Internals.Draw (Draw, mkDraw) import Graphics.HGL.Win32.Draw import Graphics.HGL.Win32.Types import qualified Graphics.HGL.Internals.Utilities as Utils import qualified Graphics.Win32 as Win32 import qualified System.Win32 as Win32 import Foreign ---------------------------------------------------------------- -- The interface ---------------------------------------------------------------- load :: String -> IO (Bitmap, (Int, Int)) delete :: Bitmap -> IO () getBitmapSize :: Bitmap -> IO (Int, Int) -- Bitmaps can be drawn in three ways: -- a) with no transformation at a point -- b) stretched to fit a rectangle -- c) rotated and sheared to fit a parallelogram -- -- Sadly, the latter isn't supported in Win'95 draw :: Point -> Bitmap -> Draw () drawStretched :: Point -> Point -> Bitmap -> Draw () drawSheared :: Point -> Point -> Point -> Bitmap -> Draw () ---------------------------------------------------------------- -- The implementation ---------------------------------------------------------------- delete (MkBitmap bitmap) = Win32.deleteBitmap bitmap load fileName = do --putStrLn ("<>") bmp <- readBitmap fileName sz <- getBitmapSize bmp return (bmp, sz) getBitmapSize (MkBitmap bmp) = do (ty, w, h, wBytes, planes, bitsPixel, bits) <- Win32.getBitmapInfo bmp return (fromIntegral w, fromIntegral h) draw pt bmp = mkDraw (\ hdc -> withCompatibleDC hdc $ \ memdc -> withBitmap memdc bmp $ do (width,height) <- getBitmapSize bmp Win32.bitBlt hdc x y (fromIntegral width) (fromIntegral height) memdc 0 0 Win32.sRCCOPY) where (x,y) = fromPoint pt drawStretched p0 p1 bmp = mkDraw (\hdc -> withCompatibleDC hdc $ \ memdc -> withBitmap memdc bmp $ do (width,height) <- getBitmapSize bmp Win32.stretchBlt hdc x0 y1 (x1-x0) (y0-y1) memdc 0 0 (fromIntegral width) (fromIntegral height) Win32.sRCCOPY) where (x0,y0) = fromPoint p0 (x1,y1) = fromPoint p1 drawSheared p0 p1 p2 bmp = mkDraw (\hdc -> withCompatibleDC hdc $ \ memdc -> withBitmap memdc bmp $ do (width,height) <- getBitmapSize bmp Win32.plgBlt hdc (fromPoint p0) (fromPoint p1) (fromPoint p2) memdc 0 0 (fromIntegral width) (fromIntegral height) Nothing 0 0) ---------------------------------------------------------------- -- Reading bitmaps from files ---------------------------------------------------------------- -- ToDo: the "bits" read are never freed but I think we can free them -- as soon as we call createDIBitmap. -- Summary of the Win32 documentation on BMP files: -- -- A bitmap file consists of: -- -- +-------------------+ -- | BITMAPFILEHEADER | -- +-------------------+ -- | BITMAPINFOHEADER | -- +-------------------+ -- | Rgbquad array | -- +-------------------+ -- | Color-index array | -- +-------------------+ -- -- The file header tells you the size of the file and the offset of the -- bitmap data from the header start. -- -- The info header specifies the width and height, the colour format, -- compression mode, number of bytes of data, resolution and the number -- of colours. -- -- The RGBQUAD array is a palette. -- -- The Color-index array is the actual bitmap. readBitmap fileName = Utils.bracket (Win32.createFile fileName Win32.gENERIC_READ Win32.fILE_SHARE_READ Nothing Win32.oPEN_EXISTING Win32.fILE_ATTRIBUTE_NORMAL Nothing) Win32.closeHandle $ \ file -> do (offset, size) <- readFileHeader file (infoHeader,bmi,bits) <- readBits file offset size hdc <- Win32.getDC Nothing -- hdc for the screen bmp <- Win32.createDIBitmap hdc infoHeader Win32.cBM_INIT bits bmi Win32.dIB_RGB_COLORS return (MkBitmap bmp) readFileHeader :: Win32.HANDLE -> IO (Word32, Word32) readFileHeader file = -- read the file header allocaBytes (fromIntegral Win32.sizeofLPBITMAPFILEHEADER) $ \ fileHeader -> do read <- Win32.win32_ReadFile file fileHeader Win32.sizeofLPBITMAPFILEHEADER Nothing assert (read == Win32.sizeofLPBITMAPFILEHEADER) "Bitmap file lacks header" -- check the tag and get the size (tag, size, r1, r2, offset) <- Win32.getBITMAPFILEHEADER fileHeader assert (tag == fromIntegral (fromEnum 'B' + 256 * fromEnum 'M')) "Bitmap file lacks tag" assert (r1 == 0 && r2 == 0) "Bitmap header contains non-zero reserved words" return ( offset - Win32.sizeofLPBITMAPFILEHEADER , size - Win32.sizeofLPBITMAPFILEHEADER ) -- read the bits out of the rest of the file -- assumes that you've just read the file header readBits :: Win32.HANDLE -> Word32 -> Word32 -> IO (Win32.LPBITMAPINFOHEADER, Win32.LPBITMAPINFO, Win32.LPVOID) readBits file offset size = do header <- mallocBytes (fromIntegral size) read <- Win32.win32_ReadFile file header size Nothing assert (read == size) "Bitmap file ended unexpectedly" return ( castPtr header , header , castPtr header `plusPtr` fromIntegral offset ) -- In the development system, this might print the error message -- if the assertion fails. assert :: Bool -> String -> IO () assert _ _ = return () {- assert True _ = return () assert False why = do putStrLn "Assertion failed:" putStrLn why return () -} ---------------------------------------------------------------- -- End ---------------------------------------------------------------- HGL-3.2.0.2/Graphics/HGL/Win32/Types.hs0000644000514200001600000000355111274041443015636 0ustar cxltomcat-- #hide module Graphics.HGL.Win32.Types ( toDimension, fromDimension , toPoint, fromPoint , toRGB, fromRGB , Bitmap(..) , DC , Key(MkKey) ) where import qualified Graphics.Win32 as Win32 import Graphics.HGL.Internals.Types -- Hugs does not allow operators to have different fixities in -- different modules (this is a known deviation from Standard Haskell). -- In consequence, we don't declare any fixities in any non-standard -- library because it would prevent the programmer from using the same -- operator name at a different fixity. -- -- infixr 9 `over` ---------------------------------------------------------------- -- Units ---------------------------------------------------------------- -- These functions are used when implementing Graphic values toPoint :: Win32.POINT -> Point fromPoint :: Point -> Win32.POINT toDimension :: Win32.INT -> Dimension fromDimension :: Dimension -> Win32.INT toPoint (x,y) = (toDimension x, toDimension y) fromPoint (x,y) = (fromDimension x, fromDimension y) toDimension = fromIntegral fromDimension = fromIntegral --------------------------------------------------------------- -- Colors ---------------------------------------------------------------- fromRGB :: RGB -> Win32.COLORREF fromRGB (RGB r g b) = Win32.rgb r g b toRGB :: Win32.COLORREF -> RGB toRGB c = RGB (Win32.getRValue c) (Win32.getGValue c) (Win32.getBValue c) ---------------------------------------------------------------- -- Bitmaps ---------------------------------------------------------------- newtype Bitmap = MkBitmap Win32.HBITMAP ---------------------------------------------------------------- -- Drawing Context ---------------------------------------------------------------- type DC = Win32.HDC newtype Key = MkKey Win32.VKey deriving Show ---------------------------------------------------------------- HGL-3.2.0.2/Graphics/HGL/Key.hs0000644000514200001600000002051411274041443014356 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.Key -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : portable -- -- Abstract representation of keys. -- ----------------------------------------------------------------------------- module Graphics.HGL.Key ( Key -- Abstract! , keyToChar -- :: Key -> Char , isCharKey -- :: Key -> Bool , isBackSpaceKey -- :: Key -> Bool , isTabKey -- :: Key -> Bool -- , isLineFeedKey -- :: Key -> Bool , isClearKey -- :: Key -> Bool , isReturnKey -- :: Key -> Bool , isEscapeKey -- :: Key -> Bool , isDeleteKey -- :: Key -> Bool -- , isMultiKeyKey -- :: Key -> Bool , isHomeKey -- :: Key -> Bool , isLeftKey -- :: Key -> Bool , isUpKey -- :: Key -> Bool , isRightKey -- :: Key -> Bool , isDownKey -- :: Key -> Bool , isPriorKey -- :: Key -> Bool , isPageUpKey -- :: Key -> Bool , isNextKey -- :: Key -> Bool , isPageDownKey -- :: Key -> Bool , isEndKey -- :: Key -> Bool -- , isBeginKey -- :: Key -> Bool , isShiftLKey -- :: Key -> Bool , isShiftRKey -- :: Key -> Bool , isControlLKey -- :: Key -> Bool , isControlRKey -- :: Key -> Bool -- , isCapsLockKey -- :: Key -> Bool -- , isShiftLockKey -- :: Key -> Bool -- , isMetaLKey -- :: Key -> Bool -- , isMetaRKey -- :: Key -> Bool -- , isAltLKey -- :: Key -> Bool -- , isAltRKey -- :: Key -> Bool ) where import Data.Maybe (isJust) #if !X_DISPLAY_MISSING import Graphics.HGL.X11.Types(Key(MkKey)) import Graphics.X11.Xlib #else import Graphics.HGL.Win32.Types(Key(MkKey)) import Graphics.Win32 #endif ---------------------------------------------------------------- -- Interface ---------------------------------------------------------------- -- | Converts a character key to a character. keyToChar :: Key -> Char isCharKey :: Key -> Bool -- Is it a "real" character? isBackSpaceKey :: Key -> Bool isTabKey :: Key -> Bool --isLineFeedKey :: Key -> Bool isClearKey :: Key -> Bool isReturnKey :: Key -> Bool isEscapeKey :: Key -> Bool isDeleteKey :: Key -> Bool --isMultiKeyKey :: Key -> Bool -- Multi-key character compose. isHomeKey :: Key -> Bool -- Cursor home. isLeftKey :: Key -> Bool -- Cursor left, left arrow. isUpKey :: Key -> Bool -- Cursor up, up arrow. isRightKey :: Key -> Bool -- Cursor right, right arrow. isDownKey :: Key -> Bool -- Cursor down, down arrow. isPriorKey :: Key -> Bool -- Prior, previous page. Same as page up. isPageUpKey :: Key -> Bool -- Page up, previous page. Same as prior. isNextKey :: Key -> Bool -- Next, next page. Same as page down. isPageDownKey :: Key -> Bool -- Page down, next page. Same as next. isEndKey :: Key -> Bool -- End of line. --isBeginKey :: Key -> Bool -- Beginning of line. isShiftLKey :: Key -> Bool -- Left shift. isShiftRKey :: Key -> Bool -- Right shift. isControlLKey :: Key -> Bool -- Left control. isControlRKey :: Key -> Bool -- Right control. --isCapsLockKey :: Key -> Bool -- Caps lock. --isShiftLockKey :: Key -> Bool -- Shift lock. --isMetaLKey :: Key -> Bool -- Left meta. --isMetaRKey :: Key -> Bool -- Right meta. --isAltLKey :: Key -> Bool -- Left alt. --isAltRKey :: Key -> Bool -- Right alt. ---------------------------------------------------------------- -- Implementation ---------------------------------------------------------------- keyToChar (MkKey ks) = case (keySymToChar ks) of Just c -> c Nothing -> error "keyToChar: Not a character key!" isCharKey (MkKey ks) = isJust (keySymToChar ks) #if !X_DISPLAY_MISSING -- Converts an X KeySym representing an ISO 8859-1 (Latin 1) character or one -- of a few control characters to a Char. -- Note! It is assumed that the KeySym encoding for Latin 1 characters agrees -- with the Haskell character encoding! keySymToChar :: KeySym -> Maybe Char keySymToChar ks | xK_space <= ks && ks <= xK_ydiaeresis = Just (toEnum (fromIntegral ks)) | ks == xK_BackSpace = Just '\BS' | ks == xK_Tab = Just '\HT' | ks == xK_Linefeed = Just '\LF' | ks == xK_Clear = Just '\FF' | ks == xK_Return = Just '\CR' | ks == xK_Escape = Just '\ESC' | ks == xK_Delete = Just '\DEL' | otherwise = Nothing isBackSpaceKey (MkKey ks) = ks == xK_BackSpace isTabKey (MkKey ks) = ks == xK_Tab --isLineFeedKey (MkKey ks) = ks == xK_Linefeed isClearKey (MkKey ks) = ks == xK_Clear isReturnKey (MkKey ks) = ks == xK_Return isEscapeKey (MkKey ks) = ks == xK_Escape isDeleteKey (MkKey ks) = ks == xK_Delete --isMultiKeyKey (MkKey ks) = ks == xK_Multi_key isHomeKey (MkKey ks) = ks == xK_Home isLeftKey (MkKey ks) = ks == xK_Left isUpKey (MkKey ks) = ks == xK_Up isRightKey (MkKey ks) = ks == xK_Right isDownKey (MkKey ks) = ks == xK_Down isPriorKey (MkKey ks) = ks == xK_Prior isPageUpKey (MkKey ks) = ks == xK_Page_Up isNextKey (MkKey ks) = ks == xK_Next isPageDownKey (MkKey ks) = ks == xK_Page_Down isEndKey (MkKey ks) = ks == xK_End --isBeginKey (MkKey ks) = ks == xK_Begin isShiftLKey (MkKey ks) = ks == xK_Shift_L isShiftRKey (MkKey ks) = ks == xK_Shift_R isControlLKey (MkKey ks) = ks == xK_Control_L isControlRKey (MkKey ks) = ks == xK_Control_R --isCapsLockKey (MkKey ks) = ks == xK_Caps_Lock --isShiftLockKey (MkKey ks) = ks == xK_Shift_Lock --isMetaLKey (MkKey ks) = ks == xK_Meta_L --isMetaRKey (MkKey ks) = ks == xK_Meta_R --isAltLKey (MkKey ks) = ks == xK_Alt_L --isAltRKey (MkKey ks) = ks == xK_Alt_R #else /* X_DISPLAY_MISSING */ -- Converts a VKey representing an ISO 8859-1 (Latin 1) character or one -- of a few control characters to a Char. -- Note! It is assumed that the VKey encoding for Latin 1 characters agrees -- with the Haskell character encoding! keySymToChar :: VKey -> Maybe Char keySymToChar ks | space <= ks && ks <= ydiaresis = Just (toEnum (fromIntegral ks)) | ks == vK_BACK = Just '\BS' | ks == vK_TAB = Just '\HT' -- | ks == vK_LINEFEED = Just '\LF' | ks == vK_CLEAR = Just '\FF' | ks == vK_RETURN = Just '\CR' | ks == vK_ESCAPE = Just '\ESC' | ks == vK_DELETE = Just '\DEL' | otherwise = Nothing where space, ydiaresis :: VKey space = fromIntegral (fromEnum ' ') ydiaresis = fromIntegral 255 -- is this right? isBackSpaceKey (MkKey ks) = ks == vK_BACK isTabKey (MkKey ks) = ks == vK_TAB --isLineFeedKey (MkKey ks) = ks == vK_LINEFEED isClearKey (MkKey ks) = ks == vK_CLEAR isReturnKey (MkKey ks) = ks == vK_RETURN isEscapeKey (MkKey ks) = ks == vK_ESCAPE isDeleteKey (MkKey ks) = ks == vK_DELETE --isMultiKeyKey (MkKey ks) = ks == vK_MULTI_KEY isHomeKey (MkKey ks) = ks == vK_HOME isLeftKey (MkKey ks) = ks == vK_LEFT isUpKey (MkKey ks) = ks == vK_UP isRightKey (MkKey ks) = ks == vK_RIGHT isDownKey (MkKey ks) = ks == vK_DOWN isPriorKey (MkKey ks) = ks == vK_PRIOR isPageUpKey (MkKey ks) = ks == vK_PRIOR -- same as isPriorKey isNextKey (MkKey ks) = ks == vK_NEXT isPageDownKey (MkKey ks) = ks == vK_NEXT -- same as isNextKey isEndKey (MkKey ks) = ks == vK_END --isBeginKey (MkKey ks) = ks == vK_Begin isShiftLKey (MkKey ks) = ks == vK_SHIFT -- can't distinguish left and right isShiftRKey (MkKey ks) = ks == vK_SHIFT isControlLKey (MkKey ks) = ks == vK_CONTROL -- ambidextrous isControlRKey (MkKey ks) = ks == vK_CONTROL --isCapsLockKey (MkKey ks) = ks == vK_Caps_Lock --isShiftLockKey (MkKey ks) = ks == vK_Shift_Lock --isMetaLKey (MkKey ks) = ks == vK_Meta_L --isMetaRKey (MkKey ks) = ks == vK_Meta_R --isAltLKey (MkKey ks) = ks == vK_Alt_L --isAltRKey (MkKey ks) = ks == vK_Alt_R #endif /* X_DISPLAY_MISSING */ ---------------------------------------------------------------- -- End ---------------------------------------------------------------- HGL-3.2.0.2/Graphics/HGL/Run.hs0000644000514200001600000000410611274041443014371 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.Run -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : non-portable (requires concurrency) -- -- Running graphical actions. -- ----------------------------------------------------------------------------- module Graphics.HGL.Run ( runGraphics -- :: IO () -> IO () ) where #if !X_DISPLAY_MISSING import Graphics.HGL.X11.Display (getDisplayName) import Graphics.HGL.X11.Window (runGraphicsEx) #else import Graphics.HGL.Win32.WND (handleEvents, beginGraphics, endGraphics) import Graphics.HGL.Internals.Utilities (safeTry) import Control.Concurrent (forkIO, yield) import Data.IORef( newIORef, readIORef, writeIORef ) import System.IO.Error (try) #endif ---------------------------------------------------------------- -- Interface ---------------------------------------------------------------- -- | Initialize the system to do graphics, run an action while collecting -- user interface events and forwarding them to the action, and then clean -- up everything else at the end. -- The other functions of the library may only be used inside 'runGraphics'. runGraphics :: IO () -> IO () -- SOE, p48 ---------------------------------------------------------------- -- Implementation ---------------------------------------------------------------- #if !X_DISPLAY_MISSING runGraphics m = do disp <- getDisplayName runGraphicsEx disp m #else /* X_DISPLAY_MISSING */ -- We took a lot of effort to make sure that we always close the -- windows - even if "m" fails. -- -- Note though that we use "try" instead of "safeTry" on the call to -- "m" because it is quite normal for "m" to block (and safeTry treats -- blocking as failure). runGraphics m = do beginGraphics quit <- newIORef False safeTry $ do forkIO (try m >> writeIORef quit True) yield handleEvents (readIORef quit) endGraphics #endif /* X_DISPLAY_MISSING */ HGL-3.2.0.2/Graphics/HGL/Core.hs0000644000514200001600000000143211274041443014514 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.Core -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : non-portable (requires concurrency) -- -- Core functions of a simple graphics library. -- ----------------------------------------------------------------------------- module Graphics.HGL.Core ( module Graphics.HGL.Units , module Graphics.HGL.Run , module Graphics.HGL.Window , module Graphics.HGL.Draw , module Graphics.HGL.Key ) where import Graphics.HGL.Units import Graphics.HGL.Run import Graphics.HGL.Window import Graphics.HGL.Draw import Graphics.HGL.Key HGL-3.2.0.2/Graphics/HGL/Internals/0000755000514200001600000000000011274041443015227 5ustar cxltomcatHGL-3.2.0.2/Graphics/HGL/Internals/Events.hs0000644000514200001600000000446111274041443017034 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.Internals.Events -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : internal -- Portability : non-portable (requires concurrency) -- -- A simple graphics library. -- ----------------------------------------------------------------------------- -- #hide module Graphics.HGL.Internals.Events( Events, newEvents, getEvent, sendEvent, isNoEvent, getTick, sendTick ) where import Graphics.HGL.Internals.Event import Graphics.HGL.Internals.Flag import Control.Concurrent.Chan(Chan, newChan, readChan, writeChan, isEmptyChan) ---------------------------------------------------------------- -- Interface ---------------------------------------------------------------- -- Events are more or less just a channel (~list) of events -- -- The only subtlety is that ticks are not part of the channel: -- they're a separate "flag" so that ticks don't accumulate in the -- queue (if you process them too fast) and so that ticks can -- "overtake" other events. -- (Win32 timers do the same thing. I was rather surprised to find -- myself reimplementing this in Haskell (even in the Win32 version -- of the Graphics library). Exposure events in X11 behave in a -- similar way except that they do not overtake other events.) data Events = Events { events :: Chan Event , tick :: Flag () } newEvents :: IO Events getEvent :: Events -> IO Event isNoEvent :: Events -> IO Bool sendEvent :: Events -> Event -> IO () sendTick :: Events -> IO () getTick :: Events -> IO () ---------------------------------------------------------------- -- Implementation ---------------------------------------------------------------- newEvents = do events <- newChan tick <- newFlag return (Events { events=events, tick=tick }) getEvent evs = readChan (events evs) isNoEvent evs = isEmptyChan (events evs) sendEvent evs = writeChan (events evs) sendTick evs = setFlag (tick evs) () getTick evs = resetFlag (tick evs) ---------------------------------------------------------------- -- End ---------------------------------------------------------------- HGL-3.2.0.2/Graphics/HGL/Internals/Event.hs0000644000514200001600000000626211274041443016652 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.Internals.Event -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : internal -- Portability : non-portable (requires concurrency) -- -- Events in a simple graphics library. -- ----------------------------------------------------------------------------- -- #hide module Graphics.HGL.Internals.Event ( Event(..) -- , Event(Char,Key,Button,MouseMove,Resize,Closed) -- deriving(Show) -- , char -- :: Event -> Char -- , keysym -- :: Event -> Key -- , isDown -- :: Event -> Bool -- , pt -- :: Event -> Point -- , isLeft -- :: Event -> Bool ) where import Graphics.HGL.Key (Key) import Graphics.HGL.Internals.Types (Point) -- We probably need a lot more info about the event -- but this will do for now. ---------------------------------------------------------------- -- Interface ---------------------------------------------------------------- -- Note: The Char event is for delivering properly translated characters -- after a key*press*. At least under X, a single key press might yield -- 0, 1 or more characters after translation (see X[mb]LookupString). -- The Key event is intended for reporting key up/down events of -- *abstract* keys, i.e. KeySyms rather than KeyCodes in X terms. -- To make it possible to report such events for arrow keys, function -- keys and the like, the Char field needs to be replaced by a field of -- a type somewhat isomorphic to KeySym, but valid under Windows too. -- | A user interface event. -- -- Notes: -- -- * Programmers should assume that the 'Event' datatype will be -- extended in the not-too-distant future and that individual events -- may change slightly. As a minimum, you should add a \"match anything\" -- alternative to any function which pattern matches against 'Event's. -- -- * X11 systems typically have three button mice. Button 1 is used as the -- left button, button 3 as the right button and button 2 (the middle -- button) is ignored. data Event = Char { char :: Char -- ^ the character represented by a key combination } -- ^ a properly translated character, sent after -- a key press. | Key { keysym :: Key -- ^ representation of the keyboard keys pressed , isDown :: Bool -- ^ if 'True', the key was pressed; -- otherwise it was released } -- ^ occurs when a key was pressed or released. | Button { pt :: Point -- ^ the position of the mouse cursor , isLeft :: Bool -- ^ if 'True', it was the left button , isDown :: Bool -- ^ if 'True', the button was pressed; -- otherwise it was released } -- ^ occurs when a mouse button is pressed or released. | MouseMove { pt :: Point -- ^ the position of the mouse cursor after the movement } -- ^ occurs when the mouse is moved inside the window. | Resize -- ^ occurs when the window is resized. | Closed -- ^ occurs when the window is closed. deriving Show ---------------------------------------------------------------- -- End ---------------------------------------------------------------- HGL-3.2.0.2/Graphics/HGL/Internals/Draw.hs0000644000514200001600000000565211274041443016470 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.Internals.Draw -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : internal -- Portability : non-portable (requires concurrency) -- -- Drawing in a simple graphics library. -- ----------------------------------------------------------------------------- -- #hide module Graphics.HGL.Internals.Draw ( Graphic -- = Draw () , Draw , ioToDraw -- :: IO a -> Draw a , bracket -- :: Draw a -> (a -> Draw b) -> (a -> Draw c) -> Draw c , bracket_ -- :: Draw a -> (a -> Draw b) -> Draw c -> Draw c , unDraw -- :: Draw a -> (DC -> IO a) , mkDraw -- :: (DC -> IO a) -> Draw a ) where #if !X_DISPLAY_MISSING import Graphics.HGL.X11.Types(DC) #else import Graphics.HGL.Win32.Types(DC) #endif import qualified Graphics.HGL.Internals.Utilities as Utils (bracket, bracket_) import Control.Monad (liftM) ---------------------------------------------------------------- -- Graphics ---------------------------------------------------------------- -- | An abstract representation of an image. type Graphic = Draw () -- | Monad for sequential construction of images. newtype Draw a = MkDraw (DC -> IO a) unDraw :: Draw a -> (DC -> IO a) unDraw (MkDraw m) = m -- | Embed an 'IO' action in a drawing action. ioToDraw :: IO a -> Draw a ioToDraw m = MkDraw (\ _ -> m) mkDraw :: (DC -> IO a) -> Draw a mkDraw = MkDraw -- a standard reader monad instance Monad Draw where return a = MkDraw (\ hdc -> return a) m >>= k = MkDraw (\ hdc -> do { a <- unDraw m hdc; unDraw (k a) hdc }) m >> k = MkDraw (\ dc -> do { unDraw m dc; unDraw k dc }) instance Functor Draw where fmap = liftM -- | Wrap a drawing action in initialization and finalization actions. bracket :: Draw a -- ^ a pre-operation, whose value is passed to the -- other two components. -> (a -> Draw b) -- ^ a post-operation, to be performed on exit from -- the bracket, whether normal or by an exception. -> (a -> Draw c) -- ^ the drawing action inside the bracket. -> Draw c bracket left right m = MkDraw (\ hdc -> Utils.bracket (unDraw left hdc) (\ a -> unDraw (right a) hdc) (\ a -> unDraw (m a) hdc)) -- | A variant of 'bracket' in which the inner drawing action does not -- use the result of the pre-operation. bracket_ :: Draw a -- ^ a pre-operation, whose value is passed to the -- other two components. -> (a -> Draw b) -- ^ a post-operation, to be performed on exit from -- the bracket, whether normal or by an exception. -> Draw c -- ^ the drawing action inside the bracket. -> Draw c bracket_ left right m = MkDraw (\ hdc -> Utils.bracket_ (unDraw left hdc) (\ a -> unDraw (right a) hdc) (unDraw m hdc)) ---------------------------------------------------------------- HGL-3.2.0.2/Graphics/HGL/Internals/Utilities.hs0000644000514200001600000000277211274041443017546 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.Internals.Utilities -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : internal -- Portability : non-portable (requires concurrency) -- -- A simple graphics library. -- ----------------------------------------------------------------------------- -- #hide module Graphics.HGL.Internals.Utilities( bracket, bracket_, safeTry, Exception, modMVar, modMVar_ ) where import qualified Control.Exception as E (bracket, try, IOException, tryJust, ioErrors) import Control.Concurrent( MVar, takeMVar, putMVar ) bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c bracket = E.bracket -- Not exactly the same type as GHC's bracket_ bracket_ :: IO a -> (a -> IO b) -> IO c -> IO c bracket_ left right m = bracket left right (const m) type Exception = E.IOException safeTry :: IO a -> IO (Either Exception a) #if __GLASGOW_HASKELL >= 610 -- ghc-6.10 safeTry = E.try #else -- ghc 6.8 (and below?) safeTry = E.tryJust E.ioErrors #endif ---------------------------------------------------------------- -- Utilities ---------------------------------------------------------------- modMVar :: MVar a -> (a -> a) -> IO a modMVar mv f = do x <- takeMVar mv putMVar mv (f x) return x modMVar_ :: MVar a -> (a -> a) -> IO () modMVar_ mv f = do x <- takeMVar mv putMVar mv (f x) HGL-3.2.0.2/Graphics/HGL/Internals/Flag.hs0000644000514200001600000000332011274041443016432 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.Internals.Flag -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : internal -- Portability : non-portable (requires concurrency) -- -- A simple graphics library. -- ----------------------------------------------------------------------------- -- #hide module Graphics.HGL.Internals.Flag ( Flag, newFlag, setFlag, resetFlag ) where import Control.Concurrent.MVar ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar ) ---------------------------------------------------------------- -- Interface ---------------------------------------------------------------- -- We maintain a list of blocked processes. -- Blocked processes are "stored" in MVars; the outer MVar -- is used to implement a critical section. newtype Flag a = Flag (MVar [MVar a]) newFlag :: IO (Flag a) -- sets the flag, never blocks, never fails setFlag :: Flag a -> a -> IO () -- block until the flag is set (and reset it) resetFlag :: Flag a -> IO a ---------------------------------------------------------------- -- Implementation ---------------------------------------------------------------- newFlag = do queue <- newMVar [] return (Flag queue) setFlag (Flag queue) a = do ps <- takeMVar queue mapM_ (\ p -> putMVar p a) ps putMVar queue [] resetFlag (Flag queue) = do ps <- takeMVar queue p <- newEmptyMVar putMVar queue (p:ps) takeMVar p -- block ---------------------------------------------------------------- -- End ---------------------------------------------------------------- HGL-3.2.0.2/Graphics/HGL/Internals/Types.hs0000644000514200001600000000641611274041443016676 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.Internals.Types -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : internal -- Portability : portable -- -- Basic types for a simple graphics library. -- ----------------------------------------------------------------------------- -- #hide module Graphics.HGL.Internals.Types where #if !X_DISPLAY_MISSING import qualified Graphics.X11.Xlib as X #else import Graphics.Win32.Misc(timeGetTime) import Control.Monad( liftM ) #endif import Data.Ix(Ix) import Data.Word(Word8) ---------------------------------------------------------------- -- Units ---------------------------------------------------------------- -- | A distance on the screen, measured in pixels. type Dimension = Int -- | A position within a window, measured in pixels to the right and down -- from the top left corner. type Point = (Int,Int) -- | A (width, height) pair, both measured in pixels. type Size = (Int,Int) -- | An angle in degrees (0 to 360). type Angle = Double -- | Time, measured in milliseconds. type Time = Integer -- | Time in milliseconds since some arbitrary epoch. getTime :: IO Integer #if !X_DISPLAY_MISSING getTime = X.gettimeofday_in_milliseconds #else getTime = liftM toInteger timeGetTime #endif --------------------------------------------------------------- -- Drawing ---------------------------------------------------------------- -- | A color, comprising red, green and blue components. data RGB = RGB Word8 Word8 Word8 -- | The style of line drawn by a pen. data Style = Solid | Dash -- "-------" | Dot -- "......." | DashDot -- "_._._._" | DashDotDot -- "_.._.._" | Null | InsideFrame -- | Background mode for drawing text. data BkMode = Opaque -- ^ Draw text on a bounding rectangle filled with the -- current background color. | Transparent -- ^ Draw text without a background rectangle. -- | How strings drawn with 'Graphics.HGL.Draw.Text.text' are positioned -- relative to the specified reference point. type Alignment = (HAlign, VAlign) -- | Horizontal alignment of text. -- Names have a tick to distinguish them from "Prelude" names. data HAlign = Left' -- ^ align the left edge of the text with the reference point | Center -- ^ center the text with the reference point | Right' -- ^ align the right edge of the text with the reference point deriving (Enum, Eq, Ord, Ix, Show) -- | Vertical alignment of text. data VAlign = Top -- ^ align the top edge of the text with the reference point | Baseline -- ^ align the baseline of the text with the reference point | Bottom -- ^ align the bottom edge of the text with the reference point deriving (Enum, Eq, Ord, Ix, Show) --------------------------------------------------------------- -- Windows ---------------------------------------------------------------- -- | Title of a window. type Title = String -- | How to draw in a window. data RedrawMode = DoubleBuffered -- ^ use a /double buffer/ to reduce flicker. -- You should probably use this for animations. | Unbuffered -- ^ draw directly to the window. -- This runs slightly faster but is more prone -- to flicker. HGL-3.2.0.2/Graphics/HGL/Draw.hs0000644000514200001600000000270611274041443014526 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.Draw -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : non-portable (requires concurrency) -- -- Drawing in a simple graphics library. -- ----------------------------------------------------------------------------- module Graphics.HGL.Draw ( -- * Graphics -- | The type 'Graphic', which represents an abstract drawing, -- is actually a special case of a 'Draw' monad. module Graphics.HGL.Draw.Monad -- * Graphical objects -- | These are ways of constructing values of type 'Graphic'. , module Graphics.HGL.Draw.Picture , module Graphics.HGL.Draw.Text , module Graphics.HGL.Draw.Region -- * Graphical attributes -- | These are used to alter the above drawings. -- Brushes are used for filling shapes, pens for drawing lines. , module Graphics.HGL.Draw.Brush , module Graphics.HGL.Draw.Pen , module Graphics.HGL.Draw.Font ) where import Graphics.HGL.Draw.Monad import Graphics.HGL.Draw.Picture import Graphics.HGL.Draw.Text import Graphics.HGL.Draw.Region import Graphics.HGL.Draw.Brush import Graphics.HGL.Draw.Pen import Graphics.HGL.Draw.Font ---------------------------------------------------------------- -- The end ---------------------------------------------------------------- HGL-3.2.0.2/Graphics/HGL/Utils.hs0000644000514200001600000002307111274041443014727 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.Utils -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : non-portable (requires concurrency) -- -- Utility functions for a simple graphics library. -- ----------------------------------------------------------------------------- module Graphics.HGL.Utils ( -- * Windows openWindow -- :: Title -> Size -> IO Window , clearWindow -- :: Window -> IO () , drawInWindow -- :: Window -> Graphic -> IO () , withWindow -- :: Title -> Size -> (Window -> IO a) -> IO a , withWindow_ -- :: Title -> Size -> (Window -> IO a) -> IO () , runWindow -- :: Title -> Size -> (Window -> IO a) -> IO () , getWindowSize -- :: Window -> IO Size -- * Specific events -- ** Mouse events , getLBP -- :: Window -> IO Point , getRBP -- :: Window -> IO Point , getButton -- :: Window -> Bool -> Bool -> IO Point -- ** Keyboard events , getKey -- :: Window -> IO Key , getKeyEx -- :: Window -> Bool -> IO Key , wGetChar -- :: Window -> IO Char -- * Graphics -- ** Combining Graphics , emptyGraphic -- :: Graphic , overGraphic -- :: Graphic -> Graphic -> Graphic , overGraphics -- :: [Graphic] -> Graphic -- ** Graphic modifiers , withFont -- :: Font -> Graphic -> Graphic , withTextColor -- :: RGB -> Graphic -> Graphic , withTextAlignment -- :: Alignment -> Graphic -> Graphic , withBkColor -- :: RGB -> Graphic -> Graphic , withBkMode -- :: BkMode -> Graphic -> Graphic , withPen -- :: Pen -> Graphic -> Graphic , withBrush -- :: Brush -> Graphic -> Graphic , withRGB -- :: RGB -> Graphic -> Graphic -- * Named colors , Color(..) , colorList -- :: [(Color, RGB)] , colorTable -- :: Array Color RGB , withColor -- :: Color -> Graphic -> Graphic -- * Concurrency , par -- :: IO a -> IO b -> IO (a, b) , par_ -- :: IO a -> IO b -> IO () , parMany -- :: [IO ()] -> IO () ) where import Graphics.HGL.Core import Control.Concurrent ( newEmptyMVar, takeMVar, putMVar , forkIO ) import qualified Control.Exception as E import Data.Ix(Ix) import Data.Array(Array,array,(!)) ---------------------------------------------------------------- -- Interface ---------------------------------------------------------------- -- | Create a window with the given title and size. openWindow :: Title -> Size -> IO Window -- | Erase all drawing in the window. -- (That is, set the 'Graphic' held by the window to 'emptyGraphic'.) clearWindow :: Window -> IO () -- | Draw the given graphic on the window, on top of anything that is -- already there. -- (That is, combine the given 'Graphic' and the one held by the window -- using 'overGraphic', store the result in the window, and display it.) drawInWindow :: Window -> Graphic -> IO () -- | Run an action inside a new window, ensuring that the window is destroyed -- on exit. withWindow :: Title -> Size -> (Window -> IO a) -> IO a -- | A variant of 'withWindow' that ignores the result of the action. withWindow_ :: Title -> Size -> (Window -> IO a) -> IO () -- | A combination of 'runGraphics' and 'withWindow_'. runWindow :: Title -> Size -> (Window -> IO a) -> IO () -- | The current size of the window. getWindowSize :: Window -> IO Size -- | Wait for a press of the left mouse button, -- and return the position of the mouse cursor. getLBP :: Window -> IO Point -- | Wait for a press of the right mouse button, -- and return the position of the mouse cursor. getRBP :: Window -> IO Point -- | Wait for a mouse button to be pressed or released, -- and return the position of the mouse cursor. getButton :: Window -> Bool -- ^ if 'True', wait for the left button -> Bool -- ^ if 'True', wait for a press; -- otherwise wait for a release. -> IO Point -- | Wait until a key is pressed and released. getKey :: Window -> IO Key -- | Wait until a key is pressed (if the second argument is 'True') -- or released (otherwise). getKeyEx :: Window -> Bool -> IO Key -- | Wait for a translated character (from a key press). -- Use in preference to 'getKey' if the aim is to read text. wGetChar :: Window -> IO Char -- | An empty drawing. emptyGraphic :: Graphic -- | A composite drawing made by overlaying the first argument on the second. overGraphic :: Graphic -> Graphic -> Graphic -- | Overlay a list of drawings. overGraphics :: [Graphic] -> Graphic -- | Set the default font for a drawing. withFont :: Font -> Graphic -> Graphic -- | Set the default color for drawing text. withTextColor :: RGB -> Graphic -> Graphic -- | Set the default alignment of text in a drawing. withTextAlignment :: Alignment -> Graphic -> Graphic -- | Set the default background color for drawing text with background -- mode 'Opaque'. The background color is ignored when the mode is -- 'Transparent'. withBkColor :: RGB -> Graphic -> Graphic -- | Set the default background mode for drawing text. withBkMode :: BkMode -> Graphic -> Graphic -- | Set the default pen for drawing lines. withPen :: Pen -> Graphic -> Graphic -- | Set the default brush for filling shapes. withBrush :: Brush -> Graphic -> Graphic -- | A convenience function that sets the brush, -- pen and text colors to the same value. withRGB :: RGB -> Graphic -> Graphic -- | Named colors. data Color = Black | Blue | Green | Cyan | Red | Magenta | Yellow | White deriving (Eq, Ord, Bounded, Enum, Ix, Show, Read) -- | A mapping of 'Color' names to 'RGB' triples. colorList :: [(Color, RGB)] -- | A mapping of 'Color' names to 'RGB' triples. colorTable :: Array Color RGB -- | Set the default drawing color for a 'Graphic'. withColor :: Color -> Graphic -> Graphic -- | Run two 'IO' actions in parallel and terminate when both actions terminate. par :: IO a -> IO b -> IO (a,b) -- | Run two 'IO' actions in parallel and terminate when both actions terminate, -- discarding the results of the actions. par_ :: IO a -> IO b -> IO () -- | Run several 'IO' actions in parallel and terminate when all actions -- terminate, discarding the results of the actions. parMany :: [IO ()] -> IO () ---------------------------------------------------------------- -- Implementation ---------------------------------------------------------------- -- Window operations openWindow name size = openWindowEx name Nothing size Unbuffered Nothing clearWindow w = setGraphic w emptyGraphic getWindowSize w = do (pt,sz) <- getWindowRect w return sz drawInWindow w p = do modGraphic w (p `overGraphic`) directDraw w p withWindow name size = E.bracket (openWindow name size) closeWindow withWindow_ name size f = withWindow name size f >> return () runWindow name size f = runGraphics (withWindow_ name size f) -- Event operations -- wait for left/right mouse button up (SOE p148) getLBP w = getButton w True True getRBP w = getButton w False True -- Wait for a key to go down then a (possibly different) key to go up getKey w = do { getKeyEx w True; getKeyEx w False } -- wait for key to go down/up getKeyEx w down = loop where loop = do e <- getWindowEvent w case e of Key { keysym = k, isDown = isDown } | isDown == down -> return k _ -> loop getButton w left down = loop where loop = do e <- getWindowEvent w case e of Button {pt=pt,isLeft=isLeft,isDown=isDown} | isLeft == left && isDown == down -> return pt _ -> loop wGetChar w = loop where loop = do e <- getWindowEvent w case e of Char {char = c} -> return c _ -> loop -- Graphic --elsewhere: type Graphic = Draw () emptyGraphic = return () g1 `overGraphic` g2 = g2 >> g1 overGraphics = foldr overGraphic emptyGraphic -- Graphic modifiers withFont x = bracket_ (selectFont x) selectFont withTextAlignment x = bracket_ (setTextAlignment x) setTextAlignment withTextColor x = bracket_ (setTextColor x) setTextColor withBkColor x = bracket_ (setBkColor x) setBkColor withBkMode x = bracket_ (setBkMode x) setBkMode withPen x = bracket_ (selectPen x) selectPen withBrush x = bracket_ (selectBrush x) selectBrush withRGB c p = mkBrush c $ \ brush -> withBrush brush $ mkPen Solid 2 c $ \ pen -> withPen pen $ withTextColor c $ p colorList = [ (Black , RGB 0 0 0) , (Blue , RGB 0 0 255) , (Green , RGB 0 255 0) , (Cyan , RGB 0 255 255) , (Red , RGB 255 0 0) , (Magenta , RGB 255 0 255) , (Yellow , RGB 255 255 0) , (White , RGB 255 255 255) ] colorTable = array (minBound, maxBound) colorList withColor c g = withRGB (colorTable ! c) g -- Concurrency primitives par m1 m2 = do v1 <- newEmptyMVar v2 <- newEmptyMVar forkIO (m1 >>= putMVar v1) forkIO (m2 >>= putMVar v2) a <- takeMVar v1 b <- takeMVar v2 return (a,b) par_ m1 m2 = do v1 <- newEmptyMVar v2 <- newEmptyMVar forkIO (m1 >> putMVar v1 ()) forkIO (m2 >> putMVar v2 ()) takeMVar v1 takeMVar v2 return () parMany ms = foldr par_ (return ()) ms ---------------------------------------------------------------- -- End ---------------------------------------------------------------- HGL-3.2.0.2/Graphics/HGL/Window.hs0000644000514200001600000001351611274041443015101 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.Window -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : non-portable (requires concurrency) -- -- Windows in a simple graphics library. -- ----------------------------------------------------------------------------- module Graphics.HGL.Window ( -- * Windows Window , Title -- = String , RedrawMode(Unbuffered, DoubleBuffered) , openWindowEx -- :: Title -> Maybe Point -> Maybe Size -> -- RedrawMode -> Maybe Time -> IO Window , getWindowRect -- :: Window -> IO (Point,Point) , closeWindow -- :: Window -> IO () -- * Drawing in a window , setGraphic -- :: Window -> Graphic -> IO () , getGraphic -- :: Window -> IO Graphic , modGraphic -- :: Window -> (Graphic -> Graphic) -> IO () , directDraw -- :: Window -> Graphic -> IO () -- not in X11: , redrawWindow -- :: Window -> IO () -- * Events in a window , Event(..) -- , Event(Char,Key,Button,MouseMove,Resize,Closed) -- deriving(Show) -- , char -- :: Event -> Char -- , keysym -- :: Event -> Key -- , isDown -- :: Event -> Bool -- , pt -- :: Event -> Point -- , isLeft -- :: Event -> Bool , getWindowEvent -- :: Window -> IO Event , maybeGetWindowEvent -- :: Window -> IO (Maybe Event) -- * Timer ticks -- | Timers that tick at regular intervals are set up by 'openWindowEx'. , getWindowTick -- :: Window -> IO () , getTime -- :: IO Time ) where #ifdef __HADDOCK__ import Graphics.HGL.Key #endif import Graphics.HGL.Units import Graphics.HGL.Draw( Graphic ) import Graphics.HGL.Internals.Event( Event(..) ) import Graphics.HGL.Internals.Types( Title, RedrawMode(..), getTime ) import qualified Graphics.HGL.Internals.Events as E import Graphics.HGL.Internals.Utilities( modMVar, modMVar_ ) #if !X_DISPLAY_MISSING import Graphics.HGL.X11.Window (Window(..)) import qualified Graphics.HGL.X11.Window as X (openWindowEx, closeWindow, redrawWindow, directDraw, getWindowRect ) #else import Graphics.HGL.Win32.WND (WND, openWND, getHWND, closeWND, wndRect, redrawWND, drawWND) import Graphics.HGL.Win32.Types import Graphics.HGL.Win32.Draw( drawGraphic, drawBufferedGraphic ) import Graphics.HGL.Draw (Draw) -- import Graphics.HGL.Internals.Types import qualified Graphics.Win32 as Win32 #endif import Control.Concurrent.MVar ---------------------------------------------------------------- -- Interface ---------------------------------------------------------------- -- | Wait for the next event on the given window. getWindowEvent :: Window -> IO Event -- | Check for a pending event on the given window. maybeGetWindowEvent :: Window -> IO (Maybe Event) -- | Wait for the next tick event from the timer on the given window. getWindowTick :: Window -> IO () -- | Get the current drawing in a window. getGraphic :: Window -> IO Graphic -- | Set the current drawing in a window. setGraphic :: Window -> Graphic -> IO () -- | Update the drawing for a window. -- Note that this does not force a redraw. modGraphic :: Window -> (Graphic -> Graphic) -> IO () -- | General window creation. openWindowEx :: Title -- ^ title of the window -> Maybe Point -- ^ the optional initial position of a window -> Size -- ^ initial size of the window -> RedrawMode -- ^ how to display a graphic on the window -> Maybe Time -- ^ the time between ticks (in milliseconds) of an -- optional timer associated with the window -> IO Window -- | Close the window. closeWindow :: Window -> IO () redrawWindow :: Window -> IO () directDraw :: Window -> Graphic -> IO () -- | The position of the top left corner of the window on the screen, -- and the size of the window. getWindowRect :: Window -> IO (Point, Size) ---------------------------------------------------------------- -- Implementation ---------------------------------------------------------------- getWindowEvent w = E.getEvent (events w) maybeGetWindowEvent w = do noEvent <- E.isNoEvent (events w) if noEvent then return Nothing else do ev <- getWindowEvent w return (Just ev) getWindowTick w = E.getTick (events w) getGraphic w = readMVar (graphic w) setGraphic w p = do modMVar (graphic w) (const p) redrawWindow w modGraphic w = modMVar_ (graphic w) #if !X_DISPLAY_MISSING openWindowEx = X.openWindowEx closeWindow = X.closeWindow getWindowRect = X.getWindowRect redrawWindow = X.redrawWindow directDraw = X.directDraw #else /* X_DISPLAY_MISSING */ data Window = MkWindow { events :: E.Events, -- the event stream graphic :: MVar (Draw ()), -- the current graphic wnd :: WND -- the real window } openWindowEx name pos size redrawMode tickRate = do graphic <- newMVar (return ()) events <- E.newEvents let draw = \ hwnd hdc -> do p <- readMVar graphic repaint p hwnd hdc wnd <- openWND name (fmap fromPoint pos) (Just $ fromPoint size) events draw (fmap fromInteger tickRate) mkWindow wnd events graphic where repaint = case redrawMode of Unbuffered -> drawGraphic DoubleBuffered -> drawBufferedGraphic mkWindow :: WND -> E.Events -> MVar (Draw ()) -> IO Window mkWindow wnd events graphic = do return (MkWindow { wnd=wnd, events=events, graphic=graphic }) closeWindow w = closeWND (wnd w) getWindowRect w = wndRect (wnd w) redrawWindow w = redrawWND (wnd w) directDraw w p = drawWND (wnd w) p -- in case you need low level access windowHWND :: Window -> IO Win32.HWND windowHWND w = getHWND (wnd w) #endif /* X_DISPLAY_MISSING */ ---------------------------------------------------------------- -- End ---------------------------------------------------------------- HGL-3.2.0.2/Graphics/HGL/Units.hs0000644000514200001600000000107511274041443014731 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL.Units -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : portable -- -- Types for units in a simple graphics library. -- ----------------------------------------------------------------------------- module Graphics.HGL.Units ( Point , Size , Angle , Time ) where import Graphics.HGL.Internals.Types HGL-3.2.0.2/Graphics/HGL.hs0000644000514200001600000000574211274041443013634 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.HGL -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : non-portable (requires concurrency) -- -- A simple graphics library. -- ----------------------------------------------------------------------------- module Graphics.HGL ( -- $intro module Graphics.HGL.Units , module Graphics.HGL.Run , module Graphics.HGL.Window , module Graphics.HGL.Draw , module Graphics.HGL.Key , module Graphics.HGL.Utils -- $utils ) where import Graphics.HGL.Units import Graphics.HGL.Run import Graphics.HGL.Window import Graphics.HGL.Draw import Graphics.HGL.Key import Graphics.HGL.Utils {- $intro The Haskell Graphics Library is designed to give the programmer access to most interesting parts of the Win32 Graphics Device Interface and X11 library without exposing the programmer to the pain and anguish usually associated with using these interfaces. To give you a taste of what the library looks like, here is the obligatory \"Hello World\" program: > module Main where > > import Graphics.HGL > > main :: IO () > main = runGraphics $ > withWindow_ "Hello World Window" (300, 200) $ \ w -> do > drawInWindow w $ text (100, 100) "Hello World" > drawInWindow w $ ellipse (100, 80) (200, 180) > getKey w Here's what each function does: * 'runGraphics' (defined in "Graphics.HGL.Run") runs a graphical action in an appropriate environment. All the other functions of the library should be used inside 'runGraphics'. * 'withWindow_' runs an action using a new 'Window', specifying the window title and size (300 pixels wide and 200 high). The window is closed when the action finishes. * 'drawInWindow' draws a 'Graphic' (an abstract representation of a picture) on a 'Window'. * 'text' creates a 'Graphic' consisting of a string at the specified position. * 'ellipse' creates a 'Graphic' consisting of an ellipse fitting inside a rectangle defined by the two points. These and other functions for defining, combining and modifying pictures are in "Graphics.HGL.Draw". * 'getKey' waits for the user to press (and release) a key. (This is necessary here to prevent the window from closing before you have a chance to read what's on the screen.) The library is broken up into several pieces. -} {- $utils The module "Graphics.HGL.Utils" defines a number of convenience functions in terms of more primitive functions defined by other modules. For example, * 'withWindow_' is defined using 'openWindowEx' and 'closeWindow' (from "Graphics.HGL.Window"). * 'getKey' is defined using 'getWindowEvent', which waits for a range of user interface events. * Instead of drawing several 'Graphic' objects sequentially as in the above example, you can combine them into a single 'Graphic' object using 'overGraphic'. -} HGL-3.2.0.2/Graphics/SOE.hs0000644000514200001600000002022711274041443013643 0ustar cxltomcat----------------------------------------------------------------------------- -- | -- Module : Graphics.SOE -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : stable -- Portability : non-portable (requires concurrency) -- -- The graphics library used in /The Haskell School of Expression/, -- by Paul Hudak, cf . -- -- /Notes:/ -- -- * This module is called @SOEGraphics@ in the book. It is a cut -- down version of "Graphics.HGL", with the interface frozen to match -- the book. -- -- * In chapters 13, 17 and 19 of the book, there are imports of modules -- @Win32Misc@ and @Word@. These should be omitted, as 'timeGetTime' -- and 'word32ToInt' are provided by this module. ----------------------------------------------------------------------------- module Graphics.SOE ( -- * Getting started runGraphics -- p41 -- * Windows , Title -- p40 , Size , Window , openWindow , getWindowSize -- not in SOE, but Resize is , clearWindow -- used on p127 , drawInWindow -- p41 , drawInWindowNow -- backward compatibility (p281) , setGraphic -- p168 , closeWindow -- p41 -- ** General windows , openWindowEx -- p168 , RedrawMode -- SOE has (Graphic -> DrawFun) , drawGraphic -- p168 , drawBufferedGraphic -- * Drawing , Graphic -- p41 , emptyGraphic -- p171 , overGraphic , overGraphics -- not in SOE, but an obvious extension -- ** Color , Color(..) -- p43 , withColor -- ** Drawing text , text -- p41 -- ** Drawing shapes , Point , ellipse -- p43 , shearEllipse , line , polygon , polyline , polyBezier -- warning: becomes error message and polyline in X11 , Angle -- not in SOE , arc -- not in SOE, but handy for pie charts -- ** Regions , Region -- p117 , createRectangle , createEllipse , createPolygon , andRegion , orRegion , xorRegion , diffRegion , drawRegion -- * User interaction -- ** Keyboard events , getKey -- p41 -- ** Mouse events , getLBP -- used on p127 , getRBP -- not in SOE, but obvious -- ** General events , Event(..) -- p214 , maybeGetWindowEvent -- p248 , getWindowEvent -- not in SOE, but obvious -- * Time -- Timers that tick at regular intervals are set up by 'openWindowEx'. , Word32 -- p168 , getWindowTick , timeGetTime -- from Win32 , word32ToInt -- obsolete function from Data.Word ) where import Graphics.HGL hiding (getKey, getKeyEx, openWindowEx, Event(..), getWindowEvent, maybeGetWindowEvent) import qualified Graphics.HGL as HGL import Control.Monad(liftM) import Data.Word(Word32) ---------------------------------------------------------------- -- Interface ---------------------------------------------------------------- -- | A rectangular region, with the given points as opposite corners. createRectangle :: Point -> Point -> Region -- | A polygonal region defined by a list of 'Point's. createPolygon :: [Point] -> Region -- | An elliptical region that fits in the rectangle with the given points -- as opposite corners. createEllipse :: Point -> Point -> Region -- | The union of two regions. orRegion :: Region -> Region -> Region -- | The intersection of two regions. andRegion :: Region -> Region -> Region -- | The part of the first region that is not also in the second. diffRegion :: Region -> Region -> Region -- | Draw a 'Region' in the current color. drawRegion :: Region -> Graphic -- | Another name for 'drawInWindow', retained for backwards compatibility. drawInWindowNow :: Window -> Graphic -> IO () ---------------------------------------------------------------- -- Implementation ---------------------------------------------------------------- -- | an extended version of 'openWindow'. openWindowEx :: Title -- ^ the title of the window -> Maybe Point -- ^ the initial position of the window -> Maybe Size -- ^ the initial size of the window -> RedrawMode -- ^ how to display a graphic on the window -> Maybe Word32 -- ^ optionally attach a timer to the window, -- with the specified time (in milliseconds) -- between ticks. -> IO Window openWindowEx a b (Just c) d e = HGL.openWindowEx a b c d (fmap fromIntegral e) openWindowEx a b Nothing d e = HGL.openWindowEx a b (300,300) d (fmap fromIntegral e) createRectangle = rectangleRegion createEllipse = ellipseRegion createPolygon = polygonRegion orRegion = unionRegion andRegion = intersectRegion diffRegion = subtractRegion drawRegion = regionToGraphic -- backwards compatibility: -- | Draw directly to the window -- (slightly faster than 'drawBufferedGraphic', but more prone to flicker). drawGraphic :: RedrawMode drawGraphic = Unbuffered -- | Use a /double buffer/ to reduce flicker and thus improve the look -- of animations. drawBufferedGraphic :: RedrawMode drawBufferedGraphic = DoubleBuffered -- should have a different way to specify background color -- drawBufferedGraphicBC :: RGB -> RedrawMode drawInWindowNow = drawInWindow -- | The current time of day (in milliseconds). timeGetTime :: IO Word32 timeGetTime = liftM integerToWord32 getTime integerToWord32 :: Integer -> Word32 #ifdef __GLASGOW_HASKELL__ integerToWord32 = fromInteger -- conversion to Word32 doesn't overflow #else integerToWord32 n = fromInteger (n `mod` (toInteger (maxBound::Word32) + 1)) #endif -- | An obsolete special case of 'fromIntegral'. word32ToInt :: Word32 -> Int word32ToInt = fromIntegral ---------------------------------------------------------------- -- Event, getKey, and maybeGetWindowEvent compatibility ---------------------------------------------------------------- {- The SOE sources are set in stone, so this module provides the interface SOE expects, even if the Graphics library moves on (cf. Event.Key). -} -- Deprecated SOE compatibility. -- | Wait until a key is pressed and released, -- and return the corresponding character. getKey :: Window -> IO Char getKey w = do { getKeyEx w True; getKeyEx w False } -- | Wait until a key is pressed (if the second argument is 'True') -- or released (otherwise), and return the corresponding character. -- (not in SOE) getKeyEx :: Window -> Bool -> IO Char getKeyEx w down = loop where loop = do e <- HGL.getWindowEvent w case e of HGL.Key { HGL.keysym = k, HGL.isDown = isDown } | isDown == down && isCharKey k -> return (keyToChar k) _ -> loop -- | Wait for the next event in the window. getWindowEvent :: Window -> IO Event getWindowEvent w = liftM toSOEEvent (HGL.getWindowEvent w) -- | Return a pending eventin the window, if any. maybeGetWindowEvent :: Window -> IO (Maybe Event) maybeGetWindowEvent w = liftM (fmap toSOEEvent) (HGL.maybeGetWindowEvent w) -- tiresome, but necessary. toSOEEvent :: HGL.Event -> Event toSOEEvent (HGL.Char x) = Key x True toSOEEvent (HGL.Key k isDown) = Key (keyToChar k) isDown toSOEEvent (HGL.Button pt left down) = Button pt left down toSOEEvent (HGL.MouseMove p) = MouseMove p toSOEEvent (HGL.Resize) = Resize toSOEEvent (HGL.Closed) = Closed -- | User interface events data Event = Key { char :: Char -- ^ character corresponding to the key , isDown :: Bool -- ^ if 'True', the key was pressed; -- otherwise it was released } -- ^ occurs when a key was pressed or released. | Button { pt :: Point -- ^ the position of the mouse cursor , isLeft :: Bool -- ^ if 'True', it was the left button , isDown :: Bool -- ^ if 'True', the button was pressed; -- otherwise it was released } -- ^ occurs when a mouse button is pressed or released. | MouseMove { pt :: Point -- ^ the position of the mouse cursor } -- ^ occurs when the mouse is moved inside the window. | Resize -- ^ occurs when the window is resized. -- The new window size can be discovered using -- 'getWindowSize'. | Closed -- ^ occurs when the window is closed. deriving Show ---------------------------------------------------------------- -- End ---------------------------------------------------------------- HGL-3.2.0.2/HGL.cabal0000644000514200001600000000373611274041443012525 0ustar cxltomcatname: HGL version: 3.2.0.2 license: BSD3 license-file: LICENSE author: Alastair Reid maintainer: Christoph Lueth category: Graphics synopsis: A simple graphics library based on X11 or Win32 description: A simple graphics library, designed to give the programmer access to most interesting parts of the Win32 Graphics Device Interface and X11 library without exposing the programmer to the pain and anguish usually associated with using these interfaces. . The library also includes a module Graphics.SOE providing the interface used in "The Haskell School of Expression", by Paul Hudak, cf . build-type: Simple cabal-version: >= 1.2.1 flag split-base library if flag(split-base) build-depends: base >= 3 && < 4, array else build-depends: base < 2 exposed-modules: Graphics.HGL.Core, Graphics.HGL.Draw, Graphics.HGL.Units, Graphics.HGL.Key, Graphics.HGL.Run, Graphics.HGL.Draw.Brush, Graphics.HGL.Draw.Font, Graphics.HGL.Draw.Monad, Graphics.HGL.Draw.Pen, Graphics.HGL.Draw.Picture, Graphics.HGL.Draw.Region, Graphics.HGL.Draw.Text, Graphics.HGL.Utils, Graphics.HGL.Window, Graphics.HGL, Graphics.SOE other-modules: Graphics.HGL.Internals.Event, Graphics.HGL.Internals.Events, Graphics.HGL.Internals.Draw, Graphics.HGL.Internals.Types, Graphics.HGL.Internals.Flag, Graphics.HGL.Internals.Utilities if os(windows) build-depends: Win32 cpp-options: -DX_DISPLAY_MISSING other-modules: Graphics.HGL.Win32.Bitmap, Graphics.HGL.Win32.Draw, Graphics.HGL.Win32.Types, Graphics.HGL.Win32.WND else build-depends: X11 other-modules: Graphics.HGL.X11.Display, Graphics.HGL.X11.DC, Graphics.HGL.X11.Timer, Graphics.HGL.X11.Types, Graphics.HGL.X11.Window extensions: CPP