-----------------------------------------------------------------------------
-- |
-- 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
