From 4866f2e367dfcf22a9591231ba40948826a1b438 Mon Sep 17 00:00:00 2001 From: Spencer Janssen Date: Thu, 1 Nov 2007 21:10:59 +0100 Subject: Hierarchify darcs-hash:20071101201059-a5988-fc1f1262bec1b69e13ba18ae7cefeafc8c4471d4.gz --- XUtils.hs | 191 -------------------------------------------------------------- 1 file changed, 191 deletions(-) delete mode 100644 XUtils.hs (limited to 'XUtils.hs') diff --git a/XUtils.hs b/XUtils.hs deleted file mode 100644 index 15c89b2..0000000 --- a/XUtils.hs +++ /dev/null @@ -1,191 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : XMonadContrib.XUtils --- Copyright : (c) 2007 Andrea Rossato --- License : BSD-style (see xmonad/LICENSE) --- --- Maintainer : andrea.rossato@unibz.it --- Stability : unstable --- Portability : unportable --- --- A module for painting on the screen --- ------------------------------------------------------------------------------ - -module XMonadContrib.XUtils ( - -- * Usage: - -- $usage - stringToPixel - , averagePixels - , initFont - , releaseFont - , createNewWindow - , showWindow - , hideWindow - , deleteWindow - , paintWindow - , Align (..) - , stringPosition - , paintAndWrite - ) where - - -import Graphics.X11.Xlib -import Graphics.X11.Xlib.Extras - -import Control.Monad.Reader -import Data.Maybe -import XMonad -import XMonad.Operations - --- $usage --- See Tabbed or DragPane for usage examples - --- | Get the Pixel value for a named color: if an invalid name is --- given the black pixel will be returned. -stringToPixel :: String -> X Pixel -stringToPixel s = do - d <- asks display - io $ catch (getIt d) (fallBack d) - where getIt d = initColor d s - fallBack d = const $ return $ blackPixel d (defaultScreen d) - --- | Compute the weighted average the colors of two given Pixel values. -averagePixels :: Pixel -> Pixel -> Double -> X Pixel -averagePixels p1 p2 f = - do d <- asks display - let cm = defaultColormap d (defaultScreen d) - [Color _ r1 g1 b1 _,Color _ r2 g2 b2 _] <- io $ queryColors d cm [Color p1 0 0 0 0,Color p2 0 0 0 0] - let mn x1 x2 = round (fromIntegral x1 * f + fromIntegral x2 * (1-f)) - Color p _ _ _ _ <- io $ allocColor d cm (Color 0 (mn r1 r2) (mn g1 g2) (mn b1 b2) 0) - return p - --- | Given a fontname returns the fonstructure. If the font name is --- not valid the default font will be loaded and returned. -initFont :: String -> X FontStruct -initFont s = do - d <- asks display - io $ catch (getIt d) (fallBack d) - where getIt d = loadQueryFont d s - fallBack d = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" - -releaseFont :: FontStruct -> X () -releaseFont fs = do - d <- asks display - io $ freeFont d fs - --- | Create a simple window given a rectangle. If Nothing is given --- only the exposureMask will be set, otherwise the Just value. --- Use 'showWindow' to map and hideWindow to unmap. -createNewWindow :: Rectangle -> Maybe EventMask -> String -> X Window -createNewWindow (Rectangle x y w h) m col = do - d <- asks display - rw <- asks theRoot - c <- stringToPixel col - win <- io $ createSimpleWindow d rw x y w h 0 c c - case m of - Just em -> io $ selectInput d win em - Nothing -> io $ selectInput d win exposureMask - return win - --- | Map a window -showWindow :: Window -> X () -showWindow w = do - d <- asks display - io $ mapWindow d w - --- | unmap a window -hideWindow :: Window -> X () -hideWindow w = do - d <- asks display - io $ unmapWindow d w - --- | destroy a window -deleteWindow :: Window -> X () -deleteWindow w = do - d <- asks display - io $ destroyWindow d w - --- | Fill a window with a rectangle and a border -paintWindow :: Window -- ^ The window where to draw - -> Dimension -- ^ Window width - -> Dimension -- ^ Window height - -> Dimension -- ^ Border width - -> String -- ^ Window background color - -> String -- ^ Border color - -> X () -paintWindow w wh ht bw c bc = - paintWindow' w (Rectangle 0 0 wh ht) bw c bc Nothing - --- | String position -data Align = AlignCenter | AlignRight | AlignLeft - --- | Return the string x and y 'Position' in a 'Rectangle', given a --- 'FontStruct' and the 'Align'ment -stringPosition :: FontStruct -> Rectangle -> Align -> String -> (Position,Position) -stringPosition fs (Rectangle _ _ w h) al s = (x,y) - where width = textWidth fs s - (_,a,d,_) = textExtents fs s - y = fi $ ((h - fi (a + d)) `div` 2) + fi a - x = case al of - AlignCenter -> fi (w `div` 2) - fi (width `div` 2) - AlignLeft -> 1 - AlignRight -> fi (w - (fi width + 1)) - --- | Fill a window with a rectangle and a border, and write a string at given position -paintAndWrite :: Window -- ^ The window where to draw - -> FontStruct -- ^ The FontStruct - -> Dimension -- ^ Window width - -> Dimension -- ^ Window height - -> Dimension -- ^ Border width - -> String -- ^ Window background color - -> String -- ^ Border color - -> String -- ^ String color - -> String -- ^ String background color - -> Align -- ^ String 'Align'ment - -> String -- ^ String to be printed - -> X () -paintAndWrite w fs wh ht bw bc borc ffc fbc al str = - paintWindow' w r bw bc borc ms - where ms = Just (fs,ffc,fbc,str) - r = Rectangle x y wh ht - (x,y) = stringPosition fs (Rectangle 0 0 wh ht) al str - --- This stuf is not exported - -paintWindow' :: Window -> Rectangle -> Dimension -> String -> String -> Maybe (FontStruct,String,String,String) -> X () -paintWindow' win (Rectangle x y wh ht) bw color b_color str = do - d <- asks display - p <- io $ createPixmap d win wh ht (defaultDepthOfScreen $ defaultScreenOfDisplay d) - gc <- io $ createGC d p - -- draw - io $ setGraphicsExposures d gc False - [c',bc'] <- mapM stringToPixel [color,b_color] - -- we start with the border - io $ setForeground d gc bc' - io $ fillRectangle d p gc 0 0 wh ht - -- and now again - io $ setForeground d gc c' - io $ fillRectangle d p gc (fi bw) (fi bw) ((wh - (bw * 2))) (ht - (bw * 2)) - when (isJust str) $ do - let (fs,fc,bc,s) = fromJust str - io $ setFont d gc $ fontFromFontStruct fs - printString d p gc fc bc x y s - -- copy the pixmap over the window - io $ copyArea d p win gc 0 0 wh ht 0 0 - -- free the pixmap and GC - io $ freePixmap d p - io $ freeGC d gc - --- | Prints a string on a 'Drawable' -printString :: Display -> Drawable -> GC -> String -> String - -> Position -> Position -> String -> X () -printString d drw gc fc bc x y s = do - [fc',bc'] <- mapM stringToPixel [fc,bc] - io $ setForeground d gc fc' - io $ setBackground d gc bc' - io $ drawImageString d drw gc x y s - --- | Short-hand for 'fromIntegral' -fi :: (Integral a, Num b) => a -> b -fi = fromIntegral -- cgit v1.2.3