xturtle 0.0.1 → 0.0.2
raw patch · 3 files changed
+68/−24 lines, 3 files
Files
- src/Graphics/X11/Turtle.hs +44/−17
- src/Graphics/X11/World.hs +23/−6
- xturtle.cabal +1/−1
src/Graphics/X11/Turtle.hs view
@@ -53,11 +53,26 @@ (x, y) <- position return $ ((x - x0) ** 2 + (y - y0) ** 2) ** (1 / 2) -pastDrawLines :: IORef [Maybe (((Double, Double), Double), IO ())]+pastDrawLines :: IORef [Maybe (((Double, Double), Double), Buf -> IO ())] pastDrawLines = unsafePerformIO $ newIORef [] +putToPastDrawLines :: (Double, Double) -> Double -> (Buf -> IO ()) -> IO ()+putToPastDrawLines tpos tdir dl = do+ pdls <- readIORef pastDrawLines+ if length pdls < 300+ then do+ writeIORef pastDrawLines $ pdls ++ [Just ((tpos, tdir), dl)]+ else do+ maybe (return ()) (($ UndoBuf) . snd) $ head pdls+ writeIORef pastDrawLines $ tail pdls ++ [Just ((tpos, tdir), dl)]++setUndoPoint :: IO ()+setUndoPoint = modifyIORef pastDrawLines $ (++ [Nothing])+ data PenState = PenUp | PenDown +data Order = Forward Double | Left Double | Undo deriving Show+ doesPenDown :: PenState -> Bool doesPenDown PenUp = False doesPenDown PenDown = True@@ -89,6 +104,15 @@ _ -> error $ "not implemented for event " ++ show ev closeTurtle +orderChan :: IORef (Chan Order)+orderChan = unsafePerformIO $ newChan >>= newIORef++getOrders :: IO [Order]+getOrders = unsafeInterleaveIO $ do+ o <- readIORef orderChan >>= readChan+ os <- getOrders+ return $ o : os+ initTurtle :: IO () initTurtle = do w <- openWorld@@ -117,7 +141,7 @@ width <- windowWidth height <- windowHeight rawGoto (x + width / 2) (- y + height / 2)- >> modifyIORef pastDrawLines (++ [Nothing])+ >> setUndoPoint rawGoto xTo yTo = do w <- readIORef world (x0, y0) <- getCursorPos w@@ -143,7 +167,7 @@ flushWorld w forward, rawForward :: Double -> IO ()-forward len = rawForward len >> modifyIORef pastDrawLines (++ [Nothing])+forward len = rawForward len >> setUndoPoint rawForward len = do w <- readIORef world (x0, y0) <- getCursorPos w@@ -171,13 +195,13 @@ drawLine :: World -> Double -> Double -> Double -> Double -> IO () drawLine w x1 y1 x2 y2 = do- let act = do+ let act buf = do ps <- readIORef penState when (doesPenDown ps) $- lineToBG w (round x1) (round y1) (round x2) (round y2)- act+ lineToBG w buf (round x1) (round y1) (round x2) (round y2)+ act BG dir <- readIORef world >>= getCursorDir - modifyIORef pastDrawLines (++ [Just (((x2, y2), dir), act)])+ putToPastDrawLines (x2, y2) dir act redrawLines :: IO () redrawLines = do@@ -185,7 +209,7 @@ dls <- fmap (map fromJust . filter isJust) $ readIORef pastDrawLines clear flip mapM_ dls $ \dl -> do- snd dl+ snd dl BG drawWorld w flushWorld w threadDelay 20000@@ -194,9 +218,10 @@ undoAll = do w <- readIORef world dls <- fmap (map fromJust . filter isJust) $ readIORef pastDrawLines- flip mapM_ (zip (reverse $ map fst dls) $ map sequence_ $ reverse $ inits $ map snd dls)+ flip mapM_ (zip (reverse $ map fst dls) $ map sequence_ $ reverse $ inits+ $ map (($ BG) . snd) dls) $ \((pos, dir), dl) -> do- cleanBG w+ cleanBG w BG dl uncurry (setCursorPos w) pos setCursorDir w dir@@ -213,9 +238,11 @@ draw1 = map fromJust $ filter isJust $ head $ dropWhile (isJust . last) $ reverse $ inits dls draw' = draw ++ [draw1]- flip mapM_ (zip (reverse $ map (fst . fromJust) $ filter isJust dls ) $ map sequence_- $ map (map snd) draw') $ \((pos, dir), dl) -> do- cleanBG w+ flip mapM_ (zip (reverse $ map (fst . fromJust) $ filter isJust dls )+ $ map sequence_+ $ map (map (($ BG) . snd)) draw') $ \((pos, dir), dl) -> do+ cleanBG w BG+ undoBufToBG w dl uncurry (setCursorPos w) pos setCursorDir w dir@@ -233,7 +260,7 @@ drawWorld w flushWorld w pos <- getCursorPos w- modifyIORef pastDrawLines (++ [Just ((pos, nd), return ())])+ putToPastDrawLines pos nd $ const (return ()) rotateTo :: Double -> IO () rotateTo d = do@@ -248,7 +275,7 @@ flushWorld w rotate, rawRotate :: Double -> IO ()-rotate d = rawRotate d >> modifyIORef pastDrawLines (++ [Nothing])+rotate d = rawRotate d >> setUndoPoint rawRotate d = do w <- readIORef world d0 <- getCursorDir w@@ -281,11 +308,11 @@ clear :: IO () clear = do w <- readIORef world- cleanBG w+ cleanBG w BG drawWorld w >> flushWorld w pos <- getCursorPos w dir <- getCursorDir w- modifyIORef pastDrawLines (++ [Just ((pos, dir), cleanBG w)])+ putToPastDrawLines pos dir $ cleanBG w closeTurtle :: IO () closeTurtle = readIORef world >>= closeWorld
src/Graphics/X11/World.hs view
@@ -8,6 +8,7 @@ setCursorSize, setCursorShape, drawWorld,+ undoBufToBG, closeWorld, withEvent, flushWorld,@@ -17,6 +18,7 @@ lineToBG, cleanBG, getWindowSize,+ Buf(..), Event(..), Position,@@ -40,6 +42,7 @@ wDel :: Atom, wBG :: Pixmap, wBuf :: Pixmap,+ wUndoBuf :: Pixmap, wPos :: IORef (Double, Double), wDir :: IORef Double, wSize :: IORef Double,@@ -100,11 +103,13 @@ win <- createSimpleWindow dpy root 0 0 width height 1 black white bg <- createPixmap dpy root width height $ defaultDepth dpy scr buf <- createPixmap dpy root width height $ defaultDepth dpy scr+ undoBuf <- createPixmap dpy root width height $ defaultDepth dpy scr gc <- createGC dpy win gc' <- createGC dpy win setForeground dpy gc' 0xffffff fillRectangle dpy bg gc' 0 0 width height fillRectangle dpy buf gc' 0 0 width height+ fillRectangle dpy undoBuf gc' 0 0 width height setWMProtocols dpy win [del] selectInput dpy win $ exposureMask .|. keyPressMask mapWindow dpy win@@ -113,7 +118,7 @@ initDir <- newIORef undefined initSize <- newIORef undefined initShape <- newIORef undefined- return $ World dpy win gc del bg buf initPos initDir initSize initShape+ return $ World dpy win gc del bg buf undoBuf initPos initDir initSize initShape closeWorld :: World -> IO () closeWorld = closeDisplay . wDisplay@@ -129,6 +134,12 @@ displayCursor w s d x y copyArea (wDisplay w) (wBuf w) (wWindow w) (wGC w) 0 0 width height 0 0 +undoBufToBG :: World -> IO ()+undoBufToBG w = do+ (_, _, _, width, height, _, _) <- getGeometry (wDisplay w) (wWindow w)+ copyArea (wDisplay w) (wUndoBuf w) (wBG w) (wGC w) 0 0 width height 0 0++ withEvent :: World -> s -> (s -> Event -> IO (s, Bool)) -> IO s withEvent w stat0 act = doWhile stat0 $ \stat -> allocaXEvent $ \e -> do nextEvent (wDisplay w) e@@ -146,15 +157,21 @@ makeFilledPolygonCursor w ps = fillPolygon (wDisplay w) (wBuf w) (wGC w) ps nonconvex coordModeOrigin -lineToBG :: World -> Position -> Position -> Position -> Position -> IO ()-lineToBG w x1 y1 x2 y2 = drawLine (wDisplay w) (wBG w) (wGC w) x1 y1 x2 y2+data Buf = BG | UndoBuf -cleanBG :: World -> IO ()-cleanBG w = do+lineToBG :: World -> Buf -> Position -> Position -> Position -> Position -> IO ()+lineToBG w BG x1 y1 x2 y2 = drawLine (wDisplay w) (wBG w) (wGC w) x1 y1 x2 y2+lineToBG w UndoBuf x1 y1 x2 y2 = drawLine (wDisplay w) (wUndoBuf w) (wGC w) x1 y1 x2 y2++cleanBG :: World -> Buf -> IO ()+cleanBG w b = do (_, _, _, width, height, _, _) <- getGeometry (wDisplay w) (wWindow w) gc <- createGC (wDisplay w) (wWindow w) setForeground (wDisplay w) gc 0xffffff- fillRectangle (wDisplay w) (wBG w) gc 0 0 width height+ let buf = case b of+ BG -> wBG w+ UndoBuf -> wUndoBuf w+ fillRectangle (wDisplay w) buf gc 0 0 width height flushWorld :: World -> IO () flushWorld = flush . wDisplay
xturtle.cabal view
@@ -2,7 +2,7 @@ cabal-version: >= 1.6 name: xturtle-version: 0.0.1+version: 0.0.2 stability: experimental author: Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer: Yoshikuni Jujo <PAF01143@nifty.ne.jp>