packages feed

xturtle 0.0.5 → 0.0.6

raw patch · 5 files changed

+257/−252 lines, 5 filesdep ~yjtools

Dependency ranges changed: yjtools

Files

src/Graphics/X11/Turtle.hs view
@@ -3,24 +3,28 @@  	openField, 	newTurtle,+ 	shape, 	shapesize, 	forward, 	backward, 	left, 	right,+	goto, 	home, 	clear, 	circle,+	penup,+	pendown, 	undo,-	position,-	distance,+ 	windowWidth, 	windowHeight,-	goto,-	penup,-	pendown,-	isdown+	position,+	distance,+	isdown,++	xturtleVersion ) where  import Graphics.X11.TurtleDraw@@ -31,13 +35,15 @@ import Data.IORef import Control.Arrow(second) +xturtleVersion :: (Int, String)+xturtleVersion = (1, "0.0.5b")+ data Turtle = Turtle { 	inputChan :: Chan TurtleInput,-	field :: Field,-	layer :: Layer,-	character :: Character, 	states :: [TurtleState],-	stateNow :: IORef Int+	stateNow :: IORef Int,+	layer :: Layer,+	character :: Character  }  newTurtle :: Field -> IO Turtle@@ -49,7 +55,6 @@ 	let	sts = drop 4 $ inputToTurtle [] initialTurtleState ret 		t = Turtle { 			inputChan = c,-			field = f, 			layer = l, 			character = ch, 			states = sts,@@ -61,9 +66,7 @@ 	writeChan c $ Goto 0 0 	writeChan c $ RotateTo 0 	writeChan c $ Goto 0 0-	_ <- forkIO $---		initialThread-		for2M_ sts $ turtleDraw f ch l+	_ <- forkIOX $ for2M_ sts $ turtleDraw ch l 	return t  shape :: Turtle -> String -> IO ()@@ -107,9 +110,9 @@ home t = modifyIORef (stateNow t) (+ 1) >> goto t 0 0 >> rotateTo t 0  clear :: Turtle -> IO ()-clear t@Turtle{field = f, layer = l} = do+clear t@Turtle{layer = l} = do 	forward t 0-	clearLayer f l+	clearLayer l  position :: Turtle -> IO (Double, Double) position Turtle{stateNow = sn, states = s} =@@ -121,8 +124,8 @@ 	return $ ((x - x0) ** 2 + (y - y0) ** 2) ** (1 / 2)  windowWidth, windowHeight :: Turtle -> IO Double-windowWidth = fmap fst . winSize . field-windowHeight = fmap snd . winSize . field+windowWidth = fmap fst . layerSize . layer+windowHeight = fmap snd . layerSize . layer  pendown, penup :: Turtle -> IO () pendown Turtle{inputChan = c, stateNow = sn} = do
src/Graphics/X11/TurtleDraw.hs view
@@ -9,7 +9,8 @@ 	clearLayer, 	turtleDraw, -	winSize+	layerSize,+	forkIOX ) where  import Graphics.X11.TurtleState@@ -19,12 +20,12 @@ import Graphics.X11.WindowLayers  turtleDraw, turtleDrawNotUndo, turtleDrawUndo ::-	Field -> Character -> Layer -> TurtleState -> TurtleState -> IO ()-turtleDraw f c l t0 t1 = do+	Character -> Layer -> TurtleState -> TurtleState -> IO ()+turtleDraw c l t0 t1 = do 	let	isUndo = turtleUndo t1-	if isUndo then turtleDrawUndo f c l t0 t1-		else turtleDrawNotUndo f c l t0 t1-turtleDrawUndo f c l t0 t1 = do+	if isUndo then turtleDrawUndo c l t0 t1+		else turtleDrawNotUndo c l t0 t1+turtleDrawUndo c l t0 t1 = do 	let	shape = turtleShape t1 		size = turtleSize t1 		prePos@(px, py) = turtlePos t0@@ -34,17 +35,17 @@ 		dir = turtleDir t1 --		doneLine = turtleLineDone t0 --	when doneLine $ undoLayer f l-	when pen $ undoLayer f l+	when pen $ undoLayer l 	forM_ (getDirections preDir dir) $ \d -> do-		drawTurtle f c shape size d prePos Nothing+		drawTurtle c shape size d prePos Nothing 		threadDelay 10000 	if pen then forM_ (getPoints px py nx ny) $ \p -> do-			drawTurtle f c shape size dir p $ Just pos+			drawTurtle c shape size dir p $ Just pos 			threadDelay 50000 		else forM_ (getPoints px py nx ny) $ \p -> do-			drawTurtle f c shape size dir p Nothing+			drawTurtle c shape size dir p Nothing 			threadDelay 50000-turtleDrawNotUndo f c l t0 t1 = do+turtleDrawNotUndo c l t0 t1 = do 	let	shape = turtleShape t1 		size = turtleSize t1 		prePos@(px, py) = turtlePos t0@@ -53,14 +54,14 @@ 		(nx, ny) = turtlePos t1 		dir = turtleDir t1 	forM_ (getDirections preDir dir) $ \d ->-		drawTurtle f c shape size d prePos Nothing+		drawTurtle c shape size d prePos Nothing 	if prePen then do 			forM_ (getPoints px py nx ny) $ \p -> do-				drawTurtle f c shape size dir p $ Just prePos+				drawTurtle c shape size dir p $ Just prePos 				threadDelay 50000-			line f l px py nx ny+			drawLine l px py nx ny 		else forM_ (getPoints px py nx ny) $ \p -> do-			drawTurtle f c shape size dir p Nothing+			drawTurtle c shape size dir p Nothing 			threadDelay 50000  step :: Double@@ -87,14 +88,12 @@         dd = sig * stepDir         beforeDir x = sig * x < sig * de -drawTurtle :: Field -> Character -> [(Double, Double)] -> Double -> Double ->+drawTurtle :: Character -> [(Double, Double)] -> Double -> Double -> 	(Double, Double) -> Maybe (Double, Double) -> IO ()-drawTurtle w c sh s d (x, y) org = do+drawTurtle c sh s d (x, y) org = do 	let sp = mkShape sh s d x y-	maybe (setPolygonCharacter w c sp)-		(flip (setPolygonCharacterAndLine w c sp) (x, y)) org-	bufToWin w-	flushWin w+	maybe (drawCharacter c sp)+		(flip (drawCharacterAndLine c sp) (x, y)) org  mkShape :: 	[(Double, Double)] -> Double -> Double -> Double -> Double -> [(Double, Double)]
src/Graphics/X11/TurtleInput.hs view
@@ -8,7 +8,6 @@ ) where  import Control.Concurrent-import System.IO.Unsafe import Graphics.X11.TurtleState import Prelude hiding (Left) @@ -28,14 +27,8 @@ makeInput :: IO (Chan TurtleInput, [TurtleInput]) makeInput = do 	c <- newChan-	ret <- getInput c+	ret <- getChanContents c 	return (c, ret)--getInput :: Chan TurtleInput -> IO [TurtleInput]-getInput c = unsafeInterleaveIO $ do-	ti <- readChan c-	tis <- getInput c-	return $ ti : tis  nextTurtle :: TurtleState -> TurtleState nextTurtle t = TurtleState{
src/Graphics/X11/WindowLayers.hs view
@@ -1,78 +1,84 @@-module Graphics.X11.WindowLayers (+module Graphics.X11.WindowLayers( 	Field, 	Layer, 	Character,  	openField, 	closeField,-	bufToWin,-	flushWin,-	winSize,+	layerSize,  	addLayer, 	addCharacter, -	line,-	setPolygonCharacter,-	setPolygonCharacterAndLine,+	drawLine,+	drawCharacter,+	drawCharacterAndLine,  	undoLayer, 	clearLayer,++	forkIOX ) where  import Graphics.X11(-	Window, Pixmap, Atom,+	Display, Window, Pixmap, Atom, GC, Point(..), Dimension,  	openDisplay, closeDisplay, flush, defaultScreen, rootWindow, 	whitePixel, blackPixel,	defaultDepth, 	createSimpleWindow, mapWindow, createPixmap, internAtom, createGC,  	setForeground, copyArea,-	drawLine, fillRectangle, fillPolygon, nonconvex, coordModeOrigin,+	fillRectangle, fillPolygon, nonconvex, coordModeOrigin,  	setWMProtocols, selectInput, allocaXEvent, nextEvent, 	keyPressMask, exposureMask,  	getGeometry, initThreads  )+import qualified Graphics.X11 as X (drawLine) import Graphics.X11.Xlib.Extras(Event(..), getEvent)-import Graphics.X11.Xlib.Types-import Control.Monad.Tools(doWhile_)-import Control.Arrow((***))-import Control.Concurrent(forkIO)+ import Data.IORef(IORef, newIORef, readIORef, writeIORef, modifyIORef) import Data.Bits((.|.)) import Data.Convertible(convert)+import Data.List.Tools(modifyAt) -data Win = Win{-	wDisplay :: Display,-	wWindow :: Window,-	wGC :: GC,-	wGCWhite :: GC,-	wDel :: Atom,-	wUndoBuf :: Pixmap,-	wBG :: Pixmap,-	wBuf :: Pixmap,-	wWidth :: IORef Dimension,-	wHeight :: IORef Dimension,-	wExpose :: IORef [[Bool -> IO ()]],-	wBuffed :: IORef [IO ()],-	wChars :: IORef [IO ()]- }+import Control.Monad(replicateM, forM_)+import Control.Monad.Tools(doWhile_)+import Control.Arrow((***))+import Control.Concurrent(forkIO, ThreadId) -data Layer = Layer Int-data Character = Character Int+data Field = Field{+	fDisplay :: Display,+	fWindow :: Window,+	fGC :: GC,+	fGCBG :: GC,+	fDel :: Atom,+	fUndoBuf :: Pixmap,+	fBG :: Pixmap,+	fBuf :: Pixmap,+	fWidth :: IORef Dimension,+	fHeight :: IORef Dimension,+	fBuffed :: IORef [IO ()],+	fLayers :: IORef [[Bool -> IO ()]],+	fCharacters :: IORef [IO ()]+ } -type Field = Win+data Layer = Layer{+	layerField :: Field,+	layerId :: Int+ } -openField :: IO Field-openField = openWin+data Character = Character{+	characterField :: Field,+	characterId :: Int+ } -closeField :: Field -> IO ()-closeField = closeDisplay . wDisplay+forkIOX :: IO () -> IO ThreadId+forkIOX = (initThreads >>) . forkIO -openWin :: IO Win-openWin = do+openField :: IO Field+openField = do 	_ <- initThreads 	dpy <- openDisplay "" 	del <- internAtom dpy "WM_DELETE_WINDOW" True@@ -82,221 +88,225 @@ 	let	black = blackPixel dpy scr 		white = whitePixel dpy scr 		depth = defaultDepth dpy scr-	undoBuf <- createPixmap dpy root rWidth rHeight depth-	bg <- createPixmap dpy root rWidth rHeight depth-	buf <- createPixmap dpy root rWidth rHeight depth+	bufs <- replicateM 3 $ createPixmap dpy root rWidth rHeight depth 	win <- createSimpleWindow dpy root 0 0 rWidth rHeight 1 black white-	gc <- createGC dpy win-	gcWhite <- createGC dpy win-	setForeground dpy gcWhite 0xffffff-	fillRectangle dpy bg gcWhite 0 0 rWidth rHeight-	fillRectangle dpy buf gcWhite 0 0 rWidth rHeight-	fillRectangle dpy undoBuf gcWhite 0 0 rWidth rHeight+	[gc, gcBG] <- replicateM 2 $ createGC dpy win+	setForeground dpy gcBG 0xffffff+	forM_ bufs $ \bf -> fillRectangle dpy bf gcBG 0 0 rWidth rHeight 	setWMProtocols dpy win [del] 	selectInput dpy win $ exposureMask .|. keyPressMask 	mapWindow dpy win-	widthRef <- newIORef rWidth-	heightRef <- newIORef rHeight-	exposeAction <- newIORef []-	buffedAction <- newIORef []-	charActions <- newIORef []-	let w = Win dpy win gc gcWhite del undoBuf bg buf widthRef heightRef-		exposeAction buffedAction charActions-	_ <- forkIO $ (>> closeDisplay dpy) $ (initThreads >>) $ withEvent w $ \ev ->-		case ev of-			ExposeEvent{} -> do-				(_, _, _, width, height, _, _) <--					getGeometry (wDisplay w) (wWindow w)-				writeIORef (wWidth w) width-				writeIORef (wHeight w) height---				clearBG w-				clearUndoBuf w-				readIORef buffedAction >>= sequence_-				undoBufToBG w-				readIORef exposeAction >>= mapM_ ($ False) . concat-				readIORef charActions >>= sequence_-				bufToWin w-				flushWin w-				return True-			KeyEvent{} -> return True-			ClientMessageEvent{} ->-				return $ not $ isDeleteEvent w ev-			_ -> return True-	flushWin w-	return w-	where-	withEvent w act = doWhile_ $ allocaXEvent $ \e -> do-		nextEvent (wDisplay w) e-		getEvent e >>= act-	isDeleteEvent w ev@ClientMessageEvent{} =-		convert (head $ ev_data ev) == wDel w-	isDeleteEvent _ _ = False+	[widthRef, heightRef] <- mapM newIORef [rWidth, rHeight]+	buffActions <- newIORef []+	layerActions <- newIORef []+	characterActions <- newIORef []+	let f = Field{+		fDisplay = dpy,+		fWindow = win,+		fGC = gc,+		fGCBG = gcBG,+		fDel = del,+		fUndoBuf = head bufs,+		fBG = bufs !! 1,+		fBuf = bufs !! 2,+		fWidth = widthRef,+		fHeight = heightRef,+		fBuffed = buffActions,+		fLayers = layerActions,+		fCharacters = characterActions+	 }+	_ <- forkIOX $ runLoop f+	flushWin f+	return f +runLoop :: Field -> IO ()+runLoop f = (>> closeField f) $	doWhile_ $ allocaXEvent $ \e -> do+	nextEvent (fDisplay f) e+	ev <- getEvent e+	case ev of+		ExposeEvent{} -> do+			(_, _, _, width, height, _, _) <-+				getGeometry (fDisplay f) (fWindow f)+			writeIORef (fWidth f) width+			writeIORef (fHeight f) height+			redrawAll f+			return True+		KeyEvent{} -> return True+		ClientMessageEvent{} ->+			return $ convert (head $ ev_data ev) /= fDel f+		_ -> return True++closeField :: Field -> IO ()+closeField = closeDisplay . fDisplay++layerSize :: Layer -> IO (Double, Double)+layerSize = fieldSize . layerField++fieldSize :: Field -> IO (Double, Double)+fieldSize w = fmap (fromIntegral *** fromIntegral) $ fieldSizeRaw w++fieldSizeRaw :: Field -> IO (Dimension, Dimension)+fieldSizeRaw w = do+	width <- readIORef $ fWidth w+	height <- readIORef $ fHeight w+	return (width, height)++addLayer :: Field -> IO Layer+addLayer f = do+	ls <- readIORef $ fLayers f+	writeIORef (fLayers f) (ls ++ [[]])+	modifyIORef (fBuffed f) (++ [return ()])+	return Layer{layerField = f, layerId = length ls}++addCharacter :: Field -> IO Character+addCharacter f = do+	cs <- readIORef $ fCharacters f+	writeIORef (fCharacters f) (cs ++ [return ()])+	return Character{characterField = f, characterId = length cs}++drawLine :: Layer -> Double -> Double -> Double -> Double -> IO ()+drawLine l@Layer{layerField = f} x1_ y1_ x2_ y2_ = do+	(x1, y1) <- convertPos f x1_ y1_+	(x2, y2) <- convertPos f x2_ y2_+	lineWin f x1 y1 x2 y2+	addLayerAction l $ \buf -> do+		(x1', y1') <- convertPos f x1_ y1_+		(x2', y2') <- convertPos f x2_ y2_+		if buf	then lineUndoBuf f x1' y1' x2' y2'+			else lineWin f x1' y1' x2' y2'+ undoN :: Int undoN = 100 -clearLayer :: Win -> Layer -> IO ()-clearLayer w l@(Layer lid) = do-	setExposeAction w l (const $ const $ return ())-	buffed <- readIORef $ wBuffed w-	writeIORef (wBuffed w) $+addLayerAction :: Layer -> (Bool -> IO ()) -> IO ()+addLayerAction Layer{layerField = f, layerId = lid} act = do+	ls <- readIORef $ fLayers f+	if length (ls !! lid) > undoN+		then do	head (ls !! lid) True+			buffed <- readIORef $ fBuffed f+			writeIORef (fBuffed f) $ +				modifyAt buffed lid (>> head (ls !! lid) True)+			writeIORef (fLayers f) $+				modifyAt ls lid $ (++ [act]) . tail+		else writeIORef (fLayers f) $ modifyAt ls lid (++ [act])++convertPos :: Field -> Double -> Double -> IO (Double, Double)+convertPos f x y = do+	(width, height) <- fieldSize f+	return (x + width / 2, - y + height / 2)++clearLayer :: Layer -> IO ()+clearLayer l@Layer{layerField = f, layerId = lid} = do+	setExposeAction f l (const $ const $ return ())+	buffed <- readIORef $ fBuffed f+	writeIORef (fBuffed f) $ 		take lid buffed ++ [return ()] ++ drop (lid + 1) buffed-	nBuffed <- readIORef $ wBuffed w-	clearUndoBuf w-	sequence_ nBuffed-	undoBufToBG w-	readIORef (wExpose w) >>= mapM_ ($ False) . concat-	bgToBuf w-	readIORef (wChars w) >>= sequence_-	bufToWin w-	flushWin w+	redrawAll f -addExposeAction :: Win -> Layer -> (Win -> Bool -> IO ()) -> IO ()-addExposeAction w@Win{wExpose = we} (Layer lid) act = do-	ls <- readIORef we-	let	theLayer = ls !! lid-		newLayer = theLayer ++ [act w]-	if length newLayer > undoN-		then do	head newLayer True-			buffed <- readIORef $ wBuffed w-			writeIORef (wBuffed w) $ take lid buffed ++-				[buffed !! lid >> head newLayer True] ++-				drop (lid + 1) buffed-			writeIORef we $ take lid ls ++ [tail newLayer] ++ drop (lid + 1) ls-		else writeIORef we $ take lid ls ++ [newLayer] ++ drop (lid + 1) ls+redrawAll :: Field -> IO ()+redrawAll f = do+	redrawBuf f+	redraw f+	flushWin f -setExposeAction :: Win -> Layer -> (Win -> Bool -> IO ()) -> IO ()-setExposeAction w@Win{wExpose = we} (Layer lid) act = do+redrawBuf :: Field -> IO ()+redrawBuf f = do+	clearUndoBuf f+	readIORef (fBuffed f) >>= sequence_++setExposeAction :: Field -> Layer -> (Field -> Bool -> IO ()) -> IO ()+setExposeAction w@Field{fLayers = we} Layer{layerId = lid} act = do 	ls <- readIORef we 	writeIORef we $ take lid ls ++ [[act w]] ++ drop (lid + 1) ls -undoLayer :: Win -> Layer -> IO ()-undoLayer w@Win{wExpose = we} (Layer lid) = do-	ls <- readIORef we-	writeIORef we $ take lid ls ++ [init (ls !! lid)] ++ drop (lid + 1) ls+undoLayer :: Layer -> IO ()+undoLayer Layer{layerField = w, layerId = lid} = do+	ls <- readIORef $ fLayers w+	writeIORef (fLayers w) $ take lid ls ++ [init (ls !! lid)] ++ drop (lid + 1) ls+	redraw w++redraw :: Field -> IO ()+redraw w = do 	undoBufToBG w-	readIORef we >>= mapM_ ($ False) . concat-	bgToBuf w-	readIORef (wChars w) >>= sequence_---	bufToWin w---	flushWin w+	readIORef (fLayers w) >>= mapM_ ($ False) . concat+	readIORef (fCharacters w) >>= sequence_ -setCharacter :: Win -> Character -> IO () -> IO ()+setCharacter :: Field -> Character -> IO () -> IO () setCharacter w c act = do 	bgToBuf w 	setCharacterAction w c act-	readIORef (wChars w) >>= sequence_---	bufToWin w---	flushWin w+	readIORef (fCharacters w) >>= sequence_ -setCharacterAction :: Win -> Character -> IO () -> IO ()-setCharacterAction Win{wChars = wc} (Character cid) act = do+setCharacterAction :: Field -> Character -> IO () -> IO ()+setCharacterAction Field{fCharacters = wc} Character{characterId = cid} act = do 	cs <- readIORef wc 	writeIORef wc $ take cid cs ++ [act] ++ drop (cid + 1) cs -addLayer :: Win -> IO Layer-addLayer Win{wExpose = we, wBuffed = wb} = do-	ls <- readIORef we-	modifyIORef we (++ [[]])-	modifyIORef wb (++ [return ()])-	return $ Layer $ length ls--addCharacter :: Win -> IO Character-addCharacter Win{wChars = wc} = do-	cs <- readIORef wc-	modifyIORef wc (++ [return ()])-	return $ Character $ length cs--winSize :: Win -> IO (Double, Double)-winSize w = fmap (fromIntegral *** fromIntegral) $ winSizeRaw w--winSizeRaw :: Win -> IO (Dimension, Dimension)-winSizeRaw w = do-	width <- readIORef $ wWidth w-	height <- readIORef $ wHeight w-	return (width, height)--undoBufToBG :: Win -> IO ()+undoBufToBG :: Field -> IO () undoBufToBG w = do-	(width, height) <- winSizeRaw w-	copyArea (wDisplay w) (wUndoBuf w) (wBG w) (wGC w) 0 0 width height 0 0+	(width, height) <- fieldSizeRaw w+	copyArea (fDisplay w) (fUndoBuf w) (fBG w) (fGC w) 0 0 width height 0 0 -bgToBuf :: Win -> IO ()+bgToBuf :: Field -> IO () bgToBuf w = do-	(width, height) <- winSizeRaw w-	copyArea (wDisplay w) (wBG w) (wBuf w) (wGC w) 0 0 width height 0 0+	(width, height) <- fieldSizeRaw w+	copyArea (fDisplay w) (fBG w) (fBuf w) (fGC w) 0 0 width height 0 0 -bufToWin :: Win -> IO ()+bufToWin :: Field -> IO () bufToWin w = do-	(width, height) <- winSizeRaw w-	copyArea (wDisplay w) (wBuf w) (wWindow w) (wGC w) 0 0 width height 0 0+	(width, height) <- fieldSizeRaw w+	copyArea (fDisplay w) (fBuf w) (fWindow w) (fGC w) 0 0 width height 0 0 -fillPolygonBuf :: Win -> [(Double, Double)] -> IO ()+fillPolygonBuf :: Field -> [(Double, Double)] -> IO () fillPolygonBuf w ps = do-	(width, height) <- winSize w+	(width, height) <- fieldSize w 	let	dtp (x, y) = Point (round $ x + width / 2) (round $ - y + height / 2)-	fillPolygon (wDisplay w) (wBuf w) (wGC w) (map dtp ps) nonconvex coordModeOrigin+	fillPolygon (fDisplay w) (fBuf w) (fGC w) (map dtp ps) nonconvex coordModeOrigin -setPolygonCharacter :: Win -> Character -> [(Double, Double)] -> IO ()-setPolygonCharacter w c ps = setCharacter w c (fillPolygonBuf w ps)+drawCharacter :: Character -> [(Double, Double)] -> IO ()+drawCharacter c@Character{characterField = w} ps = do+	setCharacter w c (fillPolygonBuf w ps)+	flushWin w -setPolygonCharacterAndLine ::-	Win -> Character -> [(Double, Double)] -> (Double, Double) ->+drawCharacterAndLine ::	Character -> [(Double, Double)] -> (Double, Double) -> 		(Double, Double) -> IO ()-setPolygonCharacterAndLine w c ps (x1_, y1_) (x2_, y2_) =-	setCharacter w c (fillPolygonBuf w ps >> lineBuf w x1_ y1_ x2_ y2_)--line :: Win -> Layer -> Double -> Double -> Double -> Double -> IO ()-line w l x1_ y1_ x2_ y2_ = do-	(width, height) <- winSize w-	let	x1 = x1_ + (width / 2)-		x2 = x2_ + (width / 2)-		y1 = - y1_ + (height / 2)-		y2 = - y2_ + (height / 2)-	lineWin w x1 y1 x2 y2-	addExposeAction w l $ \w' buf -> do-		(x1', y1') <- convertPos w' x1_ y1_-		(x2', y2') <- convertPos w' x2_ y2_-		if buf	then lineUndoBuf w' x1' y1' x2' y2'-			else lineWin w' x1' y1' x2' y2'--convertPos :: Win -> Double -> Double -> IO (Double, Double)-convertPos w x y = do-	(width, height) <- winSize w-	return (x + width / 2, - y + height / 2)+drawCharacterAndLine c@Character{characterField = w} ps (x1, y1) (x2, y2) = do+	setCharacter w c (fillPolygonBuf w ps >> lineBuf w x1 y1 x2 y2)+	flushWin w -lineWin :: Win -> Double -> Double -> Double -> Double -> IO ()+lineWin :: Field -> Double -> Double -> Double -> Double -> IO () lineWin w x1_ y1_ x2_ y2_ = do-	drawLine (wDisplay w) (wBG w) (wGC w) x1 y1 x2 y2+	X.drawLine (fDisplay w) (fBG w) (fGC w) x1 y1 x2 y2 	bgToBuf w-	readIORef (wChars w) >>= sequence_---	bufToWin w+	readIORef (fCharacters w) >>= sequence_ 	where	[x1, y1, x2, y2] = map round [x1_, y1_, x2_, y2_] -lineUndoBuf :: Win -> Double -> Double -> Double -> Double -> IO ()+lineUndoBuf :: Field -> Double -> Double -> Double -> Double -> IO () lineUndoBuf w x1_ y1_ x2_ y2_ =-	drawLine (wDisplay w) (wUndoBuf w) (wGC w) x1 y1 x2 y2+	X.drawLine (fDisplay w) (fUndoBuf w) (fGC w) x1 y1 x2 y2 	where	[x1, y1, x2, y2] = map round [x1_, y1_, x2_, y2_] -lineBuf :: Win -> Double -> Double -> Double -> Double -> IO ()+lineBuf :: Field -> Double -> Double -> Double -> Double -> IO () lineBuf w x1__ y1__ x2__ y2__ = do 	(x1_, y1_) <- convertPos w x1__ y1__ 	(x2_, y2_) <- convertPos w x2__ y2__ 	let	[x1, y1, x2, y2] = map round [x1_, y1_, x2_, y2_]-	drawLine (wDisplay w) (wBuf w) (wGC w) x1 y1 x2 y2+	X.drawLine (fDisplay w) (fBuf w) (fGC w) x1 y1 x2 y2 -clearUndoBuf :: Win -> IO ()-clearUndoBuf w = winSizeRaw w >>=-	uncurry (fillRectangle (wDisplay w) (wUndoBuf w) (wGCWhite w) 0 0)+clearUndoBuf :: Field -> IO ()+clearUndoBuf w = fieldSizeRaw w >>=+	uncurry (fillRectangle (fDisplay w) (fUndoBuf w) (fGCBG w) 0 0) -flushWin :: Win -> IO ()-flushWin = flush . wDisplay+flushWin :: Field -> IO ()+flushWin f = do+	bufToWin f+	flush $ fDisplay f  {- changeColor :: Win -> Pixel -> IO ()-changeColor w = setForeground (wDisplay w) (wGC w)+changeColor w = setForeground (fDisplay w) (fGC w)  clearBG :: Win -> IO ()-clearBG w = winSizeRaw w >>=-	uncurry (fillRectangle (wDisplay w) (wBG w) (wGCWhite w) 0 0)+clearBG w = fieldSizeRaw w >>=+	uncurry (fillRectangle (fDisplay w) (fBG w) (fGCWhite w) 0 0) -}
xturtle.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.6  name:		xturtle-version:	0.0.5+version:	0.0.6 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -18,8 +18,8 @@   > :m Graphics.X11.Turtle   > f <- openField   > t <- newTurtle f-  > forward f 100-  > left f 50+  > forward t 100+  > left t 50   .   etc @@ -30,7 +30,7 @@ library   Hs-source-dirs:	src   Exposed-modules:	Graphics.X11.Turtle-  Build-depends:	base > 3 && < 5, yjtools, convertible, X11+  Build-depends:	base > 3 && < 5, yjtools >= 0.9.12, convertible, X11   Ghc-options:		-Wall   Other-modules:	Graphics.X11.WindowLayers,     Graphics.X11.TurtleInput,