diff --git a/src/Graphics/X11/Turtle.hs b/src/Graphics/X11/Turtle.hs --- a/src/Graphics/X11/Turtle.hs +++ b/src/Graphics/X11/Turtle.hs @@ -93,19 +93,19 @@ ) where import Graphics.X11.Turtle.Data(shapeTable, speedTable) -import Graphics.X11.Turtle.Input( - TurtleState, TurtleInput(..), - turtleSeries, direction, visible, undonum, drawed, polyPoints) -import qualified Graphics.X11.Turtle.Input as S(position, degrees, pendown) +import Graphics.X11.Turtle.State( + TurtleState, direction, visible, undonum, drawed, polyPoints) +import qualified Graphics.X11.Turtle.State as S(position, degrees, pendown) +import Graphics.X11.Turtle.Input(TurtleInput(..), turtleSeries) import Graphics.X11.Turtle.Move( - Field, Coordinates(..), openField, closeField, fieldSize, - coordinates, topleft, center, waitField, forkField, flushField, + Field, Coordinates(..), openField, closeField, waitField, + topleft, center, coordinates, fieldSize, forkField, flushField, addLayer, clearLayer, addCharacter, clearCharacter, moveTurtle, onclick, onrelease, ondrag, onmotion, onkeypress, ontimer) import Text.XML.YJSVG(SVG(..), Position(..), Color(..)) import qualified Text.XML.YJSVG as S(center, topleft) -import Control.Concurrent(killThread, writeChan) +import Control.Concurrent(killThread, newChan, writeChan, getChanContents) import Control.Monad(replicateM_, zipWithM_) import Control.Arrow((&&&)) import Data.IORef(IORef, newIORef, readIORef) @@ -115,7 +115,7 @@ -------------------------------------------------------------------------------- xturtleVersion :: (Int, String) -xturtleVersion = (65, "0.1.9") +xturtleVersion = (69, "0.1.11") -------------------------------------------------------------------------------- @@ -138,7 +138,8 @@ newTurtle :: Field -> IO Turtle newTurtle f = do index <- newIORef 1; shapesRef <- newIORef shapeTable - (chan, hist, states) <- turtleSeries + chan <- newChan; hist <- getChanContents chan + let states = turtleSeries hist l <- addLayer f; c <- addCharacter f thr <- forkField f $ zipWithM_ (moveTurtle f c l) states $ tail states let t = Turtle { @@ -326,8 +327,8 @@ isvisible = flip info visible windowWidth, windowHeight :: Turtle -> IO Double -windowWidth = fmap fst . fieldSize . field -windowHeight = fmap snd . fieldSize . field +windowWidth = fmap fst . windowSize +windowHeight = fmap snd . windowSize windowSize :: Turtle -> IO (Double, Double) windowSize = fieldSize . field diff --git a/src/Graphics/X11/Turtle/Data.hs b/src/Graphics/X11/Turtle/Data.hs --- a/src/Graphics/X11/Turtle/Data.hs +++ b/src/Graphics/X11/Turtle/Data.hs @@ -1,7 +1,6 @@ module Graphics.X11.Turtle.Data( -- * tables - shapeTable, speedTable -) where + shapeTable, speedTable) where import Control.Arrow(second, (&&&)) diff --git a/src/Graphics/X11/Turtle/Field.hs b/src/Graphics/X11/Turtle/Field.hs --- a/src/Graphics/X11/Turtle/Field.hs +++ b/src/Graphics/X11/Turtle/Field.hs @@ -46,10 +46,10 @@ import Graphics.X11.Turtle.XTools( Display, Window, Pixmap, Atom, Point(..), PositionXT, Dimension, - XEventPtr, XIC, Bufs, undoBuf, bgBuf, topBuf, - GCs, gcForeground, gcBackground, Event(..), + XEventPtr, Event(..), XIC, Bufs, undoBuf, bgBuf, topBuf, + GCs, gcForeground, gcBackground, forkIOX, openWindow, destroyWindow, closeDisplay, windowSize, - flush, copyArea, setForegroundXT, + flush, setForegroundXT, copyAreaXT, drawLineXT, fillRectangleXT, fillPolygonXT, writeStringXT, drawImageXT, allocaXEvent, waitEvent, pending, nextEvent, getEvent, filterEvent, utf8LookupString, buttonPress, buttonRelease, xK_VoidSymbol) @@ -59,8 +59,8 @@ makeCharacter, character) import Text.XML.YJSVG(Position(..), Color(..)) -import Control.Monad(when, unless, forever, replicateM, join) -import Control.Monad.Tools(doWhile_, doWhile, whenM) +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, @@ -68,7 +68,9 @@ 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) -------------------------------------------------------------------------------- @@ -77,23 +79,24 @@ fIC :: XIC, fDel :: Atom, fSize :: IORef (Dimension, Dimension), fClick, fRelease :: IORef (Int -> Double -> Double -> IO Bool), - fDrag, fMotion :: IORef (Double -> Double -> IO ()), - fKeypress :: IORef (Char -> IO Bool), - fTimerEvent :: IORef (IO Bool), - fPressed :: IORef 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, fInput :: Chan InputType, - fCoordinates :: IORef Coordinates, fLock, fClose, fEnd :: Chan (), + 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 $ \_ _ _ -> return True - [drag, motion] <- replicateM 2 $ newIORef $ \_ _ -> return () - keypress <- newIORef $ \_ -> return True + [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 - pressed <- newIORef False input <- newChan coord <- newIORef CoordCenter [lock, close, end] <- replicateM 3 newChan @@ -103,37 +106,35 @@ fDisplay = dpy, fWindow = win, fBufs = bufs, fGCs = gcs, fIC = ic, fDel = del, fSize = sizeRef, - fClick = click, fRelease = release, fDrag = drag, + fClick = click, fRelease = release, + fDrag = drag, fPressed = pressed, fMotion = motion, fKeypress = keypress, fTimerEvent = timer, - fPressed = pressed, - fLayers = ls, fInput = input, fCoordinates = coord, + fLayers = ls, fCoordinates = coord, fInput = input, fLock = lock, fClose = close, fEnd = end, fRunning = running} -data Coordinates = CoordCenter | CoordTopLeft +setPressed :: Field -> Int -> Bool -> IO () +setPressed f buttonN True = atomicModifyIORef_ (fPressed f) (buttonN :) +setPressed f buttonN False = atomicModifyIORef_ (fPressed f) (delete buttonN) -coordinates :: Field -> IO Coordinates -coordinates = readIORef . fCoordinates +killRunning :: Field -> IO () +killRunning f = readIORef (fRunning f) >>= mapM_ killThread -topleft, center :: Field -> IO () -topleft = flip (writeIORef . fCoordinates) CoordTopLeft -center = flip (writeIORef . fCoordinates) CoordCenter +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) - sizeRef <- newIORef size - let getSize = readIORef sizeRef - ls <- newLayers 50 - (setForegroundXT dpy gcb (RGB 255 255 255) >> - getSize >>= uncurry (fillRectangleXT 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 + 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 @@ -144,14 +145,11 @@ waitInput f = do empty <- newChan tid <- forkIOX $ forever $ do - waitEvent $ fDisplay f - writeChan (fInput f) XInput + waitEvent (fDisplay f) >> writeChan (fInput f) XInput readChan empty atomicModifyIORef_ (fRunning f) (tid :) - _ <- forkIO $ do - readChan $ fClose f - killThread tid - writeChan (fInput f) End + _ <- forkIO $ + readChan (fClose f) >> killRunning f >> writeChan (fInput f) End return empty runLoop :: Field -> IO () @@ -159,28 +157,32 @@ empty <- waitInput f doWhile_ $ do iType <- readChan $ fInput f - cont <- case iType of + case iType of End -> return False Timer -> do - c <- join $ readIORef $ fTimerEvent f - unless c $ readIORef (fRunning f) - >>= mapM_ killThread - return c - XInput -> 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 (True, True) - else do ev <- getEvent e - c <- processEvent f e ev - return (c, c) - if cont then writeChan empty () >> return True else return False - readIORef (fRunning f) >>= mapM_ killThread + 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 @@ -192,41 +194,51 @@ _ks = fromMaybe xK_VoidSymbol mks readIORef (fKeypress f) >>= fmap and . ($ str) . mapM ButtonEvent{} -> do - coord <- readIORef $ fCoordinates f - pos <- case coord of - CoordCenter -> cntr (ev_x ev) (ev_y ev) - CoordTopLeft -> return - (fromIntegral $ ev_x ev, fromIntegral $ ev_y ev) - let buttonN = fromIntegral $ ev_button ev + let buttonN = fromIntegral $ ev_button ev + pos <- getEventXY f ev case ev_event_type ev of et | et == buttonPress -> do - writeIORef (fPressed f) True + setPressed f buttonN True readIORef (fClick f) >>= ($ pos) . uncurry . ($ buttonN) | et == buttonRelease -> do - writeIORef (fPressed f) False + setPressed f buttonN False readIORef (fRelease f) >>= ($ pos) . uncurry . ($ buttonN) _ -> error "not implement event" MotionEvent{} -> do - pos <- cntr (ev_x ev) (ev_y ev) - whenM (readIORef $ fPressed f) $ - readIORef (fDrag f) >>= ($ pos) . uncurry + 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 - where - cntr x y = do - (w, h) <- fieldSize f - return (fromIntegral x - w / 2, fromIntegral (- y) + h / 2) +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 @@ -238,20 +250,19 @@ atomicModifyIORef_ (fRunning f) (tid :) >> return tid flushField :: Field -> Bool -> IO a -> IO a -flushField f real act = do +flushField f@Field{fDisplay = dpy, fWindow = win} real act = do ret <- readChan (fLock f) >> act when real $ do - (w, h) <- readIORef $ fSize f - copyArea (fDisplay f) (topBuf $ fBufs f) (fWindow f) - (gcForeground $ fGCs f) 0 0 w h 0 0 + 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 l clr = background l $ do - setForegroundXT (fDisplay f) (gcBackground $ fGCs f) clr - readIORef (fSize f) >>= uncurry (fillRectangleXT - (fDisplay f) (undoBuf $ fBufs f) (gcBackground $ fGCs f) 0 0) +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) -------------------------------------------------------------------------------- @@ -259,13 +270,17 @@ addLayer = makeLayer . fLayers drawLayer :: Field -> Layer -> (Pixmap -> IO ()) -> IO () -drawLayer Field{fBufs = bufs} l draw = - addDraw l (draw $ undoBuf bufs, draw $ bgBuf bufs) +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 lw clr p1 p2 = - drawLayer f l $ \buf -> drawLineBuf f buf (round lw) clr p1 p2 +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 = @@ -277,24 +292,21 @@ (x, y) <- getPosition f pos drawImageXT dpy buf (gcForeground $ fGCs f) fp x y (round w) (round h) -fillPolygon :: Field -> Layer -> [Position] -> Color -> IO () -fillPolygon f@Field{fDisplay = dpy} l positions clr = drawLayer f l $ \buf -> do - ps <- mapM (fmap (uncurry Point) . getPosition f) positions - setForegroundXT dpy (gcForeground $ fGCs f) clr - fillPolygonXT dpy buf (gcForeground $ fGCs f) ps - 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) -drawLineBuf :: Field -> Pixmap -> Int -> Color -> Position -> Position -> IO () -drawLineBuf f@Field{fDisplay = dpy} buf lw clr p1 p2 = do - (x1, y1) <- getPosition f p1 - (x2, y2) <- getPosition f p2 - drawLineXT dpy (gcForeground $ fGCs f) buf lw clr x1 y1 x2 y2 +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 @@ -307,36 +319,33 @@ addCharacter = makeCharacter . fLayers drawCharacter :: Field -> Character -> Color -> [Position] -> IO () -drawCharacter f c clr sh = character c $ drawShape f clr sh +drawCharacter f ch c = character ch . fillPolygonBuf f (topBuf $ fBufs f) c drawCharacterAndLine :: Field -> Character -> Color -> [Position] -> Double -> Position -> Position -> IO () -drawCharacterAndLine f c clr sh lw p1 p2 = character c $ do - drawShape f clr sh - drawLineBuf f (topBuf $ fBufs f) (round lw) clr p1 p2 - -drawShape :: Field -> Color -> [Position] -> IO () -drawShape f clr positions = do - ps <- mapM (fmap (uncurry Point) . getPosition f) positions - setForegroundXT (fDisplay f) (gcForeground $ fGCs f) clr - fillPolygonXT (fDisplay f) (topBuf $ fBufs f) (gcForeground $ fGCs f) ps +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 c = character c $ return () +clearCharacter ch = character ch $ return () -------------------------------------------------------------------------------- onclick, onrelease :: Field -> (Int -> Double -> Double -> IO Bool) -> IO () -(onclick, onrelease) = (writeIORef . fClick, writeIORef . fRelease) +[onclick, onrelease] = map (writeIORef .) [fClick, fRelease] -ondrag, onmotion :: Field -> (Double -> Double -> IO ()) -> IO () -(ondrag, onmotion) = (writeIORef . fDrag, writeIORef . fMotion) +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 - threadDelay $ t * 1000 - writeChan (fInput f) Timer + _ <- forkIO $ threadDelay (t * 1000) >> writeChan (fInput f) Timer + return () diff --git a/src/Graphics/X11/Turtle/Input.hs b/src/Graphics/X11/Turtle/Input.hs --- a/src/Graphics/X11/Turtle/Input.hs +++ b/src/Graphics/X11/Turtle/Input.hs @@ -1,31 +1,14 @@ -module Graphics.X11.Turtle.Input( - -- * types - TurtleState, - TurtleInput(..), - - -- * get TurtlsStates in timeline - turtleSeries, - - -- * read TurtleState members - position, - direction, - degrees, - pendown, - visible, - undonum, - drawed, - polyPoints -) where +module Graphics.X11.Turtle.Input(TurtleInput(..), turtleSeries) where -import Graphics.X11.Turtle.State(TurtleState(..), initialTurtleState, makeShape) +import Graphics.X11.Turtle.State(TurtleState(..), initTurtleState, makeShape) import Text.XML.YJSVG(SVG(..), Color(..), Position(..)) -import Control.Concurrent.Chan(Chan, newChan, getChanContents) -------------------------------------------------------------------------------- data TurtleInput = Goto Position | Forward Double + | RotateRad Double | Rotate Double | TurnLeft Double | Dot Double @@ -52,31 +35,29 @@ | Degrees Double deriving (Show, Read) -turtleSeries :: IO (Chan TurtleInput, [TurtleInput], [TurtleState]) -turtleSeries = do - let ts0 = initialTurtleState - c <- newChan - tis <- getChanContents c - return (c, tis, ts0 : ts0 : inputToTurtle [] ts0 tis) +turtleSeries :: [TurtleInput] -> [TurtleState] +turtleSeries tis = let ts0 = initTurtleState in ts0 : ts0 : turtles [] ts0 tis -inputToTurtle :: [TurtleState] -> TurtleState -> [TurtleInput] -> [TurtleState] -inputToTurtle [] ts0 (Undo : tis) = ts0 : inputToTurtle [] ts0 tis -inputToTurtle (tsb : tsbs) _ (Undo : tis) = - let ts1 = tsb{undo = True} in ts1 : inputToTurtle tsbs ts1 tis -inputToTurtle tsbs ts0 (Forward len : tis) = case position ts0 of +turtles :: [TurtleState] -> TurtleState -> [TurtleInput] -> [TurtleState] +turtles [] ts0 (Undo : tis) = ts0 : turtles [] ts0 tis +turtles (tsb : tsbs) _ (Undo : tis) = + let ts1 = tsb{undo = True} in ts1 : turtles tsbs ts1 tis +turtles tsbs ts0 (Forward len : tis) = case position ts0 of Center x0 y0 -> let x = x0 + len * cos (direction ts0) y = y0 + len * sin (direction ts0) in - inputToTurtle tsbs ts0 $ Goto (Center x y) : tis + turtles tsbs ts0 $ Goto (Center x y) : tis TopLeft x0 y0 -> let x = x0 + len * cos (direction ts0) y = y0 - len * sin (direction ts0) in - inputToTurtle tsbs ts0 $ Goto (TopLeft x y) : tis -inputToTurtle tsbs ts0 (TurnLeft dd : tis) = inputToTurtle tsbs ts0 $ - Rotate (direction ts0 * degrees ts0 / (2 * pi) + dd) : tis -inputToTurtle tsbs ts0 (ti : tis) = - let ts1 = nextTurtle ts0 ti in ts1 : inputToTurtle (ts0 : tsbs) ts1 tis -inputToTurtle _ _ [] = error "no more input" + turtles tsbs ts0 $ Goto (TopLeft x y) : tis +turtles tsbs ts0 (Rotate dir : tis) = turtles tsbs ts0 $ + RotateRad (dir * 2 * pi / degrees ts0) : tis +turtles tsbs ts0 (TurnLeft dd : tis) = turtles tsbs ts0 $ + RotateRad (direction ts0 + dd * 2 * pi / degrees ts0) : tis +turtles tsbs ts0 (ti : tis) = + let ts1 = nextTurtle ts0 ti in ts1 : turtles (ts0 : tsbs) ts1 tis +turtles _ _ [] = error "no more input" reset :: TurtleState -> TurtleState reset t = t{draw = Nothing, clear = False, undo = False, undonum = 1, @@ -91,13 +72,13 @@ polyPoints = (if poly t then (pos :) else id) $ polyPoints t} `set` if not $ pendown t then Nothing else Just $ Line pos (position t) (pencolor t) (pensize t) -nextTurtle t (Rotate dir) = (reset t){direction = dir * 2 * pi / degrees t} -nextTurtle t (Dot sz) = - reset t `set` Just (Rect (position t) sz sz 0 (pencolor t) (pencolor t)) +nextTurtle t (RotateRad dir) = (reset t){direction = dir} +nextTurtle t@TurtleState{pencolor = clr} (Dot sz) = reset t `set` + Just (Rect (position t) sz sz 0 clr clr) nextTurtle t@TurtleState{pencolor = clr} Stamp = reset t `set` Just (Polyline (makeShape t (direction t) (position t)) clr clr 0) -nextTurtle t (Write fnt sz str) = - reset t `set` Just (Text (position t) sz (pencolor t) fnt str) +nextTurtle t@TurtleState{pencolor = clr} (Write fnt sz str) = reset t `set` + Just (Text (position t) sz clr fnt str) nextTurtle t (PutImage fp w h) = reset t `set` Just (Image (position t) w h fp) nextTurtle t (Undonum un) = (reset t){undonum = un} nextTurtle t Clear = (reset t){clear = True, drawed = [last $ drawed t]} @@ -112,8 +93,8 @@ nextTurtle t (SetPendown pd) = (reset t){pendown = pd} nextTurtle t (SetVisible v) = (reset t){visible = v} nextTurtle t (SetFill fl) = (reset t){fill = fl, fillPoints = [position t | fl]} - `set` (if not (fill t) || fl then Nothing - else Just $ Polyline (fillPoints t) (pencolor t) (pencolor t) 0) + `set` (if not (fill t) || fl then Nothing else + Just $ Polyline (fillPoints t) (pencolor t) (pencolor t) 0) nextTurtle t (SetPoly p) = (reset t){ poly = p, polyPoints = if p then [position t] else polyPoints t} nextTurtle t (SetFlush ss) = (reset t){stepbystep = ss} diff --git a/src/Graphics/X11/Turtle/Layers.hs b/src/Graphics/X11/Turtle/Layers.hs --- a/src/Graphics/X11/Turtle/Layers.hs +++ b/src/Graphics/X11/Turtle/Layers.hs @@ -26,63 +26,48 @@ -------------------------------------------------------------------------------- data Layers = Layers{ - backgrounds :: [IO ()], - buffers :: [IO ()], - layers :: [[(IO (), IO ())]], - characters :: [IO ()], - buffSize :: Int, - clearBuffers :: IO (), - clearLayers :: IO (), - clearCharacters :: IO ()} - -data Layer = Layer{ - layerId :: Int, - layerLayers :: IORef Layers - } + bgs :: [IO ()], buffs :: [IO ()], layers :: [[(IO (), IO ())]], + chars :: [IO ()], buffSize :: Int, + clearBuffers :: IO (), clearLayers :: IO (), clearCharacters :: IO ()} -data Character = Character{ - characterId :: Int, - characterLayers :: IORef Layers - } +data Layer = Layer{layerId :: Int, layerLayers :: IORef Layers} +data Character = Character{charId :: Int, charLayers :: IORef Layers} -------------------------------------------------------------------------------- newLayers :: Int -> IO () -> IO () -> IO () -> IO (IORef Layers) newLayers bsize cbuf clyr cchr = newIORef Layers{ - backgrounds = [], - buffers = [], - layers = [], - characters = [], - buffSize = bsize, - clearBuffers = cbuf, - clearLayers = clyr, - clearCharacters = cchr} + bgs = [], buffs = [], layers = [], chars = [], buffSize = bsize, + clearBuffers = cbuf, clearLayers = clyr, clearCharacters = cchr} makeLayer :: IORef Layers -> IO Layer makeLayer rls = atomicModifyIORef rls $ \ls -> (ls{ - backgrounds = backgrounds ls ++[return ()], - buffers = buffers ls ++ [return ()], + bgs = bgs ls ++[return ()], buffs = buffs ls ++ [return ()], layers = layers ls ++ [[]]}, Layer{layerId = length $ layers ls, layerLayers = rls}) makeCharacter :: IORef Layers -> IO Character -makeCharacter rls = atomicModifyIORef rls $ \ls -> - (ls{characters = characters ls ++ [return ()]}, Character{ - characterId = length $ characters ls, - characterLayers = rls}) +makeCharacter rls = atomicModifyIORef rls $ \ls -> (ls{ + chars = chars ls ++ [return ()]}, + Character{charId = length $ chars ls, charLayers = rls}) -------------------------------------------------------------------------------- redrawLayers :: IORef Layers -> IO () redrawLayers rls = readIORef rls >>= \ls -> do - clearBuffers ls >> sequence_ (backgrounds ls) >> sequence_ (buffers ls) + clearBuffers ls >> sequence_ (bgs ls) >> sequence_ (buffs ls) clearLayers ls >> mapM_ snd (concat $ layers ls) - clearCharacters ls >> sequence_ (characters ls) + clearCharacters ls >> sequence_ (chars ls) +background :: Layer -> IO () -> IO () +background Layer{layerId = lid, layerLayers = rls} act = + atomicModifyIORef_ rls (\ls -> ls{bgs = setAt (bgs ls) lid act}) + >> redrawLayers rls + addDraw :: Layer -> (IO (), IO ()) -> IO () addDraw Layer{layerId = lid, layerLayers = rls} acts@(_, act) = do readIORef rls >>= \ls -> do - act >> clearCharacters ls >> sequence_ (characters ls) + act >> clearCharacters ls >> sequence_ (chars ls) unless (length (layers ls !! lid) < buffSize ls) $ fst $ head $ layers ls !! lid atomicModifyIORef_ rls $ \ls -> @@ -90,13 +75,7 @@ then ls{layers = modifyAt (layers ls) lid (++ [acts])} else let (a, _) : as = layers ls !! lid in ls{ layers = setAt (layers ls) lid $ as ++ [acts], - buffers = modifyAt (buffers ls) lid (>> a)} - -background :: Layer -> IO () -> IO () -background Layer{layerId = lid, layerLayers = rls} act = do - atomicModifyIORef_ rls $ \ls -> - ls{backgrounds = setAt (backgrounds ls) lid act} - redrawLayers rls + buffs = modifyAt (buffs ls) lid (>> a)} undoLayer :: Layer -> IO Bool undoLayer Layer{layerId = lid, layerLayers = rls} = do @@ -105,20 +84,17 @@ else (ls{layers = modifyAt (layers ls) lid init}, True) when done $ readIORef rls >>= \ls -> do clearLayers ls >> mapM_ snd (concat $ layers ls) - clearCharacters ls >> sequence_ (characters ls) + clearCharacters ls >> sequence_ (chars ls) return done clearLayer :: Layer -> IO () -clearLayer Layer{layerId = lid, layerLayers = rls} = do - atomicModifyIORef_ rls $ \ls -> ls{ - backgrounds = setAt (backgrounds ls) lid $ return (), - buffers = setAt (buffers ls) lid $ return (), - layers = setAt (layers ls) lid []} - redrawLayers rls +clearLayer Layer{layerId = lid, layerLayers = rls} = + atomicModifyIORef_ rls (\ls -> ls{ + bgs = setAt (bgs ls) lid $ return (), + buffs = setAt (buffs ls) lid $ return (), + layers = setAt (layers ls) lid []}) >> redrawLayers rls character :: Character -> IO () -> IO () -character Character{characterId = cid, characterLayers = rls} act = do - atomicModifyIORef_ rls $ \ls -> - ls{characters = setAt (characters ls) cid act} - readIORef rls >>= \ls -> - clearCharacters ls >> sequence_ (characters ls) +character Character{charId = cid, charLayers = rls} act = do + atomicModifyIORef_ rls $ \ls -> ls{chars = setAt (chars ls) cid act} + readIORef rls >>= \ls -> clearCharacters ls >> sequence_ (chars ls) diff --git a/src/Graphics/X11/Turtle/Move.hs b/src/Graphics/X11/Turtle/Move.hs --- a/src/Graphics/X11/Turtle/Move.hs +++ b/src/Graphics/X11/Turtle/Move.hs @@ -6,11 +6,11 @@ -- * process Field openField, closeField, - fieldSize, - coordinates, + waitField, topleft, center, - waitField, + coordinates, + fieldSize, -- * draws forkField, @@ -33,9 +33,9 @@ import Graphics.X11.Turtle.State(TurtleState(..), makeShape) import Graphics.X11.Turtle.Field( Field, Layer, Character, Coordinates(..), - openField, closeField, fieldSize, coordinates, topleft, center, - waitField, forkField, flushField, - addLayer, clearLayer, addCharacter, clearCharacter, + openField, closeField, waitField, coordinates, topleft, center, + fieldSize, forkField, flushField, addLayer, clearLayer, + addCharacter, clearCharacter, onclick, onrelease, ondrag, onmotion, onkeypress, ontimer, fieldColor, drawLine, fillRectangle, fillPolygon, writeString, drawImage, undoLayer, drawCharacter, drawCharacterAndLine) diff --git a/src/Graphics/X11/Turtle/State.hs b/src/Graphics/X11/Turtle/State.hs --- a/src/Graphics/X11/Turtle/State.hs +++ b/src/Graphics/X11/Turtle/State.hs @@ -1,9 +1,9 @@ module Graphics.X11.Turtle.State( - TurtleState(..), initialTurtleState, makeShape) where + TurtleState(..), initTurtleState, makeShape) where import Text.XML.YJSVG(Position(..), SVG(Fill), Color(RGB)) -import Control.Arrow((***)) import Data.Tuple.Tools(rotate) +import Control.Arrow((***)) data TurtleState = TurtleState { position :: Position, @@ -33,8 +33,8 @@ directionStep :: Maybe Double, interval :: Int} -initialTurtleState :: TurtleState -initialTurtleState = TurtleState { +initTurtleState :: TurtleState +initTurtleState = TurtleState { position = Center 0 0, direction = 0, degrees = 360, diff --git a/src/Graphics/X11/Turtle/XTools.hs b/src/Graphics/X11/Turtle/XTools.hs --- a/src/Graphics/X11/Turtle/XTools.hs +++ b/src/Graphics/X11/Turtle/XTools.hs @@ -30,7 +30,7 @@ -- * draw functions flush, setForegroundXT, - copyArea, + copyAreaXT, fillRectangleXT, fillPolygonXT, drawLineXT, @@ -50,8 +50,6 @@ xK_VoidSymbol, ) where -import Text.XML.YJSVG(Color(..)) - import Graphics.X11( Display, Drawable, Window, Pixmap, GC, Atom, Point(..), Position, Dimension, XEventPtr, @@ -79,7 +77,7 @@ import Graphics.Imlib( ImlibLoadError(..), loadImageWithErrorReturn, contextSetImage, imageGetWidth, imageGetHeight, imageGetData, createCroppedScaledImage) - +import Text.XML.YJSVG(Color(..)) import Numeric(showFFloat) import Control.Monad(forM_, replicateM) import Control.Monad.Tools(unlessM) @@ -88,8 +86,7 @@ import System.Posix.Types(Fd(..)) import Data.Word(Word32) import Data.Bits((.|.), shift) -import Data.IORef(newIORef, readIORef) -import Data.IORef.Tools(atomicModifyIORef_) +import Data.IORef(newIORef, readIORef, modifyIORef) import Foreign.Ptr(Ptr) import Foreign.Storable(peek) import Foreign.Marshal.Array(advancePtr) @@ -103,7 +100,7 @@ -------------------------------------------------------------------------------- forkIOX :: IO () -> IO ThreadId -forkIOX = (initThreads >>) . forkIO +forkIOX = forkIO . (initThreads >>) openWindow :: IO (Display, Window, Bufs, GCs, XIC, Atom, (Dimension, Dimension)) openWindow = do @@ -113,7 +110,7 @@ _ <- setLocaleModifiers "" dpy <- openDisplay "" del <- internAtom dpy "WM_DELETE_WINDOW" True - let scr = defaultScreen dpy + let scr = defaultScreen dpy root <- rootWindow dpy scr (rWidth, rHeight) <- windowSize dpy root bufs@[ub, bb, tb] <- replicateM 3 $ @@ -140,16 +137,20 @@ -------------------------------------------------------------------------------- setForegroundXT :: Display -> GC -> Color -> IO () -setForegroundXT dpy gc (RGB r g b) = - setForeground dpy gc $ shift (fromIntegral r) 16 .|. - shift (fromIntegral g) 8 .|. fromIntegral b -setForegroundXT dpy gc (ColorName cn) = - (allocNamedColor dpy (defaultColormap dpy $ defaultScreen dpy) cn - >>= setForeground dpy gc . color_pixel . fst) - `catch` const (putStrLn "no such color") +setForegroundXT dpy gc (RGB r_ g_ b_) = let + [r, g, b] = map fromIntegral [r_, g_, b_] in + setForeground dpy gc $ shift r 16 .|. shift g 8 .|. b +setForegroundXT dpy gc (ColorName cn) = let + cm = defaultColormap dpy $ defaultScreen dpy in + (allocNamedColor dpy cm cn >>= setForeground dpy gc . color_pixel . fst) + `catch` const (putStrLn "no such color") -fillRectangleXT :: Display -> Drawable -> GC -> - Position -> Position -> Dimension -> Dimension -> IO () +copyAreaXT :: Display -> Drawable -> Drawable -> GC -> + Dimension -> Dimension -> IO () +copyAreaXT dpy src dst gc w h = copyArea dpy src dst gc 0 0 w h 0 0 + +fillRectangleXT :: Display -> Drawable -> GC -> Position -> Position -> + Dimension -> Dimension -> IO () fillRectangleXT = fillRectangle fillPolygonXT :: Display -> Drawable -> GC -> [Point] -> IO () @@ -165,22 +166,19 @@ writeStringXT :: Display -> Drawable -> String -> Double -> Color -> Position -> Position -> String -> IO () writeStringXT dpy buf fname size clr x y str = do - let visual = defaultVisual dpy $ defaultScreen dpy - colormap = defaultColormap dpy $ defaultScreen dpy - font = fname ++ "-" ++ showFFloat (Just 0) size "" - xftDraw <- xftDrawCreate dpy buf visual colormap - xftFont <- xftFontOpen dpy (defaultScreenOfDisplay dpy) font - case clr of - RGB r g b -> withXftColorValue dpy visual colormap color $ \c -> - xftDrawString xftDraw c xftFont x y str - where - color = XRenderColor { + let vsl = defaultVisual dpy $ defaultScreen dpy + cm = defaultColormap dpy $ defaultScreen dpy + withColor = case clr of + RGB r g b -> withXftColorValue dpy vsl cm XRenderColor{ xrendercolor_red = fromIntegral r * 0x100, xrendercolor_blue = fromIntegral g * 0x100, xrendercolor_green = fromIntegral b * 0x100, xrendercolor_alpha = 0xffff} - ColorName cn -> withXftColorName dpy visual colormap cn $ \c -> - xftDrawString xftDraw c xftFont x y str + ColorName cn -> withXftColorName dpy vsl cm cn + draw <- xftDrawCreate dpy buf vsl cm + font <- xftFontOpen dpy (defaultScreenOfDisplay dpy) $ + fname ++ "-" ++ showFFloat (Just 0) size "" + withColor $ \c -> xftDrawString draw c font x y str drawImageXT :: Display -> Drawable -> GC -> FilePath -> Position -> Position -> Dimension -> Dimension -> IO () @@ -193,22 +191,21 @@ case err of ImlibLoadErrorNone -> do contextSetImage img - let zero = 0 :: Position w <- fmap fromIntegral imageGetWidth :: IO Dimension h <- fmap fromIntegral imageGetHeight :: IO Dimension img' <- createCroppedScaledImage zero zero w h nw nh contextSetImage img' fmap Just imageGetData _ -> print err >> return Nothing + where zero = 0 :: Position -drawBitmap :: Display -> Drawable -> GC -> Position -> Position -> Dimension -> - Dimension -> Ptr Word32 -> IO () -drawBitmap dpy win gc x0 y0 w_ h_ dat = do - ptr <- newIORef dat +drawBitmap :: Display -> Drawable -> GC -> Position -> Position -> + Dimension -> Dimension -> Ptr Word32 -> IO () +drawBitmap dpy win gc x y w_ h_ dat = newIORef dat >>= \ptr -> forM_ [0 .. w * h - 1] $ \i -> do readIORef ptr >>= peek >>= setForeground dpy gc - drawPoint dpy win gc (x0 + i `mod` w) (y0 + i `div` w) - atomicModifyIORef_ ptr $ flip advancePtr 1 + drawPoint dpy win gc (x + i `mod` w) (y + i `div` w) + modifyIORef ptr $ flip advancePtr 1 where [w, h] = map fromIntegral [w_, h_] -------------------------------------------------------------------------------- diff --git a/xturtle.cabal b/xturtle.cabal --- a/xturtle.cabal +++ b/xturtle.cabal @@ -2,7 +2,7 @@ cabal-version: >= 1.6 name: xturtle -version: 0.1.9 +version: 0.1.11 stability: experimental author: Yoshikuni Jujo maintainer: Yoshikuni Jujo @@ -30,7 +30,7 @@ library Hs-source-dirs: src Exposed-modules: Graphics.X11.Turtle - Build-depends: base > 3 && < 5, yjtools >= 0.9.15, convertible >= 1.0.8, X11, + Build-depends: base > 3 && < 5, yjtools >= 0.9.16, convertible >= 1.0.8, X11, X11-xft <= 3.1, x11-xim, setlocale, yjsvg >= 0.1.14, Imlib >= 0.1.2 Ghc-options: -Wall Other-modules: Graphics.X11.Turtle.Field, Graphics.X11.Turtle.Input,