module Graphics.X11.Turtle.XTools( -- * types Display, Window, Pixmap, Atom, Point(..), Position, Dimension, XEventPtr, XIC, Bufs, undoBuf, bgBuf, topBuf, GCs, gcForeground, gcBackground, Event(..), -- * open window forkIOX, openWindow, destroyWindow, closeDisplay, windowSize, -- * draws flush, getColorPixel, setForeground, copyArea, fillRectangle, fillPolygon, drawLineXT, writeStringXT, drawImage, -- * event allocaXEvent, waitEvent, pending, nextEvent, getEvent, filterEvent, utf8LookupString, buttonPress, buttonRelease, xK_VoidSymbol, ) where import Text.XML.YJSVG(Color(..)) import Graphics.X11( Display, Drawable, Window, Pixmap, Visual, Colormap, GC, Pixel, Atom, Point(..), Position, Dimension, XEventPtr, initThreads, flush, supportsLocale, setLocaleModifiers, connectionNumber, openDisplay, closeDisplay, internAtom, createSimpleWindow, destroyWindow, mapWindow, createGC, createPixmap, rootWindow, defaultScreen, defaultScreenOfDisplay, defaultVisual, defaultColormap, defaultDepth, whitePixel, blackPixel, copyArea, fillRectangle, drawLine, nonconvex, coordModeOrigin, setLineAttributes, lineSolid, capRound, joinRound, setForeground, allocNamedColor, color_pixel, allocaXEvent, pending, nextEvent, setWMProtocols, selectInput, button1MotionMask, buttonReleaseMask, buttonPressMask, keyPressMask, exposureMask, pointerMotionMask, buttonPress, buttonRelease, xK_VoidSymbol, getGeometry, drawPoint) import qualified Graphics.X11 as X(fillPolygon) import Graphics.X11.Xlib.Extras(Event(..), getEvent) import Graphics.X11.Xft( XftColor, xftDrawCreate, xftFontOpen, withXftColorValue, withXftColorName, xftDrawString) import Graphics.X11.Xrender(XRenderColor(..)) import Graphics.X11.Xim( XIC, XNInputStyle(..), openIM, createIC, getICValue, filterEvent, utf8LookupString) import Control.Monad(forM_, replicateM) import Control.Monad.Tools(unlessM) import Control.Concurrent(ThreadId, forkIO, threadWaitRead) import Data.Bits((.|.), shift) import System.Locale.SetLocale(setLocale, Category(..)) import System.Posix.Types(Fd(..)) import Numeric(showFFloat) import Data.IORef import Data.IORef.Tools(atomicModifyIORef_) import Foreign.Ptr import Foreign.Storable import Foreign.Marshal.Array import Data.Word import Graphics.Imlib -------------------------------------------------------------------------------- data Bufs = Bufs{ undoBuf :: Pixmap, bgBuf :: Pixmap, topBuf :: Pixmap} data GCs = GCs{ gcForeground :: GC, gcBackground :: GC} -------------------------------------------------------------------------------- forkIOX :: IO () -> IO ThreadId forkIOX = (initThreads >>) . forkIO openWindow :: IO (Display, Window, Bufs, GCs, XIC, Atom, (Dimension, Dimension)) openWindow = do _ <- setLocale LC_CTYPE Nothing >>= maybe (error "setLocale") return _ <- initThreads unlessM supportsLocale $ error "Current locale is not supported." _ <- setLocaleModifiers "" dpy <- openDisplay "" del <- internAtom dpy "WM_DELETE_WINDOW" True let scr = defaultScreen dpy root <- rootWindow dpy scr (rWidth, rHeight) <- windowSize dpy root bufs@[ub, bb, tb] <- replicateM 3 $ createPixmap dpy root rWidth rHeight $ defaultDepth dpy scr win <- createSimpleWindow dpy root 0 0 rWidth rHeight 1 (blackPixel dpy scr) (whitePixel dpy scr) im <- openIM dpy Nothing Nothing Nothing ic <- createIC im [XIMPreeditNothing, XIMStatusNothing] win fevent <- getICValue ic "filterEvents" [gc, gcBG] <- replicateM 2 $ createGC dpy win setForeground dpy gcBG 0xffffff forM_ bufs $ \bf -> fillRectangle dpy bf gcBG 0 0 rWidth rHeight setWMProtocols dpy win [del] selectInput dpy win $ fevent .|. exposureMask .|. keyPressMask .|. buttonPressMask .|. buttonReleaseMask .|. button1MotionMask .|. pointerMotionMask size <- mapWindow dpy win >> windowSize dpy win return (dpy, win, Bufs ub bb tb, GCs gc gcBG, ic, del, size) windowSize :: Display -> Window -> IO (Dimension, Dimension) windowSize dpy win = do (_, _, _, width, height, _, _) <- getGeometry dpy win return (width, height) -------------------------------------------------------------------------------- getColorPixel :: Display -> Color -> IO (Maybe Pixel) getColorPixel _ (RGB r g b) = return $ Just $ shift (fromIntegral r) 16 .|. shift (fromIntegral g) 8 .|. fromIntegral b getColorPixel dpy (ColorName cn) = fmap (Just . color_pixel . fst) (allocNamedColor dpy (defaultColormap dpy $ defaultScreen dpy) cn) `catch` const (putStrLn "no such color" >> return Nothing) fillPolygon :: Display -> Drawable -> GC -> [Point] -> IO () fillPolygon d w gc ps = X.fillPolygon d w gc ps nonconvex coordModeOrigin drawLineXT :: Display -> GC -> Drawable -> Int -> Color -> Position -> Position -> Position -> Position -> IO () drawLineXT dpy gc bf lw c x1 y1 x2 y2 = do getColorPixel dpy c >>= maybe (return ()) (setForeground dpy gc) setLineAttributes dpy gc (fromIntegral lw) lineSolid capRound joinRound drawLine dpy bf gc x1 y1 x2 y2 writeStringXT :: Display -> Drawable -> String -> Double -> Color -> Position -> Position -> String -> IO () writeStringXT dpy buf fname size clr x y str = do let scrN = defaultScreenOfDisplay dpy visual = defaultVisual dpy $ defaultScreen dpy colormap = defaultColormap dpy $ defaultScreen dpy xftDraw <- xftDrawCreate dpy buf visual colormap xftFont <- xftFontOpen dpy scrN $ fname ++ "-" ++ showFFloat (Just 0) size "" withXftColor dpy visual colormap clr $ \c -> xftDrawString xftDraw c xftFont x y str withXftColor :: Display -> Visual -> Colormap -> Color -> (XftColor -> IO a) -> IO a withXftColor dpy visual colormap (RGB r g b) action = withXftColorValue dpy visual colormap color action where color = XRenderColor { xrendercolor_red = fromIntegral r * 0x100, xrendercolor_green = fromIntegral b * 0x100, xrendercolor_blue = fromIntegral g * 0x100, xrendercolor_alpha = 0xffff} withXftColor dpy visual colormap (ColorName cn) action = withXftColorName dpy visual colormap cn action -------------------------------------------------------------------------------- waitEvent :: Display -> IO () waitEvent = threadWaitRead . Fd . connectionNumber drawImage :: Display -> Drawable -> GC -> FilePath -> Position -> Position -> Dimension -> Dimension -> IO () drawImage dpy win gc fp x y w h = getPicture fp w h >>= maybe (return ()) (drawPicture dpy win gc x y) getPicture :: FilePath -> Dimension -> Dimension -> IO (Maybe (Dimension, Dimension, Ptr Word32)) getPicture fp nw nh = do (img, err) <- loadImageWithErrorReturn fp case err of ImlibLoadErrorNone -> do contextSetImage img w <- fmap fromIntegral imageGetWidth h <- fmap fromIntegral imageGetHeight nimg <- createCroppedScaledImage (0 :: Int) (0 :: Int) (w :: Int) (h :: Int) nw nh contextSetImage nimg dat <- imageGetData return $ Just (nw, nh, dat) _ -> print err >> return Nothing drawPicture :: Display -> Drawable -> GC -> Position -> Position -> (Dimension, Dimension, Ptr Word32) -> IO () drawPicture dpy win gc x0 y0 (w, h, dat) = do ptr <- newIORef dat forM_ [0 .. w * h - 1] $ \i -> do readIORef ptr >>= peek >>= setForeground dpy gc let x = fromIntegral i `mod` w y = fromIntegral i `div` w drawPoint dpy win gc (x0 + fromIntegral x) (y0 + fromIntegral y) atomicModifyIORef_ ptr $ flip advancePtr 1