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 @@ -32,6 +32,10 @@ home, clear, undo, + sleep, + flushoff, + flushon, + flush, -- * change turtle state shape, @@ -93,7 +97,7 @@ -------------------------------------------------------------------------------- xturtleVersion :: (Int, String) -xturtleVersion = (46, "0.1.0") +xturtleVersion = (48, "0.1.2") -------------------------------------------------------------------------------- @@ -138,7 +142,7 @@ return t killTurtle :: Turtle -> IO () -killTurtle t = flushField (field t) $ do +killTurtle t = flushField (field t) True $ do clearLayer $ layer t clearCharacter $ character t killThread $ thread t @@ -193,6 +197,16 @@ undo :: Turtle -> IO () undo t = readIORef (stateIndex t) >>= flip replicateM_ (input t Undo) . undonum . (states t !!) + +sleep :: Turtle -> Int -> IO () +sleep t = input t . Sleep + +flushoff, flushon :: Turtle -> IO () +flushoff = (`input` SetFlush False) +flushon = (`input` SetFlush True) + +flush :: Turtle -> IO () +flush = (`input` Flush) -------------------------------------------------------------------------------- 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 @@ -52,7 +52,7 @@ makeCharacter, setCharacter) import Text.XML.YJSVG(Color(..)) -import Control.Monad(forever, replicateM) +import Control.Monad(forever, replicateM, when) import Control.Monad.Tools(doWhile_, doWhile, whenM) import Control.Arrow((***)) import Control.Concurrent( @@ -154,7 +154,7 @@ processEvent :: Field -> XEventPtr -> Event -> IO Bool processEvent f e ev = case ev of - ExposeEvent{} -> flushField f $ do + ExposeEvent{} -> flushField f True $ do windowSize (fDisplay f) (fWindow f) >>= writeIORef (fSize f) redrawLayers $ fLayers f return True @@ -205,14 +205,15 @@ modifyIORef (fRunning f) (tid :) return tid -flushField :: Field -> IO a -> IO a -flushField f act = do +flushField :: Field -> Bool -> IO a -> IO a +flushField f real 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 + 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 + flush $ fDisplay f writeChan (fLock f) () return ret 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 @@ -43,6 +43,9 @@ | Clear | Forward Double | TurnLeft Double + | Sleep Int + | SetFlush Bool + | Flush deriving (Show, Read) turtleSeries :: IO (Chan TurtleInput, [TurtleInput], [TurtleState]) @@ -101,8 +104,12 @@ where txt = Text (uncurry Center $ position t) sz (pencolor t) fnt str nextTurtle t (Bgcolor c) = (clearState t){ bgcolor = c, drawed = init (drawed t) ++ [Fill c]} -nextTurtle t (Clear) = (clearState t){clear = True, drawed = [last $ drawed t]} +nextTurtle t Clear = (clearState t){clear = True, drawed = [last $ drawed t]} +nextTurtle t (Sleep time) = (clearState t){sleep = Just time} +nextTurtle t (SetFlush ss) = (clearState t){stepbystep = ss} +nextTurtle t Flush = (clearState t){flush = True} nextTurtle _ _ = error "not defined" clearState :: TurtleState -> TurtleState -clearState t = t{undonum = 1, undo = False, clear = False, draw = Nothing} +clearState t = t{undonum = 1, undo = False, clear = False, draw = Nothing, + sleep = Nothing, flush = False} 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 @@ -45,25 +45,28 @@ -------------------------------------------------------------------------------- moveTurtle :: Field -> Character -> Layer -> TurtleState -> TurtleState -> IO () +moveTurtle _ _ _ _ TurtleState{sleep = Just t} = threadDelay $ 1000 * t +moveTurtle f _ _ _ TurtleState{flush = True} = flushField f True $ return () moveTurtle f c l t0 t1 = do - when (undo t1) $ flushField f $ do + when (undo t1) $ flushField f fl $ do when (clear t0) redraw when (isJust $ draw t0) $ do unlessM (undoLayer l) $ clearLayer l >> redraw when (visible t1) $ drawT (direction t1) $ position t0 when (visible t1) $ do - forM_ (directions t0 t1) $ \dir -> flushField f $ + forM_ (directions t0 t1) $ \dir -> flushField f fl $ drawT dir (position t0) >> threadDelay (interval t0) - forM_ (positions t0 t1) $ \p -> flushField f $ + forM_ (positions t0 t1) $ \p -> flushField f fl $ drawT (direction t1) p >> threadDelay (interval t0) - flushField f $ drawT (direction t1) $ position t1 + flushField f fl $ drawT (direction t1) $ position t1 when (bgcolor t0 /= bgcolor t1) $ - flushField f $ fieldColor f l $ bgcolor t1 - unless (undo t1) $ flushField f $ do + flushField f fl $ fieldColor f l $ bgcolor t1 + unless (undo t1) $ flushField f fl $ do when (visible t0 && not (visible t1)) $ clearCharacter c when (clear t1) $ clearLayer l maybe (return ()) (drawSVG f l) (draw t1) where + fl = stepbystep t0 redraw = mapM_ (drawSVG f l) $ reverse $ drawed t1 drawT d p = drawTurtle f c t1 d p lineOrigin lineOrigin | undo t1 && pendown t0 = Just $ position t1 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 @@ -25,7 +25,10 @@ undonum :: Int, draw :: Maybe SVG, drawed :: [SVG], - fillPoints :: [(Double, Double)]} + fillPoints :: [(Double, Double)], + sleep :: Maybe Int, + stepbystep :: Bool, + flush :: Bool} deriving Show initialTurtleState :: TurtleState @@ -49,4 +52,7 @@ undonum = 0, draw = Nothing, drawed = [Fill $ RGB 255 255 255], - fillPoints = []} + fillPoints = [], + sleep = Nothing, + stepbystep = True, + flush = False} 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.0 +version: 0.1.2 stability: experimental author: Yoshikuni Jujo maintainer: Yoshikuni Jujo