module Graphics.X11.Turtle.Field(
Field,
Layer,
Character,
openField,
closeField,
waitField,
fieldSize,
forkField,
flushField,
fieldColor,
addLayer,
drawLine,
fillPolygon,
writeString,
undoLayer,
clearLayer,
addCharacter,
drawCharacter,
drawCharacterAndLine,
clearCharacter,
onclick,
onrelease,
ondrag,
onkeypress
) where
import Graphics.X11.Turtle.XTools(
Display, Window, Pixmap, Atom, Point(..), Position, Dimension,
XEventPtr, XIC, Bufs, undoBuf, bgBuf, topBuf,
GCs, gcForeground, gcBackground, Event(..),
forkIOX, openWindow, destroyWindow, closeDisplay, windowSize,
flush, getColorPixel, setForeground, copyArea, fillRectangle,
drawLineXT, writeStringXT,
allocaXEvent, waitEvent, pending, nextEvent, getEvent, filterEvent,
utf8LookupString, buttonPress, buttonRelease, xK_VoidSymbol)
import qualified Graphics.X11.Turtle.XTools as X(fillPolygon)
import Graphics.X11.Turtle.Layers(
Layers, Layer, Character, newLayers, redrawLayers,
makeLayer, addDraw, setBackground, undoLayer, clearLayer,
makeCharacter, setCharacter)
import Text.XML.YJSVG(Color(..))
import Control.Monad(forever, replicateM)
import Control.Monad.Tools(doWhile_, doWhile, whenM)
import Control.Arrow((***))
import Control.Concurrent(
forkIO, ThreadId, killThread, Chan, newChan, readChan, writeChan)
import Data.IORef(IORef, newIORef, readIORef, writeIORef, modifyIORef)
import Data.Maybe(fromMaybe)
import Data.Convertible(convert)
data Field = Field{
fDisplay :: Display, fWindow :: Window, fBufs :: Bufs, fGCs :: GCs,
fIC :: XIC, fDel :: Atom, fSize :: IORef (Dimension, Dimension),
fClick, fRelease :: IORef (Int -> Double -> Double -> IO Bool),
fDrag :: IORef (Double -> Double -> IO ()),
fKeypress :: IORef (Char -> IO Bool), fPressed :: IORef Bool,
fLayers :: IORef Layers, fRunning :: IORef [ThreadId],
fLock, fClose, fEnd :: Chan ()
}
makeField :: Display -> Window -> Bufs -> GCs -> XIC -> Atom ->
IORef (Dimension, Dimension) -> IORef Layers -> IO Field
makeField dpy win bufs gcs ic del sizeRef ls = do
[click, release] <- replicateM 2 $ newIORef $ \_ _ _ -> return True
drag <- newIORef $ \_ _ -> return ()
keypress <- newIORef $ \_ -> return True
pressed <- newIORef False
running <- newIORef []
[lock, close, end] <- replicateM 3 newChan
writeChan lock ()
return Field{
fDisplay = dpy, fWindow = win, fBufs = bufs, fGCs = gcs,
fIC = ic, fDel = del, fSize = sizeRef,
fClick = click, fRelease = release, fDrag = drag,
fKeypress = keypress, fPressed = pressed,
fLayers = ls,
fRunning = running,
fLock = lock, fClose = close, fEnd = end
}
openField :: IO Field
openField = do
(dpy, win, bufs, gcs, ic, del, size) <- openWindow
let (ub, bb, tb) = (undoBuf bufs, bgBuf bufs, topBuf bufs)
(gcf, gcb) = (gcForeground gcs, gcBackground gcs)
sizeRef <- newIORef size
let getSize = readIORef sizeRef
ls <- newLayers 50
(getSize >>= uncurry (fillRectangle dpy ub gcb 0 0))
(getSize >>= \(w, h) -> copyArea dpy ub bb gcf 0 0 w h 0 0)
(getSize >>= \(w, h) -> copyArea dpy bb tb gcf 0 0 w h 0 0)
f <- makeField dpy win bufs gcs ic del sizeRef ls
_ <- forkIOX $ runLoop f
flush dpy
return f
waitInput :: Field -> IO (Chan Bool, Chan ())
waitInput f = do
go <- newChan
empty <- newChan
tid <- forkIOX $ forever $ do
waitEvent $ fDisplay f
writeChan go True
readChan empty
_ <- forkIO $ do
readChan $ fClose f
killThread tid
writeChan go False
return (go, empty)
runLoop :: Field -> IO ()
runLoop f = allocaXEvent $ \e -> do
(go, empty) <- waitInput f
doWhile_ $ do
notEnd <- readChan go
cont <- doWhile True $ const $ do
evN <- pending $ fDisplay f
if evN > 0 then do
nextEvent (fDisplay f) e
filtered <- filterEvent e 0
if filtered then return (True, True)
else do ev <- getEvent e
c <- processEvent f e ev
return (c, c)
else return (True, False)
if notEnd && cont then writeChan empty () >> return True
else return False
readIORef (fRunning f) >>= mapM_ killThread
destroyWindow (fDisplay f) (fWindow f)
closeDisplay $ fDisplay f
writeChan (fEnd f) ()
processEvent :: Field -> XEventPtr -> Event -> IO Bool
processEvent f e ev = case ev of
ExposeEvent{} -> flushField f $ do
windowSize (fDisplay f) (fWindow f) >>= writeIORef (fSize f)
redrawLayers $ fLayers f
return True
KeyEvent{} -> do
(mstr, mks) <- utf8LookupString (fIC f) e
let str = fromMaybe "" mstr
_ks = fromMaybe xK_VoidSymbol mks
readIORef (fKeypress f) >>= fmap and . ($ str) . mapM
ButtonEvent{} -> do
pos <- center (ev_x ev) (ev_y ev)
let buttonN = fromIntegral $ ev_button ev
case ev_event_type ev of
et | et == buttonPress -> do
writeIORef (fPressed f) True
readIORef (fClick f) >>=
($ pos) . uncurry . ($ buttonN)
| et == buttonRelease -> do
writeIORef (fPressed f) False
readIORef (fRelease f) >>=
($ pos) . uncurry . ($ buttonN)
_ -> error "not implement event"
MotionEvent{} -> do
pos <- center (ev_x ev) (ev_y ev)
whenM (readIORef $ fPressed f) $
readIORef (fDrag f) >>= ($ pos) . uncurry
return True
ClientMessageEvent{} -> return $ convert (head $ ev_data ev) /= fDel f
_ -> return True
where
center x y = do
(w, h) <- fieldSize f
return (fromIntegral x w / 2, fromIntegral ( y) + h / 2)
closeField :: Field -> IO ()
closeField = flip writeChan () . fClose
waitField :: Field -> IO ()
waitField = readChan . fEnd
fieldSize :: Field -> IO (Double, Double)
fieldSize = fmap (fromIntegral *** fromIntegral) . readIORef . fSize
forkField :: Field -> IO () -> IO ThreadId
forkField f act = do
tid <- forkIOX act
modifyIORef (fRunning f) (tid :)
return tid
flushField :: Field -> IO a -> IO a
flushField f act = do
readChan $ fLock f
ret <- act
(w, h) <- readIORef $ fSize f
copyArea (fDisplay f) (topBuf $ fBufs f) (fWindow f)
(gcForeground $ fGCs f) 0 0 w h 0 0
flush $ fDisplay f
writeChan (fLock f) ()
return ret
fieldColor :: Field -> Layer -> Color -> IO ()
fieldColor f l c = setBackground l $ do
getColorPixel (fDisplay f) c >>=
maybe (return ())
(setForeground (fDisplay f) (gcBackground $ fGCs f))
readIORef (fSize f) >>= uncurry (fillRectangle
(fDisplay f) (undoBuf $ fBufs f) (gcBackground $ fGCs f) 0 0)
addLayer :: Field -> IO Layer
addLayer = makeLayer . fLayers
drawLine :: Field -> Layer -> Double -> Color ->
Double -> Double -> Double -> Double -> IO ()
drawLine f l lw clr x1 y1 x2 y2 =
addDraw l (drawLineBuf f undoBuf (round lw) clr x1 y1 x2 y2,
drawLineBuf f bgBuf (round lw) clr x1 y1 x2 y2)
writeString :: Field -> Layer -> String -> Double -> Color ->
Double -> Double -> String -> IO ()
writeString f l fname size clr xc yc str = addDraw l (ws undoBuf, ws bgBuf)
where ws bf = do
(x, y) <- topLeft f xc yc
writeStringXT (fDisplay f) (bf $ fBufs f) fname size clr x y str
fillPolygon :: Field -> Layer -> [(Double, Double)] -> Color -> IO ()
fillPolygon f l psc clr = addDraw l (fp undoBuf, fp bgBuf)
where fp bf = do
ps <- mapM (fmap (uncurry Point) . uncurry (topLeft f)) psc
getColorPixel (fDisplay f) clr >>= maybe (return ())
(setForeground (fDisplay f) (gcForeground $ fGCs f))
X.fillPolygon (fDisplay f) (bf $ fBufs f) (gcForeground $ fGCs f) ps
drawLineBuf :: Field -> (Bufs -> Pixmap) -> Int -> Color ->
Double -> Double -> Double -> Double -> IO ()
drawLineBuf f bf lw c x1_ y1_ x2_ y2_ = do
(x1, y1) <- topLeft f x1_ y1_
(x2, y2) <- topLeft f x2_ y2_
drawLineXT (fDisplay f) (gcForeground $ fGCs f) (bf $ fBufs f) lw c
x1 y1 x2 y2
topLeft :: Field -> Double -> Double -> IO (Position, Position)
topLeft f x y = do
(width, height) <- fieldSize f
return (round $ x + width / 2, round $ y + height / 2)
addCharacter :: Field -> IO Character
addCharacter = makeCharacter . fLayers
drawCharacter :: Field -> Character -> Color -> [(Double, Double)] -> IO ()
drawCharacter f c clr sh = setCharacter c $ drawShape f clr sh
drawCharacterAndLine :: Field -> Character -> Color -> [(Double, Double)] ->
Double -> Double -> Double -> Double -> Double -> IO ()
drawCharacterAndLine f c clr sh lw x1 y1 x2 y2 = setCharacter c $
drawShape f clr sh >> drawLineBuf f topBuf (round lw) clr x1 y1 x2 y2
drawShape :: Field -> Color -> [(Double, Double)] -> IO ()
drawShape f clr psc = do
ps <- mapM (fmap (uncurry Point) . uncurry (topLeft f)) psc
getColorPixel (fDisplay f) clr >>= maybe (return ())
(setForeground (fDisplay f) (gcForeground $ fGCs f))
X.fillPolygon (fDisplay f) (topBuf $ fBufs f) (gcForeground $ fGCs f) ps
clearCharacter :: Character -> IO ()
clearCharacter c = setCharacter c $ return ()
onclick, onrelease :: Field -> (Int -> Double -> Double -> IO Bool) -> IO ()
(onclick, onrelease) = (writeIORef .) *** (writeIORef .) $ (fClick, fRelease)
ondrag :: Field -> (Double -> Double -> IO ()) -> IO ()
ondrag = writeIORef . fDrag
onkeypress :: Field -> (Char -> IO Bool) -> IO ()
onkeypress = writeIORef . fKeypress