module Graphics.X11.Turtle.Field(
Field,
Layer,
Character,
Coordinates(..),
openField,
closeField,
waitField,
topleft,
center,
coordinates,
fieldSize,
forkField,
flushField,
fieldColor,
addLayer,
drawLine,
fillRectangle,
fillPolygon,
writeString,
drawImage,
undoLayer,
clearLayer,
addCharacter,
drawCharacter,
drawCharacterAndLine,
clearCharacter,
onclick,
onrelease,
ondrag,
onmotion,
onkeypress,
ontimer
) where
import Graphics.X11.Turtle.XTools(
Display, Window, Pixmap, Atom, Point(..), PositionXT, Dimension,
XEventPtr, Event(..), XIC, Bufs, undoBuf, bgBuf, topBuf,
GCs, gcForeground, gcBackground,
forkIOX, openWindow, destroyWindow, closeDisplay, windowSize,
flush, setForegroundXT, copyAreaXT,
drawLineXT, fillRectangleXT, fillPolygonXT, writeStringXT, drawImageXT,
allocaXEvent, waitEvent, pending, nextEvent, getEvent, filterEvent,
utf8LookupString, buttonPress, buttonRelease, xK_VoidSymbol)
import Graphics.X11.Turtle.Layers(
Layers, Layer, Character, newLayers, redrawLayers,
makeLayer, background, addDraw, undoLayer, clearLayer,
makeCharacter, character)
import Text.XML.YJSVG(Position(..), Color(..))
import Control.Monad(when, unless, forever, replicateM, forM_, join)
import Control.Monad.Tools(doWhile_, doWhile)
import Control.Arrow((***))
import Control.Concurrent(
ThreadId, forkIO, killThread, threadDelay,
Chan, newChan, readChan, writeChan)
import Data.IORef(IORef, newIORef, readIORef, writeIORef)
import Data.IORef.Tools(atomicModifyIORef_)
import Data.Maybe(fromMaybe)
import Data.List(delete)
import Data.Convertible(convert)
import Data.Function.Tools(const2, const3)
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 (Int -> Double -> Double -> IO ()),
fPressed :: IORef [Int],
fMotion :: IORef (Double -> Double -> IO ()),
fKeypress :: IORef (Char -> IO Bool), fTimerEvent :: IORef (IO Bool),
fLayers :: IORef Layers, fCoordinates :: IORef Coordinates,
fInput :: Chan InputType, fLock, fClose, fEnd :: Chan (),
fRunning :: IORef [ThreadId]}
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 $ const3 $ return True
drag <- newIORef $ const3 $ return ()
pressed <- newIORef []
motion <- newIORef $ const2 $ return ()
keypress <- newIORef $ const $ return True
timer <- newIORef $ return True
input <- newChan
coord <- newIORef CoordCenter
[lock, close, end] <- replicateM 3 newChan
running <- newIORef []
writeChan lock ()
return Field{
fDisplay = dpy, fWindow = win, fBufs = bufs, fGCs = gcs,
fIC = ic, fDel = del, fSize = sizeRef,
fClick = click, fRelease = release,
fDrag = drag, fPressed = pressed,
fMotion = motion, fKeypress = keypress, fTimerEvent = timer,
fLayers = ls, fCoordinates = coord, fInput = input,
fLock = lock, fClose = close, fEnd = end, fRunning = running}
setPressed :: Field -> Int -> Bool -> IO ()
setPressed f buttonN True = atomicModifyIORef_ (fPressed f) (buttonN :)
setPressed f buttonN False = atomicModifyIORef_ (fPressed f) (delete buttonN)
killRunning :: Field -> IO ()
killRunning f = readIORef (fRunning f) >>= mapM_ killThread
data Coordinates = CoordCenter | CoordTopLeft
openField :: IO Field
openField = do
(dpy, win, bufs, gcs, ic, del, size) <- openWindow
sizeRef <- newIORef size
let (ub, bb, tb) = (undoBuf bufs, bgBuf bufs, topBuf bufs)
(gcf, gcb) = (gcForeground gcs, gcBackground gcs)
lyrs <- newLayers 50 (setForegroundXT dpy gcb (RGB 255 255 255) >>
readIORef sizeRef >>= uncurry (fillRectangleXT dpy ub gcb 0 0))
(readIORef sizeRef >>= uncurry (copyAreaXT dpy ub bb gcf))
(readIORef sizeRef >>= uncurry (copyAreaXT dpy bb tb gcf))
f <- makeField dpy win bufs gcs ic del sizeRef lyrs
_ <- forkIOX $ runLoop f
flush dpy
return f
data InputType = XInput | End | Timer
waitInput :: Field -> IO (Chan ())
waitInput f = do
empty <- newChan
tid <- forkIOX $ forever $ do
waitEvent (fDisplay f) >> writeChan (fInput f) XInput
readChan empty
atomicModifyIORef_ (fRunning f) (tid :)
_ <- forkIO $
readChan (fClose f) >> killRunning f >> writeChan (fInput f) End
return empty
runLoop :: Field -> IO ()
runLoop f = allocaXEvent $ \e -> do
empty <- waitInput f
doWhile_ $ do
iType <- readChan $ fInput f
case iType of
End -> return False
Timer -> do
cont <- join $ readIORef $ fTimerEvent f
unless cont $ killRunning f
return cont
XInput -> do
cont <- processXInput f e
when cont $ writeChan empty ()
return cont
destroyWindow (fDisplay f) (fWindow f)
closeDisplay $ fDisplay f
writeChan (fEnd f) ()
processXInput :: Field -> XEventPtr -> IO Bool
processXInput f e = doWhile undefined $ const $ do
evN <- pending $ fDisplay f
if evN <= 0 then return (True, False) else do
nextEvent (fDisplay f) e
filtered <- filterEvent e 0
if filtered then return (undefined, True) else do
ev <- getEvent e
c <- processEvent f e ev
unless c $ killRunning f
return (c && undefined, c)
processEvent :: Field -> XEventPtr -> Event -> IO Bool
processEvent f e ev = case ev of
ExposeEvent{} -> flushField f True $ 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
let buttonN = fromIntegral $ ev_button ev
pos <- getEventXY f ev
case ev_event_type ev of
et | et == buttonPress -> do
setPressed f buttonN True
readIORef (fClick f) >>=
($ pos) . uncurry . ($ buttonN)
| et == buttonRelease -> do
setPressed f buttonN False
readIORef (fRelease f) >>=
($ pos) . uncurry . ($ buttonN)
_ -> error "not implement event"
MotionEvent{} -> do
pos <- getEventXY f ev
pressed <- readIORef $ fPressed f
forM_ pressed $ \bn -> readIORef (fDrag f) >>=
($ pos) . uncurry . ($ bn)
readIORef (fMotion f) >>= ($ pos) . uncurry
return True
ClientMessageEvent{} -> return $ convert (head $ ev_data ev) /= fDel f
_ -> return True
getEventXY :: Field -> Event -> IO (Double, Double)
getEventXY f ev = do
let [x, y] = map (fromIntegral . ($ ev)) [ev_x, ev_y]
coord <- readIORef $ fCoordinates f
case coord of
CoordCenter -> do
(w, h) <- fieldSize f
return (x w / 2, h / 2 y)
CoordTopLeft -> return (x, y)
closeField :: Field -> IO ()
closeField = flip writeChan () . fClose
waitField :: Field -> IO ()
waitField = readChan . fEnd
topleft, center :: Field -> IO ()
topleft = flip (writeIORef . fCoordinates) CoordTopLeft
center = flip (writeIORef . fCoordinates) CoordCenter
coordinates :: Field -> IO Coordinates
coordinates = readIORef . fCoordinates
fieldSize :: Field -> IO (Double, Double)
fieldSize = fmap (fromIntegral *** fromIntegral) . readIORef . fSize
forkField :: Field -> IO () -> IO ThreadId
forkField f act = do
tid <- forkIOX act
atomicModifyIORef_ (fRunning f) (tid :) >> return tid
flushField :: Field -> Bool -> IO a -> IO a
flushField f@Field{fDisplay = dpy, fWindow = win} real act = do
ret <- readChan (fLock f) >> act
when real $ do
let (tb, gc) = (topBuf $ fBufs f, gcForeground $ fGCs f)
uncurry (copyAreaXT dpy tb win gc) =<< readIORef (fSize f)
flush $ fDisplay f
writeChan (fLock f) () >> return ret
fieldColor :: Field -> Layer -> Color -> IO ()
fieldColor f@Field{fDisplay = dpy} l clr = background l $ do
let (ub, gc) = (undoBuf $ fBufs f, gcBackground $ fGCs f)
setForegroundXT dpy gc clr
uncurry (fillRectangleXT dpy ub gc 0 0) =<< readIORef (fSize f)
addLayer :: Field -> IO Layer
addLayer = makeLayer . fLayers
drawLayer :: Field -> Layer -> (Pixmap -> IO ()) -> IO ()
drawLayer Field{fBufs = bs} l drw = addDraw l (drw $ undoBuf bs, drw $ bgBuf bs)
drawLine :: Field -> Layer -> Double -> Color -> Position -> Position -> IO ()
drawLine f l w c p q = drawLayer f l $ \buf -> drawLineBuf f buf (round w) c p q
drawLineBuf :: Field -> Pixmap -> Int -> Color -> Position -> Position -> IO ()
drawLineBuf f@Field{fDisplay = dpy} buf lw clr p q = do
(x1, y1) <- getPosition f p
(x2, y2) <- getPosition f q
drawLineXT dpy (gcForeground $ fGCs f) buf lw clr x1 y1 x2 y2
writeString :: Field -> Layer -> String -> Double -> Color -> Position ->
String -> IO ()
writeString f@Field{fDisplay = dpy} l fname size clr pos str =
drawLayer f l $ \buf -> getPosition f pos >>=
flip (uncurry $ writeStringXT dpy buf fname size clr) str
drawImage :: Field -> Layer -> FilePath -> Position -> Double -> Double -> IO ()
drawImage f@Field{fDisplay = dpy} l fp pos w h = drawLayer f l $ \buf -> do
(x, y) <- getPosition f pos
drawImageXT dpy buf (gcForeground $ fGCs f) fp x y (round w) (round h)
fillRectangle :: Field -> Layer -> Position -> Double -> Double -> Color -> IO ()
fillRectangle f@Field{fDisplay = dpy} l p w h clr = drawLayer f l $ \buf -> do
(x, y) <- getPosition f p
setForegroundXT dpy (gcForeground $ fGCs f) clr
fillRectangleXT dpy buf (gcForeground $ fGCs f) x y (round w) (round h)
fillPolygon :: Field -> Layer -> [Position] -> Color -> IO ()
fillPolygon f l ps clr = drawLayer f l $ \buf -> fillPolygonBuf f buf clr ps
fillPolygonBuf :: Field -> Pixmap -> Color -> [Position] -> IO ()
fillPolygonBuf f@Field{fDisplay = dpy} buf clr positions = do
ps <- mapM (fmap (uncurry Point) . getPosition f) positions
setForegroundXT dpy (gcForeground $ fGCs f) clr
fillPolygonXT dpy buf (gcForeground $ fGCs f) ps
getPosition :: Field -> Position -> IO (PositionXT, PositionXT)
getPosition f (Center x y) = do
(w, h) <- fieldSize f
return (round x + round (w / 2), round y + round (h / 2))
getPosition _ (TopLeft x y) = return (round x, round y)
addCharacter :: Field -> IO Character
addCharacter = makeCharacter . fLayers
drawCharacter :: Field -> Character -> Color -> [Position] -> IO ()
drawCharacter f ch c = character ch . fillPolygonBuf f (topBuf $ fBufs f) c
drawCharacterAndLine :: Field -> Character -> Color -> [Position] ->
Double -> Position -> Position -> IO ()
drawCharacterAndLine f ch clr sh lw p q = character ch $ do
fillPolygonBuf f (topBuf $ fBufs f) clr sh
drawLineBuf f (topBuf $ fBufs f) (round lw) clr p q
clearCharacter :: Character -> IO ()
clearCharacter ch = character ch $ return ()
onclick, onrelease :: Field -> (Int -> Double -> Double -> IO Bool) -> IO ()
[onclick, onrelease] = map (writeIORef .) [fClick, fRelease]
ondrag :: Field -> (Int -> Double -> Double -> IO ()) -> IO ()
ondrag = writeIORef . fDrag
onmotion :: Field -> (Double -> Double -> IO ()) -> IO ()
onmotion = writeIORef . fMotion
onkeypress :: Field -> (Char -> IO Bool) -> IO ()
onkeypress = writeIORef . fKeypress
ontimer :: Field -> Int -> IO Bool -> IO ()
ontimer f t fun = do
writeIORef (fTimerEvent f) fun
_ <- forkIO $ threadDelay (t * 1000) >> writeChan (fInput f) Timer
return ()