packages feed

xturtle 0.0.2 → 0.0.4

raw patch · 5 files changed

+693/−521 lines, 5 files

Files

+ src/Graphics/X11/CharAndBG.hs view
@@ -0,0 +1,340 @@+module Graphics.X11.CharAndBG (+	Field,+	Turtle,+	openField,+	newTurtle,+	goto,+	rotate,+	direction,+	position,+	shape,+	shapesize,+	undo,+	clear,+	setUndoN,+	windowWidth,+	windowHeight,+	penup,+	pendown,+	isdown,++	testModuleCharAndBG+) where++import Graphics.X11.WindowLayers+import Control.Concurrent+import Data.IORef+import Control.Arrow+import Control.Monad++type Field = Win+type Turtle = Square++openField :: IO Field+openField = do+	w <- openWin+	flushWin w+	return w++newTurtle :: Field -> IO Turtle+newTurtle f = do+	s <- newSquare f+	showSquare s+	return s++goto :: Turtle -> Double -> Double -> IO ()+goto t x y = do+	(width, height) <- winSize (sWin t)+	moveSquare (sWin t) t (x + width / 2) (- y + height / 2)++rotate :: Turtle -> Double -> IO ()+rotate t = rotateSquare t . negate++direction :: Turtle -> IO Double+direction = fmap negate . readIORef . sDir++position :: Turtle -> IO (Double, Double)+position t = do+	(x_, y_) <- readIORef $ sPos t+	(width, height) <- winSize (sWin t)+	return (x_ - width / 2, - y_ + height / 2)++undo, undoGen :: Turtle -> IO ()+undoGen t = do+	rot : rots <- readIORef $ sRotHist t+	writeIORef (sRotHist t) rots+	d <- readIORef $ sDir t+	case rot of+		Just r -> rotateGen t (d - r) >> return ()+		Nothing -> undoSquare (sWin t) t++undo t = do+	n <- readIORef $ sUndoN t+	ns <- readIORef $ sUndoNs t+	case ns of+		n' : ns' -> do+			writeIORef (sUndoN t) n'+			writeIORef (sUndoNs t) ns'+		_ -> writeIORef (sUndoN t) 1+	print n+	replicateM_ n $ undoGen t++setUndoN :: Turtle -> Int -> IO ()+setUndoN t n = do+	n0 <- readIORef $ sUndoN t+	writeIORef (sUndoN t) n+	modifyIORef (sUndoNs t) (n0 :)++clear :: Turtle -> IO ()+clear Square{sWin = w, sLayer = l} = clearLayer w l++windowWidth, windowHeight :: Turtle -> IO Double+windowWidth = fmap fst . winSize . sWin+windowHeight = fmap snd . winSize . sWin++penup, pendown :: Turtle -> IO ()+penup = flip writeIORef False . sPenDown+pendown = flip writeIORef True . sPenDown++isdown :: Turtle -> IO Bool+isdown = readIORef . sPenDown++data Square = Square{+	sLayer :: Layer,+	sChar :: Character,+	sPos :: IORef (Double, Double),+	sHistory :: IORef [(Double, Double)],+	sSize :: IORef Double,+	sDir :: IORef Double,+	sShape :: IORef [(Double, Double)],+	sUndoN :: IORef Int,+	sUndoNs :: IORef [Int],+	sIsRotated :: IORef Bool,+	sRotHist :: IORef [Maybe Double],+	sPenDown :: IORef Bool,+	sWin :: Win+ }++testModuleCharAndBG :: IO ()+testModuleCharAndBG = main++main :: IO ()+main = do+	w <- openWin+	s <- newSquare w+	s1 <- newSquare w+	shape s1 "turtle"+	shapesize s1 1+	moveSquare w s 100 105+	moveSquare w s1 200 30+	moveSquare w s 50 300+	moveSquare w s1 20 30+	moveSquare w s 300 300+	shapesize s1 2+	undoSquare w s+	moveSquare w s 300 400+	rotateSquare s1 0+	undoSquare w s+	moveSquare w s 300 200+	undoSquare w s+	undoSquare w s1+	undoSquare w s+	getLine >> return ()++newSquare :: Win -> IO Square+newSquare w = do+	l <- addLayer w+	c <- addCharacter w+	(width, height) <- winSize w+	p <- newIORef (width / 2, height / 2)+	h <- newIORef []+	sr <- newIORef 1+	dr <- newIORef 0+	rsh <- newIORef classic+	run <- newIORef 1+	runs <- newIORef []+	isr <- newIORef False+	srh <- newIORef []+	rpd <- newIORef True+	return Square{+		sLayer = l,+		sChar = c,+		sPos = p,+		sHistory = h,+		sSize = sr,+		sWin = w,+		sShape = rsh,+		sDir = dr,+		sUndoN = run,+		sUndoNs = runs,+		sIsRotated = isr,+		sRotHist = srh,+		sPenDown = rpd+	 }++shape :: Square -> String -> IO ()+shape s@Square{sShape = rsh} name =+	case name of+		"turtle" -> do+			writeIORef rsh turtle+			showSquare s+		"clasic" -> do+			writeIORef rsh classic+			showSquare s+		_ -> return ()++shapesize :: Square -> Double -> IO ()+shapesize s size = do+	writeIORef (sSize s) size+	p <- readIORef $ sPos s+	uncurry (moveSquare (sWin s) s) p++step :: Double+step = 10+stepTime :: Int+stepTime = 10000++stepDir :: Double+stepDir = 5+stepDirTime :: Int+stepDirTime = 10000++getPoints :: Double -> Double -> Double -> Double -> [(Double, Double)]+getPoints x1 y1 x2 y2 = let+	len = ((x2 - x1) ** 2 + (y2 - y1) ** 2) ** (1/2)+	dx = (x2 - x1) * step / len+	dy = (y2 - y1) * step / len in+	zip (takeWhile (before dx x2) [x1, x1 + dx ..])+		(takeWhile (before dy y2) [y1, y1 + dy ..]) +++			[(x2, y2)]++before :: (Num a, Ord a) => a -> a -> a -> Bool+before d t x = signum d * t >= signum d * x++showAnimation :: Bool -> Win -> Square -> Double -> Double -> Double -> Double -> IO ()+showAnimation pd w s x1 y1 x2 y2 = do+	(size, d, sh) <- getSizeDirShape s+	if pd then setPolygonCharacterAndLine w (sChar s)+				(getShape sh size d x2 y2) (x1, y1) (x2, y2)+		else setPolygonCharacter w (sChar s) (getShape sh size d x2 y2)+	bufToWin w+	flushWin w++getSizeDirShape :: Square -> IO (Double, Double, [(Double, Double)])+getSizeDirShape s = do+	size <- readIORef (sSize s)+	d <- readIORef (sDir s)+	sh <- readIORef (sShape s)+	return (size, d, sh)++showSquare :: Square -> IO ()+showSquare s@Square{sWin = w} = do+	(x, y) <- readIORef $ sPos s+	(size, d, sh) <- getSizeDirShape s+	setPolygonCharacter w (sChar s) (getShape sh size d x y)+	bufToWin w+	flushWin w++moveSquare :: Win -> Square -> Double -> Double -> IO ()+moveSquare w s@Square{sPos = p} x2 y2 = do+	modifyIORef (sRotHist s) (Nothing :)+	writeIORef (sIsRotated s) False+	(x1, y1) <- readIORef p+	modifyIORef (sHistory s) ((x1, y1) :)+	pd <- readIORef $ sPenDown s+	mapM_ (\(x, y) -> showAnimation pd w s x1 y1 x y >> threadDelay stepTime) $+		getPoints x1 y1 x2 y2+	writeIORef p (x2, y2)+	when pd $ line w (sLayer s) x1 y1 x2 y2+{-+	setPolygonCharacter w (sChar s)+		[(x2, y2), (x2 + 10, y2), (x2 + 10, y2 + 10), (x2, y2 + 10)]+-}++getDirections :: Double -> Double -> [Double]+getDirections ds de = takeWhile beforeDir [ds, ds + dd ..] ++ [de]+	where+	sig = signum (de - ds)+	dd = sig * stepDir+	beforeDir x = sig * x < sig * de++setDirSquare :: Square -> Double -> IO ()+setDirSquare s@Square{sDir = dr} d = do+	writeIORef dr d+	showSquare s++rotateSquare :: Square -> Double -> IO ()+rotateSquare s d = do+	d0 <- rotateGen s d+	modifyIORef (sRotHist s) (Just (d - d0) :)+rotateGen :: Square -> Double -> IO Double+rotateGen s@Square{sDir = dr} d = do+	d0 <- readIORef dr+	mapM_ ((>> threadDelay stepDirTime) . setDirSquare s) $ getDirections d0 d+	writeIORef dr (d `modd` 360)+	return d0++modd :: (Num a, Ord a) => a -> a -> a+modd x y+	| x < 0 = modd (x + y) y+	| x < y = x+	| otherwise = modd (x - y) y++undoSquare :: Win -> Square -> IO ()+undoSquare w s@Square{sLayer = l} = do+	undoLayer w l+	(x1, y1) <- readIORef $ sPos s+	p@(x2, y2) : ps <- readIORef $ sHistory s+--	moveSquare w s x y+--	showAnimation w s x1 y1 x y+	mapM_ (\(x, y) -> showAnimation True w s x2 y2 x y >> threadDelay 50000) $+		getPoints x1 y1 x2 y2+	writeIORef (sPos s) p+	writeIORef (sHistory s) ps++getShape ::+	[(Double, Double)] -> Double -> Double -> Double -> Double -> [(Double, Double)]+getShape sh s d x y =+	map (uncurry (addDoubles (x, y)) . rotatePointD d . mulPoint s) sh++classic :: [(Double, Double)]+classic = clssc ++ reverse (map (second negate) clssc)+	where+	clssc = [+		(- 10, 0),+		(- 16, 6),+		(0, 0)+	 ]++turtle :: [(Double, Double)]+turtle = ttl ++ reverse (map (second negate) ttl)+	where+	ttl = [+		(- 10, 0),+		(- 8, - 3),+		(- 10, - 5),+		(- 7, - 9),+		(- 5, - 6),+		(0, - 8),+		(4, - 7),+		(6, - 10),+		(8, - 7),+		(7, - 5),+		(10, - 2),+		(13, - 3),+		(16, 0)+	 ]++addDoubles :: (Double, Double) -> Double -> Double -> (Double, Double)+addDoubles (x, y) dx dy = (x + dx, y + dy)++rotatePointD :: Double -> (Double, Double) -> (Double, Double)+rotatePointD = rotatePointR . (* pi) . (/ 180)++rotatePointR :: Double -> (Double, Double) -> (Double, Double)+rotatePointR rad (x, y) =+	(x * cos rad - y * sin rad, x * sin rad + y * cos rad)++mulPoint :: Double -> (Double, Double) -> (Double, Double)+mulPoint s (x, y) = (x * s, y * s)+
src/Graphics/X11/Turtle.hs view
@@ -1,359 +1,63 @@ module Graphics.X11.Turtle (-	initTurtle,-	closeTurtle,+	Turtle,+	openField,+	newTurtle,+	shape, 	shapesize,-	goto, 	forward, 	backward,+	circle,+	undo, 	left, 	right,-	penup,+	clear,+	home, 	pendown,+	penup, 	isdown,-	home,-	circle,-	clear,-	undoAll,-	undo,-	distance,--	Position,-	testModuleTurtle+	distance ) where -import Graphics.X11.World-import Data.IORef-import Data.List-import System.IO.Unsafe-import Control.Arrow (second)-import Control.Monad.Tools+import Graphics.X11.CharAndBG import Control.Monad-import Control.Concurrent-import Data.Maybe -world :: IORef World-world = unsafePerformIO $ newIORef undefined+forward, backward, forwardNotSetUndo :: Turtle -> Double -> IO ()+forward t dist = do+	setUndoN t 1+	forwardNotSetUndo t dist -windowWidth :: IO Double-windowWidth = readIORef world >>= fmap fst . getWindowSize+forwardNotSetUndo t dist = do+	dir <- direction t+	(x0, y0) <- position t+	let	xd = dist * cos (dir * pi / 180)+		yd = dist * sin (dir * pi / 180)+	goto t (x0 + xd) (y0 + yd) -windowHeight :: IO Double-windowHeight = readIORef world >>= fmap snd . getWindowSize -position :: IO (Double, Double)-position = do-	w <- readIORef world-	(x, y) <- getCursorPos w-	width <- windowWidth-	height <- windowHeight-	return (x - width / 2, height / 2 - y)--distance :: Double -> Double -> IO Double-distance x0 y0 = do-	(x, y) <- position-	return $ ((x - x0) ** 2 + (y - y0) ** 2) ** (1 / 2)--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--penState :: IORef PenState-penState = unsafePerformIO $ newIORef PenDown--testModuleTurtle :: IO ()-testModuleTurtle = main--main :: IO ()-main = do-	putStrLn "module Turtle"-	initTurtle-	w <- readIORef world-	redrawLines-	withEvent w () $ \() ev ->-		case ev of-			ExposeEvent{} -> do-				drawWorld w-				return ((), True)-			KeyEvent{} -> do-				ch <- eventToChar w ev-				return ((), (ch /= 'q'))-			ClientMessageEvent{} ->-				return ((), not $ isDeleteEvent w ev)-			AnyEvent{ev_event_type = 14} ->-				return ((), True)-			_ -> 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-	setCursorPos w 100 200-	setCursorDir w 0-	setCursorSize w 2-	setCursorShape w displayTurtle-	drawWorld w-	flushWorld w-	writeIORef world w-	width <- windowWidth-	height <- windowHeight-	setCursorPos w (width / 2) (height / 2)-	drawWorld w-	flushWorld w--shapesize :: Double -> IO ()-shapesize s = do-	w <- readIORef world-	setCursorSize w s-	drawWorld w-	flushWorld w--goto, rawGoto :: Double -> Double -> IO ()-goto x y = do-	width <- windowWidth-	height <- windowHeight-	rawGoto (x + width / 2) (- y + height / 2)-		>> setUndoPoint-rawGoto xTo yTo = do-	w <- readIORef world-	(x0, y0) <- getCursorPos w-	let	step = 10-		distX = xTo - x0-		distY = yTo - y0-		dist = (distX ** 2 + distY ** 2) ** (1 / 2)-		dx = step * distX / dist-		dy = step * distY / dist-	(x', y') <- if (dist <= step) then return (x0, y0) else doWhile (x0, y0) $ \(x, y) -> do-		let	nx = x + dx-			ny = y + dy-		setCursorPos w nx ny-		drawLine w x y nx ny-		drawWorld w-		flushWorld w-		threadDelay 20000-		return ((nx, ny),-			(nx + dx - x0) ** 2 + (ny + dy - y0) ** 2 < dist ** 2)-	setCursorPos w xTo yTo-	drawLine w x' y' xTo yTo-	drawWorld w-	flushWorld w--forward, rawForward :: Double -> IO ()-forward len = rawForward len >> setUndoPoint-rawForward len = do-	w <- readIORef world-	(x0, y0) <- getCursorPos w-	d <- getCursorDir w-	let	rad = d * pi / 180-		nx' = x0 + len * cos rad-		ny' = y0 + len * sin rad-	rawGoto nx' ny'--backward :: Double -> IO ()-backward = forward . negate--penup :: IO ()-penup = writeIORef penState PenUp--pendown :: IO ()-pendown = writeIORef penState PenDown--isdown :: IO Bool-isdown = do-	ps <- readIORef penState-	return $ case ps of-		PenUp -> False-		PenDown -> True--drawLine :: World -> Double -> Double -> Double -> Double -> IO ()-drawLine w x1 y1 x2 y2 = do-	let act buf = do-		ps <- readIORef penState-		when (doesPenDown ps) $-			lineToBG w buf (round x1) (round y1) (round x2) (round y2)-	act BG-	dir <- readIORef world >>= getCursorDir -	putToPastDrawLines (x2, y2) dir act--redrawLines :: IO ()-redrawLines = do-	w <- readIORef world-	dls <- fmap (map fromJust . filter isJust) $ readIORef pastDrawLines-	clear-	flip mapM_ dls $ \dl -> do-		snd dl BG-		drawWorld w-		flushWorld w-		threadDelay 20000--undoAll :: IO ()-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 (($ BG) . snd) dls)-		$ \((pos, dir), dl) -> do-		cleanBG w BG-		dl-		uncurry (setCursorPos w) pos-		setCursorDir w dir-		drawWorld w-		flushWorld w-		threadDelay 20000--undo :: IO ()-undo = do-	w <- readIORef world-	dls <- fmap init $ readIORef pastDrawLines-	let	draw = map (map fromJust . filter isJust)-			$ takeWhile (isJust . last) $ reverse $ inits dls-		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 (($ BG) . snd)) draw') $ \((pos, dir), dl) -> do-		cleanBG w BG-		undoBufToBG w-		dl-		uncurry (setCursorPos w) pos-		setCursorDir w dir-		drawWorld w-		flushWorld w-		threadDelay 20000-	modifyIORef pastDrawLines $ reverse . dropWhile isJust . tail . reverse--rotateBy :: Double -> IO ()-rotateBy dd = do-	w <- readIORef world-	d0 <- getCursorDir w-	let	nd = (d0 + dd) `gMod` 360-	setCursorDir w nd-	drawWorld w-	flushWorld w-	pos <- getCursorPos w-	putToPastDrawLines pos nd $ const (return ())--rotateTo :: Double -> IO ()-rotateTo d = do-	w <- readIORef world-	d0 <- getCursorDir w-	let	step = 5-		dd = d - d0-	replicateM_ (abs dd `gDiv` step) $-		rotateBy (signum dd * step) >> threadDelay 10000-	setCursorDir w d-	drawWorld w-	flushWorld w--rotate, rawRotate :: Double -> IO ()-rotate d = rawRotate d >> setUndoPoint-rawRotate d = do-	w <- readIORef world-	d0 <- getCursorDir w-	rotateTo $ d0 + d--gDiv :: (Num a, Ord a, Integral b) => a -> a -> b-x `gDiv` y-	| x >= y = 1 + (x - y) `gDiv` y-	| otherwise = 0--gMod :: (Num a, Ord a) => a -> a -> a-x `gMod` y-	| x >= y = (x - y) `gMod` y-	| otherwise = x--right :: Double -> IO ()-right = rotate--left :: Double -> IO ()-left = rotate . negate--circle :: Position -> IO ()-circle r = replicateM_ 36 $ do-	rawForward $ (2 * fromIntegral r * pi / 36 :: Double)-	rawRotate (- 10)--home :: IO ()-home = goto 0 0 >> rotateTo 0--clear :: IO ()-clear = do-	w <- readIORef world-	cleanBG w BG-	drawWorld w >> flushWorld w-	pos <- getCursorPos w-	dir <- getCursorDir w-	putToPastDrawLines pos dir $ cleanBG w--closeTurtle :: IO ()-closeTurtle = readIORef world >>= closeWorld--displayTurtle :: World -> Double -> Double -> Double -> Double -> IO ()-displayTurtle w s d x y =-	makeFilledPolygonCursor w $ map (uncurry $ addPoint $ Point (round x) (round y))-		$ map (rotatePointD d)-		$ map (mulPoint s) turtle--addPoint :: Point -> Position -> Position -> Point-addPoint (Point x y) dx dy = Point (x + dx) (y + dy)+backward t = forward t . negate -rotatePointD :: Double -> (Position, Position) -> (Position, Position)-rotatePointD = rotatePointR . (* pi) . (/ 180)+left, right :: Turtle -> Double -> IO ()+left t dd = do+	dir <- direction t+	rotate t (dir + dd) -rotatePointR :: Double -> (Position, Position) -> (Position, Position)-rotatePointR rad (x, y) =-	(x `mul` cos rad - y `mul` sin rad, x `mul` sin rad + y `mul` cos rad)+right t = left t . negate -mulPoint :: Double -> (Position, Position) -> (Position, Position)-mulPoint s (x, y) = (x `mul` s, y `mul` s)+circle :: Turtle -> Double -> IO ()+circle t r = do+	setUndoN t 73+	forwardNotSetUndo t (r * pi / 36)+	left t 10+	replicateM_ 35 $ forwardNotSetUndo t (2 * r * pi / 36) >>+		left t 10+	forwardNotSetUndo t (r * pi / 36) -mul :: (Integral a, RealFrac b) => a -> b -> a-x `mul` y = round $ fromIntegral x * y+home :: Turtle -> IO ()+home t = do+	goto t 0 0+	rotate t 0 -turtle :: [(Position, Position)]-turtle = ttl ++ reverse (map (second negate) ttl)-	where-	ttl = [-		(- 10, 0),-		(- 8, - 3),-		(- 10, - 5),-		(- 7, - 9),-		(- 5, - 6),-		(0, - 8),-		(4, - 7),-		(6, - 10),-		(8, - 7),-		(7, - 5),-		(10, - 2),-		(13, - 3),-		(16, 0)-	 ]+distance :: Turtle -> Double -> Double -> IO Double+distance t x0 y0 = do+	(x, y) <- position t+	return $ ((x - x0) ** 2 + (y - y0) ** 2) ** (1 / 2)
+ src/Graphics/X11/WindowLayers.hs view
@@ -0,0 +1,304 @@+module Graphics.X11.WindowLayers (+	Win,+	openWin,+	flushWin,+	winSize,++	clearUndoBuf,+--	lineUndoBuf,+	clearBG,+	fillPolygonBuf,++--	lineWin,+	changeColor,+	putSome,+	line,++	undoBufToBG,+	bgToBuf,+	bufToWin,++	addExposeAction,+	setExposeAction,+	setCharacterAction,+	setCharacter,+	setPolygonCharacter,+	setPolygonCharacterAndLine,+--	undoAction,+	addLayer,+	addCharacter,++	undoLayer,+	clearLayer,++	Layer,+	Character,+) where++import Graphics.X11(+	Window, Pixmap, Atom,++	openDisplay, closeDisplay, flush, defaultScreen, rootWindow,+	whitePixel, blackPixel,	defaultDepth,+	createSimpleWindow, mapWindow, createPixmap, internAtom, createGC,++	setForeground, copyArea,+	drawLine, fillRectangle, fillPolygon, nonconvex, coordModeOrigin,++	setWMProtocols, selectInput, allocaXEvent, nextEvent,+	keyPressMask, exposureMask,++	getGeometry, initThreads+ )+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)++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 ()]+ }++data Layer = Layer Int+data Character = Character Int++openWin :: IO Win+openWin = do+	_ <- initThreads+	dpy <- openDisplay ""+	del <- internAtom dpy "WM_DELETE_WINDOW" True+	let	scr = defaultScreen dpy+	root <- rootWindow dpy scr+	(_, _, _, rWidth, rHeight, _, _) <- getGeometry dpy root+	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+	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+	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+				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+	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++undoN :: Int+undoN = 300++clearLayer :: Win -> Layer -> IO ()+clearLayer w l@(Layer lid) = do+	setExposeAction w l (const $ const $ return ())+	buffed <- readIORef $ wBuffed w+	writeIORef (wBuffed w) $+		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++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++setExposeAction :: Win -> Layer -> (Win -> Bool -> IO ()) -> IO ()+setExposeAction w@Win{wExpose = we} (Layer 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+	undoBufToBG w+	readIORef we >>= mapM_ ($ False) . concat+	bgToBuf w+	readIORef (wChars w) >>= sequence_+--	bufToWin w+--	flushWin w++setCharacter :: Win -> Character -> IO () -> IO ()+setCharacter w c act = do+	bgToBuf w+	setCharacterAction w c act+	readIORef (wChars w) >>= sequence_+--	bufToWin w+--	flushWin w++setCharacterAction :: Win -> Character -> IO () -> IO ()+setCharacterAction Win{wChars = wc} (Character 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++{-+undoAction :: Win -> Layer -> IO ()+undoAction w@Win{wExpose = we} (Layer lid) = do+	clearWin w+	modifyIORef we init+	readIORef we >>= sequence_+	flushWin w+-}++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 w = do+	(width, height) <- winSizeRaw w+	copyArea (wDisplay w) (wUndoBuf w) (wBG w) (wGC w) 0 0 width height 0 0++bgToBuf :: Win -> IO ()+bgToBuf w = do+	(width, height) <- winSizeRaw w+	copyArea (wDisplay w) (wBG w) (wBuf w) (wGC w) 0 0 width height 0 0++bufToWin :: Win -> IO ()+bufToWin w = do+	(width, height) <- winSizeRaw w+	copyArea (wDisplay w) (wBuf w) (wWindow w) (wGC w) 0 0 width height 0 0++fillPolygonBuf :: Win -> [(Double, Double)] -> IO ()+fillPolygonBuf w ps = fillPolygon (wDisplay w) (wBuf w) (wGC w) (map dtp ps)+						nonconvex coordModeOrigin+	where+	dtp (x, y) = Point (round x) (round y)++setPolygonCharacter :: Win -> Character -> [(Double, Double)] -> IO ()+setPolygonCharacter w c ps = setCharacter w c (fillPolygonBuf w ps)++setPolygonCharacterAndLine ::+	Win -> 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)++putSome :: Win -> (Double, Double) -> IO ()+putSome w (x, y) = do+	bgToBuf w+	fillPolygonBuf w [(x, y), (x + 10, y), (x + 10, y + 10), (x, y + 10)]+	bufToWin w+	flushWin w++line :: Win -> Layer -> Double -> Double -> Double -> Double -> IO ()+line w l x1 y1 x2 y2 = do+	lineWin w x1 y1 x2 y2+	addExposeAction w l $ \w' buf -> if buf+		then lineUndoBuf w' x1 y1 x2 y2+		else lineWin w' x1 y1 x2 y2++lineWin :: Win -> Double -> Double -> Double -> Double -> IO ()+lineWin w x1_ y1_ x2_ y2_ = do+	drawLine (wDisplay w) (wBG w) (wGC w) x1 y1 x2 y2+	bgToBuf w+	readIORef (wChars w) >>= sequence_+--	bufToWin w+	where	[x1, y1, x2, y2] = map round [x1_, y1_, x2_, y2_]++lineUndoBuf :: Win -> Double -> Double -> Double -> Double -> IO ()+lineUndoBuf w x1_ y1_ x2_ y2_ =+	drawLine (wDisplay w) (wUndoBuf w) (wGC w) x1 y1 x2 y2+	where	[x1, y1, x2, y2] = map round [x1_, y1_, x2_, y2_]++lineBuf :: Win -> Double -> Double -> Double -> Double -> IO ()+lineBuf w x1_ y1_ x2_ y2_ =+	drawLine (wDisplay w) (wBuf w) (wGC w) x1 y1 x2 y2+	where	[x1, y1, x2, y2] = map round [x1_, y1_, x2_, y2_]++clearBG :: Win -> IO ()+clearBG w = winSizeRaw w >>=+	uncurry (fillRectangle (wDisplay w) (wBG w) (wGCWhite w) 0 0)++clearUndoBuf :: Win -> IO ()+clearUndoBuf w = winSizeRaw w >>=+	uncurry (fillRectangle (wDisplay w) (wUndoBuf w) (wGCWhite w) 0 0)++flushWin :: Win -> IO ()+flushWin = flush . wDisplay++changeColor :: Win -> Pixel -> IO ()+changeColor w = setForeground (wDisplay w) (wGC w)
− src/Graphics/X11/World.hs 
@@ -1,177 +0,0 @@-module Graphics.X11.World (-	World,-	openWorld,-	setCursorPos,-	getCursorPos,-	setCursorDir,-	getCursorDir,-	setCursorSize,-	setCursorShape,-	drawWorld,-	undoBufToBG,-	closeWorld,-	withEvent,-	flushWorld,-	eventToChar,-	isDeleteEvent,-	makeFilledPolygonCursor,-	lineToBG,-	cleanBG,-	getWindowSize,-	Buf(..),--	Event(..),-	Position,-	Dimension,-	Point(..),-	testModuleWorld-) where--import Graphics.X11-import Graphics.X11.Xlib.Extras-import Data.IORef-import Data.Bits-import Data.Char-import Data.Convertible-import Control.Monad.Tools--data World = World{-	wDisplay :: Display,-	wWindow :: Window,-	wGC :: GC,-	wDel :: Atom,-	wBG :: Pixmap,-	wBuf :: Pixmap,-	wUndoBuf :: Pixmap,-	wPos :: IORef (Double, Double),-	wDir :: IORef Double,-	wSize :: IORef Double,-	wShape :: IORef (World -> Double -> Double -> Double -> Double -> IO ())- }--getWindowSize :: World -> IO (Double, Double)-getWindowSize w = do-	(_, _, _, width, height, _, _) <- getGeometry (wDisplay w) (wWindow w)-	return (fromIntegral width, fromIntegral height)--setCursorPos :: World -> Double -> Double -> IO ()-setCursorPos w x y = writeIORef (wPos w) (x, y)--getCursorPos :: World -> IO (Double, Double)-getCursorPos w = readIORef (wPos w)--setCursorDir :: World -> Double -> IO ()-setCursorDir w d = writeIORef (wDir w) d--getCursorDir :: World -> IO Double-getCursorDir w = readIORef (wDir w)--setCursorSize :: World -> Double -> IO ()-setCursorSize w s = writeIORef (wSize w) s--setCursorShape ::-	World -> (World -> Double -> Double -> Double -> Double -> IO ()) -> IO ()-setCursorShape w s = writeIORef (wShape w) s--testModuleWorld :: IO ()-testModuleWorld = main--main :: IO ()-main = do-	putStrLn "module World"-	w <- openWorld-	withEvent w () $ \() ev ->-		case ev of-			ExposeEvent{} -> return ((), True)-			KeyEvent{} -> do-				ch <- eventToChar w ev-				return ((), ch /= 'q')-			ClientMessageEvent{} ->-				return ((), not $ isDeleteEvent w ev)-			_ -> error $ "not implemented for event " ++ show ev-	closeWorld w--openWorld :: IO World-openWorld = do-	dpy <- openDisplay ""-	del <- internAtom dpy "WM_DELETE_WINDOW" True-	let	scr = defaultScreen dpy-	root <- rootWindow dpy scr-	(_, _, _, width, height, _, _) <- getGeometry dpy root-	let	black = blackPixel dpy scr-		white = whitePixel dpy scr-	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-	flush dpy-	initPos <- newIORef undefined-	initDir <- newIORef undefined-	initSize <- newIORef undefined-	initShape <- newIORef undefined-	return $ World dpy win gc del bg buf undoBuf initPos initDir initSize initShape--closeWorld :: World -> IO ()-closeWorld = closeDisplay . wDisplay--drawWorld :: World -> IO ()-drawWorld w = do-	(_, _, _, width, height, _, _) <- getGeometry (wDisplay w) (wWindow w)-	copyArea (wDisplay w) (wBG w) (wBuf w) (wGC w) 0 0 width height 0 0-	(x, y) <- readIORef $ wPos w-	d <- readIORef $ wDir w-	s <- readIORef $ wSize w-	displayCursor <- readIORef $ wShape w-	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-	getEvent e >>= act stat--eventToChar :: World -> Event -> IO Char-eventToChar w ev =-	fmap (chr . fromEnum) $ keycodeToKeysym (wDisplay w) (ev_keycode ev) 0--isDeleteEvent :: World -> Event -> Bool-isDeleteEvent w ev@ClientMessageEvent{} = convert (head $ ev_data ev) == wDel w-isDeleteEvent _ _ = False--makeFilledPolygonCursor :: World -> [Point] -> IO ()-makeFilledPolygonCursor w ps =-	fillPolygon (wDisplay w) (wBuf w) (wGC w) ps nonconvex coordModeOrigin--data Buf = BG | UndoBuf--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-	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.2+version:	0.0.4 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -16,9 +16,10 @@   In ghci   .   > :m Graphics.X11.Turtle-  > initTurtle-  > forward 100-  > left 50+  > f <- openField+  > t <- newTurtle f+  > forward f 100+  > left f 50   .   etc @@ -31,4 +32,4 @@   Exposed-modules:	Graphics.X11.Turtle   Build-depends:	base > 3 && < 5, yjtools, convertible, X11   Ghc-options:		-Wall-  Other-modules:	Graphics.X11.World+  Other-modules:	Graphics.X11.WindowLayers, Graphics.X11.CharAndBG