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 @@ -45,7 +45,7 @@ import Data.IORef(IORef, newIORef, readIORef, modifyIORef) xturtleVersion :: (Int, String) -xturtleVersion = (14, "0.0.8") +xturtleVersion = (16, "0.0.9") data Turtle = Turtle { layer :: Layer, diff --git a/src/Graphics/X11/TurtleInput.hs b/src/Graphics/X11/TurtleInput.hs --- a/src/Graphics/X11/TurtleInput.hs +++ b/src/Graphics/X11/TurtleInput.hs @@ -47,12 +47,13 @@ nextTurtle :: TurtleState -> TurtleInput -> TurtleState nextTurtle t (Shape sh) = (clearState t){shape = sh} nextTurtle t (ShapeSize ss) = (clearState t){size = ss} -nextTurtle t (Goto x y) = (clearState t){position = (x, y), line = pendown t} +nextTurtle t (Goto x y) = (clearState t){position = (x, y), line = pendown t, + drawed = if pendown t then (position t, (x, y)) : drawed t else drawed t} nextTurtle t (Rotate d) = (clearState t){direction = d} nextTurtle t Pendown = (clearState t){pendown = True} nextTurtle t Penup = (clearState t){pendown = False} nextTurtle t (Undonum un) = (clearState t){undonum = un} -nextTurtle t (Clear) = (clearState t){clear = True} +nextTurtle t (Clear) = (clearState t){clear = True, drawed = []} nextTurtle _ _ = error "not defined" clearState :: TurtleState -> TurtleState diff --git a/src/Graphics/X11/TurtleMove.hs b/src/Graphics/X11/TurtleMove.hs --- a/src/Graphics/X11/TurtleMove.hs +++ b/src/Graphics/X11/TurtleMove.hs @@ -16,7 +16,7 @@ import Graphics.X11.TurtleState(TurtleState(..)) import Graphics.X11.WindowLayers( Field, Layer, Character, - forkIOX, openField, closeField, + forkIOX, openField, closeField, flushLayer, addLayer, addCharacter, layerSize, clearLayer, drawLine, drawCharacter, drawCharacterAndLine, undoLayer ) @@ -41,7 +41,10 @@ moveTurtle :: Character -> Layer -> TurtleState -> TurtleState -> IO () moveTurtle c l t0 t1 = do - when (undo t1 && line t0) $ undoLayer l + when (undo t1 && line t0) $ do + done <- undoLayer l + when (not done) $ clearLayer l >> drawLines l (drawed t1) + when (undo t1 && clear t0) $ drawLines l $ drawed t1 forM_ (getDirections (direction t0) (direction t1)) $ \d -> do drawTurtle c (shape t1) (size t1) d p0 Nothing threadDelay rotateSpeed @@ -50,12 +53,15 @@ threadDelay moveSpeed drawTurtle c (shape t1) (size t1) (direction t1) p1 lineOrigin when (not (undo t1) && line t1) $ drawLine l x0 y0 x1 y1 - when (clear t1) $ clearLayer l + when (clear t1) $ clearLayer l >> flushLayer l where (tl, to) = if undo t1 then (t0, t1) else (t1, t0) lineOrigin = if line tl then Just $ position to else Nothing p0@(x0, y0) = position t0 p1@(x1, y1) = position t1 + +drawLines :: Layer -> [((Double, Double), (Double, Double))] -> IO () +drawLines l ls = mapM_ (\((x0, y0), (x1, y1)) -> drawLine l x0 y0 x1 y1) $ reverse ls getPositions :: Double -> Double -> Double -> Double -> [Pos] getPositions x0 y0 x1 y1 = zip [x0, x0 + dx .. x1 - dx] [y0, y0 + dy .. y1 - dy] diff --git a/src/Graphics/X11/TurtleState.hs b/src/Graphics/X11/TurtleState.hs --- a/src/Graphics/X11/TurtleState.hs +++ b/src/Graphics/X11/TurtleState.hs @@ -9,6 +9,7 @@ position :: (Double, Double), direction :: Double, pendown :: Bool, + drawed :: [((Double, Double), (Double, Double))], line :: Bool, undo :: Bool, undonum :: Int, @@ -22,6 +23,7 @@ position = (0, 0), direction = 0, pendown = True, + drawed = [], line = False, undo = False, undonum = 1, diff --git a/src/Graphics/X11/WindowLayers.hs b/src/Graphics/X11/WindowLayers.hs --- a/src/Graphics/X11/WindowLayers.hs +++ b/src/Graphics/X11/WindowLayers.hs @@ -16,6 +16,7 @@ undoLayer, clearLayer, + flushLayer, forkIOX ) where @@ -144,6 +145,9 @@ layerSize :: Layer -> IO (Double, Double) layerSize = fieldSize . layerField +flushLayer :: Layer -> IO () +flushLayer = flushWindow . layerField + addLayer :: Field -> IO Layer addLayer f = do ls <- readIORef $ fLayers f @@ -172,11 +176,13 @@ drawCharacterAndLine c@Character{characterField = f} ps x1 y1 x2 y2 = setCharacter c $ fillPolygonBuf f ps >> drawLineBuf f fBuf x1 y1 x2 y2 -undoLayer :: Layer -> IO () +undoLayer :: Layer -> IO Bool undoLayer Layer{layerField = f, layerId = lid} = do ls <- readIORef $ fLayers f - writeIORef (fLayers f) $ modifyAt ls lid init - redraw f + if null $ ls !! lid then return False else do + writeIORef (fLayers f) $ modifyAt ls lid init + redraw f + return True clearLayer :: Layer -> IO () clearLayer Layer{layerField = f, layerId = lid} = do @@ -184,7 +190,8 @@ writeIORef (fLayers f) $ setAt ls lid [] buffed <- readIORef $ fBuffed f writeIORef (fBuffed f) $ setAt buffed lid $ return () - redrawAll f + redrawBuf f + redraw f forkIOX :: IO () -> IO ThreadId forkIOX = (initThreads >>) . forkIO @@ -253,26 +260,28 @@ readIORef (fBuffed f) >>= sequence_ redraw :: Field -> IO () -redraw f = do +redraw = withLock $ \f -> do (width, height) <- winSize f copyArea (fDisplay f) (fUndoBuf f) (fBG f) (fGC f) 0 0 width height 0 0 - readChan $ fWait f readIORef (fLayers f) >>= mapM_ ($ False) . concat + copyArea (fDisplay f) (fBG f) (fBuf f) (fGC f) 0 0 width height 0 0 readIORef (fCharacters f) >>= sequence_ - writeChan (fWait f) () redrawCharacters :: Field -> IO () -redrawCharacters f = do +redrawCharacters = withLock $ \f -> do (width, height) <- winSize f - readChan $ fWait f copyArea (fDisplay f) (fBG f) (fBuf f) (fGC f) 0 0 width height 0 0 readIORef (fCharacters f) >>= sequence_ - writeChan (fWait f) () flushWindow :: Field -> IO () -flushWindow f = do +flushWindow = withLock $ \f -> do (width, height) <- winSize f - readChan $ fWait f copyArea (fDisplay f) (fBuf f) (fWindow f) (fGC f) 0 0 width height 0 0 flush $ fDisplay f + +withLock :: (Field -> IO a) -> Field -> IO a +withLock act f = do + readChan $ fWait f + ret <- act f writeChan (fWait f) () + return ret 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.0.8 +version: 0.0.9 stability: experimental author: Yoshikuni Jujo maintainer: Yoshikuni Jujo