packages feed

xturtle 0.0.15 → 0.0.16

raw patch · 14 files changed

+956/−873 lines, 14 filessetup-changed

Files

Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
src/Graphics/X11/Turtle.hs view
@@ -2,86 +2,88 @@ {-# LANGUAGE TypeSynonymInstances #-}  module Graphics.X11.Turtle (+	-- * meta data+	xturtleVersion,++	-- * types and classes 	Field, 	Turtle,+	ColorClass, +	-- * beginings and endings 	openField, 	closeField,+	waitField, 	newTurtle, 	killTurtle, +	-- * move turtle 	forward, 	backward,-	right,-	left, 	goto, 	setx, 	sety,+	right,+	left, 	setheading,-	home, 	circle,+	write,+	home,+	clear, 	undo, +	-- * change turtle state+	shape,+	shapesize,+	showturtle,+	hideturtle,+	pendown,+	penup,+	pencolor,+	bgcolor,+	pensize,+	degrees,+	radians,++	-- * turtle information 	position, 	xcor, 	ycor, 	heading, 	towards, 	distance,--	pendown,-	penup, 	isdown,--	bgcolor,-	rgbToColor,-	pencolor,-	Color(..),-	pensize,--	clear,--	showturtle,-	hideturtle, 	isvisible,--	shape,-	shapesize,--	degrees,-	radians,- 	windowWidth, 	windowHeight,++	-- * on events 	onclick, 	onrelease, 	ondrag, 	onkeypress,-	waitField, -	xturtleVersion,-	write,-+	-- * save and load 	getInputs, 	sendInputs,-	getSVG,-	ColorClass+	getSVG ) where -import Graphics.X11.TurtleMove(+import Graphics.X11.Turtle.Move( 	Field, Layer, Character, 	forkIOX, openField, closeField, 	addCharacter, addLayer, fieldSize, clearLayer, clearCharacter, 	addThread, fieldColor, onclick, onrelease, ondrag, onkeypress, waitField, 	moveTurtle  )-import Graphics.X11.TurtleInput(+import Graphics.X11.Turtle.Input( 	TurtleInput(..), TurtleState,-	getTurtleStates, getPosition, getPendown, undonum, visible, direction,-	SVG, drawed, Color(..)+	getTurtleStates, undonum, visible, direction,+	drawed  )-import qualified Graphics.X11.TurtleInput as S(degrees)-import Graphics.X11.TurtleShape(lookupShape)+import qualified Graphics.X11.Turtle.Input as S(degrees, pendown, position)+import Graphics.X11.Turtle.Shape(nameToShape)+import Text.XML.YJSVG(SVG(..), Color(..)) import Control.Concurrent(Chan, writeChan, threadDelay, ThreadId, killThread) import Control.Monad(replicateM_, zipWithM_) import Prelude hiding(Left)@@ -89,7 +91,7 @@ import Data.Fixed(mod')  xturtleVersion :: (Int, String)-xturtleVersion = (29, "0.0.15")+xturtleVersion = (34, "0.0.16")  data Turtle = Turtle { 	field :: Field,@@ -106,7 +108,7 @@ newTurtle f = do 	ch <- addCharacter f 	l <- addLayer f-	(ic, tis, sts) <- getTurtleStates $ lookupShape "classic"+	(ic, tis, sts) <- getTurtleStates 	si <- newIORef 1 	let	t = Turtle { 			field = f,@@ -118,14 +120,15 @@ 			stateIndex = si, 			thread = undefined 		 }-	tid <- forkIOX $ zipWithM_ (moveTurtle ch l) sts $ tail sts+	tid <- forkIOX $ zipWithM_ (moveTurtle f ch l) sts $ tail sts 	addThread f tid+	shape t "classic" 	return t{thread = tid} -killTurtle :: Turtle -> IO ()-killTurtle t = do+killTurtle :: Field -> Turtle -> IO ()+killTurtle f t = do 	clearLayer $ layer t-	clearCharacter $ character t+	clearCharacter f $ character t 	killThread $ thread t  hideturtle, showturtle :: Turtle -> IO ()@@ -139,7 +142,7 @@ 	threadDelay 10000  shape :: Turtle -> String -> IO ()-shape t = sendCommand t . Shape . lookupShape+shape t = sendCommand t . Shape . nameToShape  shapesize :: Turtle -> Double -> IO () shapesize t = sendCommand t . ShapeSize@@ -187,9 +190,6 @@ penup = flip sendCommand Penup pendown = flip sendCommand Pendown -rgbToColor :: Double -> Double -> Double -> Color-rgbToColor r g b = RGB (round $ r * 0xff) (round $ g * 0xff) (round $ b * 0xff)- pencolor :: ColorClass c => Turtle -> c -> IO () pencolor t c = sendCommand t $ Pencolor $ getColor c @@ -227,7 +227,7 @@  position :: Turtle -> IO (Double, Double) position Turtle{stateIndex = si, states = s} =-	fmap (getPosition . (s !!)) $ readIORef si+	fmap (S.position . (s !!)) $ readIORef si  xcor, ycor :: Turtle -> IO Double xcor = fmap fst . position@@ -252,7 +252,7 @@ 	return $ ((x - x0) ** 2 + (y - y0) ** 2) ** (1 / 2)  isdown :: Turtle -> IO Bool-isdown t = fmap (getPendown . (states t !!)) $ readIORef $ stateIndex t+isdown t = fmap (S.pendown . (states t !!)) $ readIORef $ stateIndex t  isvisible :: Turtle -> IO Bool isvisible t = fmap (visible . (states t !!)) $ readIORef $ stateIndex t
+ src/Graphics/X11/Turtle/Field.hs view
@@ -0,0 +1,443 @@+module Graphics.X11.Turtle.Field(+	Field,+	withLock2,++	Layer,+	Character,++	openField,+	closeField,+	waitField,+	fieldColor,+	fieldSize,++	addLayer,+	addCharacter,++	drawLine,+	writeString,+	drawCharacter,+	drawCharacterAndLine,+	clearCharacter,++	undoLayer,+	clearLayer,+	flushLayer,++	onclick,+	onrelease,+	ondrag,+	onkeypress,++	forkIOX,+	addThread+) where++import Graphics.X11(+	Display, Window, Pixmap, Atom, GC, Point(..), Dimension, Position, Pixel,++	setLineAttributes, lineSolid, capRound, joinRound,++	openDisplay, closeDisplay, flush, defaultScreen, rootWindow,+	whitePixel, blackPixel,	defaultDepth,+	createSimpleWindow, mapWindow, createPixmap, internAtom, createGC,++	setForeground, copyArea,+	fillRectangle, fillPolygon, nonconvex, coordModeOrigin,++	setWMProtocols, selectInput, allocaXEvent, nextEvent, XEventPtr,+	keyPressMask, exposureMask, buttonPressMask, buttonReleaseMask,+	button1MotionMask,++	getGeometry, initThreads, connectionNumber, pending, destroyWindow,++	defaultVisual, defaultColormap, defaultScreenOfDisplay,+	Visual, Colormap,++	supportsLocale, setLocaleModifiers,+	xK_VoidSymbol, buttonPress, buttonRelease,+	allocNamedColor+ )+import qualified Graphics.X11 as X (drawLine, Color(..))+import Graphics.X11.Xlib.Extras(Event(..), getEvent)+import Graphics.X11.Xft+import Graphics.X11.Xrender+import Graphics.X11.Xim+import Graphics.X11.Turtle.Layers(undoLayer, clearLayer,+	Layers, Layer, Character, newLayers, setCharacter, addLayerAction)+import qualified Graphics.X11.Turtle.Layers as L(+	addLayer, addCharacter)++import Data.IORef(IORef, newIORef, readIORef, writeIORef, modifyIORef)+import Data.Bits((.|.), shift)+import Data.Convertible(convert)+import Data.Maybe++import Control.Monad(replicateM, forM_, forever, replicateM_, when, unless)+import Control.Monad.Tools(doWhile_, whenM, unlessM)+import Control.Arrow((***))+import Control.Concurrent(+	forkIO, ThreadId, Chan, newChan, writeChan, readChan, threadWaitRead,+	killThread)++import System.Posix.Types+import System.Locale.SetLocale+import Foreign.C.Types++import Text.XML.YJSVG(Color(..))++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,++	fLayers :: IORef Layers,++	fWait :: Chan (),+	fWait2 :: Chan (),+	fEvent :: Chan (Maybe Event),+	fClose :: Chan (),+	fClosed :: IORef Bool,+	fRunning :: IORef [ThreadId],+	fOnclick :: IORef (Int -> Double -> Double -> IO Bool),+	fOnrelease :: IORef (Double -> Double -> IO Bool),+	fOndrag :: IORef (Double -> Double -> IO ()),+	fPress :: IORef Bool,+	fKeypress :: IORef (Char -> IO Bool),+	fEnd :: Chan ()+ }++openField :: IO Field+openField = do+	_ <- setLocale LC_CTYPE Nothing >>= maybe (error "Can't set locale.") return+	_ <- initThreads+	unlessM supportsLocale $ error "Current locale is notSupported."+	_ <- setLocaleModifiers ""+	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+	bufs <- replicateM 3 $ createPixmap dpy root rWidth rHeight depth+	win <- createSimpleWindow dpy root 0 0 rWidth rHeight 1 black white+	im <- openIM dpy Nothing Nothing Nothing+	ic <- createIC im [XIMPreeditNothing, XIMStatusNothing] win+	fevent <- getICValue ic "filterEvents"+	[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 .|.+		buttonPressMask .|. buttonReleaseMask .|. button1MotionMask .|.+		fevent+	mapWindow dpy win+	[widthRef, heightRef] <- mapM newIORef [rWidth, rHeight]+	wait <- newChan+	wait2 <- newChan+	event <- newChan+	close <- newChan+	closed <- newIORef False+	running <- newIORef []+	onclickRef <- newIORef $ const $ const $ const $ return True+	onreleaseRef <- newIORef $ const $ const $ return True+	ondragRef <- newIORef $ const $ const $ return ()+	pressRef <- newIORef False+	keypressRef <- newIORef $ const $ return True+	endRef <- newChan+	writeChan wait ()+	writeChan wait2 ()+	fllRef <- newIORef undefined+	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,+		fWait = wait,+		fWait2 = wait2,+		fEvent = event,+		fClose = close,+		fClosed = closed,+		fRunning = running,+		fOnclick = onclickRef,+		fOnrelease = onreleaseRef,+		fOndrag = ondragRef,+		fPress = pressRef,+		fKeypress = keypressRef,+		fEnd = endRef,+		fLayers = fllRef+	 }+	_ <- forkIOX $ runLoop ic f+	flushWindow f+	fll <- newLayers 50 +		(winSize f >>= \(width, height) ->+			copyArea (fDisplay f) (fUndoBuf f) (fBG f) (fGC f) 0 0 width height 0 0)+		(winSize f >>=+			uncurry (fillRectangle (fDisplay f) (fUndoBuf f) (fGCBG f) 0 0))+		(winSize f >>= \(width, height) ->+			copyArea (fDisplay f) (fBG f) (fBuf f) (fGC f) 0 0 width height 0 0)+		(flushWindow f)+	return f{fLayers = fll}++runLoop :: XIC -> Field -> IO ()+runLoop ic f = allocaXEvent $ \e -> do+	endc <- waitInput f+	th1 <- forkIOX $ forever $ do+		evN <- pending $ fDisplay f+		replicateM_ (fromIntegral evN) $ do+			nextNotFilteredEvent (fDisplay f) e+			ev <- getEvent e+			writeChan (fEvent f) $ Just ev+		end <- readChan endc+		when end $ writeChan (fEvent f) Nothing+	doWhile_ $ do+		mev <- readChan $ fEvent f+		case mev of+			Just (ExposeEvent{}) -> do+				(_, _, _, width, height, _, _) <-+					getGeometry (fDisplay f) (fWindow f)+				writeIORef (fWidth f) width+				writeIORef (fHeight f) height+				return True+			Just (KeyEvent{}) -> do+				(mstr, mks) <- utf8LookupString ic e+				let	str = fromMaybe " " mstr+					_ks = fromMaybe xK_VoidSymbol mks+				readIORef (fKeypress f) >>= fmap and . ($ str) . mapM+			Just ev@ButtonEvent{} -> do+				pos <- convertPosRev f (ev_x ev) (ev_y ev)+				case ev_event_type ev of+					et	| et == buttonPress -> do+							writeIORef (fPress f) True+							fun <- readIORef (fOnclick f)+							uncurry (fun $ fromIntegral $ ev_button ev)+								pos+						| et == buttonRelease -> do+							writeIORef (fPress f) False+							readIORef (fOnrelease f) >>=+								($ pos) . uncurry+					_ -> error "not implement event"+			Just ev@MotionEvent{} -> do+				pos <- convertPosRev f (ev_x ev) (ev_y ev)+				whenM (readIORef $ fPress f) $+					readIORef (fOndrag f) >>= ($ pos) . uncurry+				return True+			Just ev@ClientMessageEvent{} ->+				return $ convert (head $ ev_data ev) /= fDel f+			Nothing -> killThread th1 >> return False+			_ -> return True+	destroyWindow (fDisplay f) (fWindow f)+	closeDisplay $ fDisplay f+	writeChan (fEnd f) ()++onclick :: Field -> (Int -> Double -> Double -> IO Bool) -> IO ()+onrelease :: Field -> (Double -> Double -> IO Bool) -> IO ()+onclick f = writeIORef $ fOnclick f+onrelease f = writeIORef $ fOnrelease f++ondrag :: Field -> (Double -> Double -> IO ()) -> IO ()+ondrag f = writeIORef $ fOndrag f++onkeypress :: Field -> (Char -> IO Bool) -> IO ()+onkeypress f = writeIORef $ fKeypress f++fieldColor :: Field -> Color -> IO ()+fieldColor f@Field{fDisplay = dpy} c = do+	clr <- getColorPixel dpy c+	setForeground (fDisplay f) (fGCBG f) clr+	let bufs = [fUndoBuf f, fBG f, fBuf f]+	width <- readIORef $ fWidth f+	height <- readIORef $ fHeight f+	forM_ bufs $ \bf -> fillRectangle (fDisplay f) bf (fGCBG f) 0 0 width height++getColorPixel :: Display -> Color -> IO Pixel+getColorPixel _ (RGB r g b) = return $ shift (fromIntegral r) 16 .|.+	shift (fromIntegral g) 8 .|. fromIntegral b+getColorPixel dpy (ColorName cn) = do+	let	scr = defaultScreen dpy+		colormap = defaultColormap dpy scr+	fmap (X.color_pixel . fst) $ allocNamedColor dpy colormap cn++getConnection :: Field -> Fd+getConnection = Fd . connectionNumber . fDisplay++waitInput :: Field -> IO (Chan Bool)+waitInput f = do+	c <- newChan+	_ <- forkIOX $ forever $ do+		threadWaitRead $ getConnection f+		writeChan c False+	_ <- forkIO $ do+		readChan $ fClose f+		writeChan c True+	return c++closeField :: Field -> IO ()+closeField f = do+	readIORef (fRunning f) >>= mapM_ killThread+	writeChan (fClose f) ()+	writeIORef (fClosed f) True++addThread :: Field -> ThreadId -> IO ()+addThread f tid = modifyIORef (fRunning f) (tid :)++flushLayer :: Field -> IO ()+flushLayer = flushWindow++addLayer :: Field -> IO Layer+addLayer = L.addLayer . fLayers++addCharacter :: Field -> IO Character+addCharacter = L.addCharacter . fLayers++runIfOpened :: Field -> IO a -> IO ()+runIfOpened f act = do+	cl <- readIORef $ fClosed f+	unless cl $ act >> return ()++drawLine :: Field ->+	Layer -> Double -> Color -> Double -> Double -> Double -> Double -> IO ()+drawLine f l lw_ clr x1 y1 x2 y2 = runIfOpened f $ -- withFLLayers f $ \ls ->+	addLayerAction l (drawLineBuf f lw clr fUndoBuf x1 y1 x2 y2,+		drawLineBuf f lw clr fBG x1 y1 x2 y2)+	where+	lw = round lw_++writeString :: Field -> Layer -> String -> Double -> Color ->+	Double -> Double -> String -> IO ()+writeString f l fname size clr x y str = -- withFLLayers f $ \ls ->+	addLayerAction l (writeStringBuf f fUndoBuf fname size clr x y str,+		writeStringBuf f fBG fname size clr x y str)++writeStringBuf :: Field -> (Field -> Pixmap) -> String -> Double ->+	Color -> Double -> Double -> String -> IO ()+writeStringBuf f buf fname size clr x_ y_ str = do+	let	dpy = fDisplay f+		scr = defaultScreen dpy+		scrN = defaultScreenOfDisplay dpy+		visual = defaultVisual dpy scr+		colormap = defaultColormap dpy scr+	xftDraw <- xftDrawCreate dpy (buf f) visual colormap+	xftFont <- xftFontOpen dpy scrN $ fname ++ "-" ++ show (round size :: Int)+	[(x, y)] <- convertPos f [(x_, y_)]+	withXftColor dpy visual colormap clr $ \c ->+		xftDrawString xftDraw c xftFont x y str++withXftColor ::+	Display -> Visual -> Colormap -> Color -> (XftColor -> IO a) -> IO a+withXftColor dpy visual colormap (RGB r g b) action =+	withXftColorValue dpy visual colormap color action+	where+	color = XRenderColor {+		xrendercolor_red = fromIntegral r * 0x100,+		xrendercolor_green = fromIntegral b * 0x100,+		xrendercolor_blue = fromIntegral g * 0x100,+		xrendercolor_alpha = 0xffff+	 }+withXftColor dpy visual colormap (ColorName cn) action =+	withXftColorName dpy visual colormap cn action++clearCharacter :: Field -> Character -> IO ()+clearCharacter f c = runIfOpened f $ -- withFLLayers f $ \ls ->+	setCharacter c $ return ()++drawCharacter :: Field -> Character -> Color -> [(Double, Double)] -> IO ()+drawCharacter f c cl sh = runIfOpened f $+	setCharacter c $ do+	clr <- getColorPixel (fDisplay f) cl+	setForeground (fDisplay f) (fGC f) clr+	fillPolygonBuf f sh++drawCharacterAndLine ::	Field -> Character -> Color -> [(Double, Double)] -> Double ->+	Double -> Double -> Double -> Double -> IO ()+drawCharacterAndLine f c cl ps lw x1 y1 x2 y2 =+	runIfOpened f $ -- withFLLayers f $ \ls -> do+		setCharacter c $ do+		clr <- getColorPixel (fDisplay f) cl+		setForeground (fDisplay f) (fGC f) clr+		fillPolygonBuf f ps >>+			drawLineBuf f (round lw) cl fBuf x1 y1 x2 y2++forkIOX :: IO () -> IO ThreadId+forkIOX = (initThreads >>) . forkIO++--------------------------------------------------------------------------------++fillPolygonBuf :: Field -> [(Double, Double)] -> IO ()+fillPolygonBuf f ps_ = do+	ps <- convertPos f ps_+	fillPolygon (fDisplay f) (fBuf f) (fGC f) (map (uncurry Point) ps)+		nonconvex coordModeOrigin++drawLineBuf :: Field -> Int -> Color -> (Field -> Pixmap) ->+	Double -> Double -> Double -> Double -> IO ()+drawLineBuf f@Field{fDisplay = dpy, fGC = gc} lw c bf x1_ y1_ x2_ y2_ = do+	clr <- getColorPixel dpy c+	setForeground (fDisplay f) (fGC f) clr+	setLineAttributes (fDisplay f) (fGC f) (fromIntegral lw) lineSolid capRound joinRound+	[(x1, y1), (x2, y2)] <- convertPos f [(x1_, y1_), (x2_, y2_)]+	X.drawLine dpy (bf f) gc x1 y1 x2 y2++convertPos :: Field -> [(Double, Double)] -> IO [(Position, Position)]+convertPos f ps = do+	(width, height) <- fieldSize f+	return $ (round . (+ width / 2) *** round . (+ height / 2) . negate)+		`map` ps++convertPosRev :: Field -> CInt -> CInt -> IO (Double, Double)+convertPosRev f x y = do+	(width, height) <- fieldSize f+	return (fromIntegral x - width / 2, fromIntegral (- y) + height / 2)++fieldSize :: Field -> IO (Double, Double)+fieldSize w = fmap (fromIntegral *** fromIntegral) $ winSize w++winSize :: Field -> IO (Dimension, Dimension)+winSize f = do+	width <- readIORef $ fWidth f+	height <- readIORef $ fHeight f+	return (width, height)++flushWindow :: Field -> IO ()+flushWindow = withLock $ \f -> do+	(width, height) <- winSize 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++withLock2 :: (Field -> IO a) -> Field -> IO a+withLock2 act f = do+	readChan $ fWait2 f+	ret <- act f+	writeChan (fWait2 f) ()+	return ret++waitField :: Field -> IO ()+waitField = readChan . fEnd++nextNotFilteredEvent :: Display -> XEventPtr -> IO ()+nextNotFilteredEvent dpy e = do+	nextEvent dpy e+	whenM (filterEvent e 0) $ nextNotFilteredEvent dpy e
+ src/Graphics/X11/Turtle/Input.hs view
@@ -0,0 +1,92 @@+module Graphics.X11.Turtle.Input (+	TurtleState,+	TurtleInput(..),++	getTurtleStates,+	position,+	pendown,+	undonum,+	visible,+	direction,+	degrees,+	drawed,+) where++import Graphics.X11.Turtle.State(TurtleState(..), initialTurtleState)+import Control.Concurrent.Chan(Chan, newChan, getChanContents)+import Prelude hiding(Left)+import Text.XML.YJSVG(SVG(..), Color(..), Position(..))++data TurtleInput+	= Shape [(Double, Double)]+	| ShapeSize Double+	| Goto Double Double+	| Rotate Double+	| Penup+	| Pendown+	| SetVisible Bool+	| Undo+	| Clear+	| Forward Double+	| Left Double+	| Undonum Int+	| Pencolor Color+	| Pensize Double+	| Degrees Double+	| Write String Double String+	deriving (Show, Read)++getTurtleStates :: IO (Chan TurtleInput, [TurtleInput], [TurtleState])+getTurtleStates = do+	let	ts0 = initialTurtleState+	c <- newChan+	tis <- getChanContents c+	return (c, tis, ts0 : ts0 : inputToTurtle [] ts0 tis)++nextTurtle :: TurtleState -> TurtleInput -> TurtleState+nextTurtle t (Shape sh) = (clearState t){shape = sh}+nextTurtle t (ShapeSize ss) = (clearState t){shapesize = ss}+nextTurtle t (Goto x y) = (clearState t){position = (x, y),+	drawed = if pendown t then ln : drawed t else drawed t,+	draw = if pendown t then Just ln else Nothing}+	where+	ln = Line (uncurry Center $ position t) (Center x y) (pencolor t)+		(pensize 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 (SetVisible v) = (clearState t){visible = v}+nextTurtle t (Undonum un) = (clearState t){undonum = un}+nextTurtle t (Clear) = (clearState t){clear = True, drawed = []}+nextTurtle t (Pencolor c) = (clearState t){pencolor = c}+nextTurtle t (Pensize ps) = (clearState t){pensize = ps}+nextTurtle t (Degrees ds) = (clearState t){+	degrees = ds,+	direction = direction t * ds / degrees t+ }+nextTurtle t (Write fnt sz str) = (clearState t){+	draw = Just d, drawed = d : drawed t+ }+	where+	(x, y) = position t+	d = Text (Center x y) sz (pencolor t) fnt str+nextTurtle _ _ = error "not defined"++clearState :: TurtleState -> TurtleState+clearState t = t{undo = False, undonum = 1, clear = False, draw = Nothing}++inputToTurtle :: [TurtleState] -> TurtleState -> [TurtleInput] -> [TurtleState]+inputToTurtle [] ts0 (Undo : tis) = ts0 : inputToTurtle [] ts0 tis+inputToTurtle (tsb : tsbs) _ (Undo : tis) =+	let ts1 = tsb{undo = True} in ts1 : inputToTurtle tsbs ts1 tis+inputToTurtle tsbs ts0 (Forward len : tis) = let+	(x0, y0) = position ts0+	dir = direction ts0 / degrees ts0+	x = x0 + len * cos (dir * 2 * pi)+	y = y0 + len * sin (dir * 2 * pi) in+	inputToTurtle tsbs ts0 $ Goto x y : tis+inputToTurtle tsbs ts0 (Left dd : tis) =+	inputToTurtle tsbs ts0 $ Rotate (direction ts0 + dd) : tis+inputToTurtle tsbs ts0 (ti : tis) =+	let ts1 = nextTurtle ts0 ti in ts1 : inputToTurtle (ts0 : tsbs) ts1 tis+inputToTurtle _ _ [] = error "no more input"
+ src/Graphics/X11/Turtle/Layers.hs view
@@ -0,0 +1,177 @@+module Graphics.X11.Turtle.Layers(+	Layers,+	Layer,+	Character,+	+	newLayers,+	addLayer,+	addCharacter,++	addLayerAction,+	undoLayer,+	clearLayer,+	setCharacter,+) where++import System.IO.Unsafe+import Data.IORef+import Data.List.Tools+import Control.Concurrent++lockChan :: Chan ()+lockChan = unsafePerformIO $ do+	c <- newChan+	writeChan c ()+	return c++withLock2 :: IO a -> IO a+withLock2 act = do+	readChan lockChan+	ret <- act+	writeChan lockChan ()+	return ret++withLock :: Layers -> (Layers -> IO a) -> IO a+withLock ls act = do+	readChan $ lock ls+	ret <- act ls+	writeChan (lock ls) ()+	return ret++data Layers = Layers{+	undoNum :: Int,+	undoLayersAction :: IO (),+	clearLayersAction :: IO (),+	clearCharactersAction :: IO (),+	flush :: IO (),+	buffed :: [IO ()],+	layers :: [[(IO (), IO ())]],+	characters :: [IO ()],+	lock :: Chan ()+ }++newLayers :: Int -> IO () -> IO () -> IO () -> IO () -> IO (IORef Layers)+newLayers un ula cla cca flsh = do+	ls <- newLayers_ un ula cla cca flsh+	newIORef ls++newLayers_ :: Int -> IO () -> IO () -> IO () -> IO () -> IO Layers+newLayers_ un ula cla cca flsh = do+	l <- newChan+	writeChan l ()+	return Layers{+		undoNum = un,+		undoLayersAction = ula,+		clearLayersAction = cla,+		clearCharactersAction = cca,+		flush = flsh,+		buffed = [],+		layers = [],+		characters = [],+		lock = l+	 }++data Layer = Layer{+	layerId :: Int,+	layerLayers :: IORef Layers+ }++data Character = Character{+	characterId :: Int,+	characterLayers :: IORef Layers+ }++addLayer :: IORef Layers -> IO Layer+addLayer rls = withLock2 $ do+	ls <- readIORef rls+	let	(lid, nls) = addLayer_ ls+	writeIORef rls nls+	return Layer{layerId = lid, layerLayers = rls}++addLayer_ :: Layers -> (Int, Layers)+addLayer_ ls =+	(length $ layers ls,+		ls{layers = layers ls ++ [[]], buffed = buffed ls ++ [return ()]})++addLayerAction :: Layer -> (IO (), IO ()) -> IO ()+addLayerAction Layer{layerId = lid, layerLayers = rls} acts = withLock2 $+	readIORef rls >>= flip withLock (\ls -> do+		nls <- addLayerAction_ ls lid acts+		writeIORef rls nls)++addLayerAction_ :: Layers -> Int -> (IO (), IO ()) -> IO Layers+addLayerAction_ ls l acts@(_, act) = do+	let actNum = length $ layers ls !! l+	act+	clearCharactersAction ls+	sequence_ $ characters ls+	if actNum < undoNum ls then+			return ls{layers =+				modifyAt (layers ls) l (++ [acts])}+		else do	fst $ head $ layers ls !! l+			return ls{+				layers = modifyAt (layers ls) l+					((++ [acts]) . tail),+				buffed = modifyAt (buffed ls) l+					(>> fst (head $ layers ls !! l))}++undoLayer :: Layer -> IO Bool+undoLayer Layer{layerId = lid, layerLayers = rls} = withLock2 $+	readIORef rls >>= flip withLock (\ls -> do+		mnls <- undoLayer_ ls lid+		maybe (return False)+			((>> return True) . writeIORef rls) mnls)++undoLayer_ :: Layers -> Int -> IO (Maybe Layers)+undoLayer_ ls l =+	if null $ layers ls !! l then return Nothing else do+		let nls = modifyAt (layers ls) l init+		undoLayersAction ls+		mapM_ snd $ concat nls+		clearCharactersAction ls+		sequence_ $ characters ls+--		flush ls+		return $ Just ls{layers = nls}++clearLayer :: Layer -> IO ()+clearLayer Layer{layerId = lid, layerLayers = rls} = withLock2 $ do+	ls <- readIORef rls+	nls <- clearLayer_ ls lid+	writeIORef rls nls++clearLayer_ :: Layers -> Int -> IO Layers+clearLayer_ ls l = do+	let	nls = setAt (layers ls) l []+		nbf = setAt (buffed ls) l $ return ()+	clearLayersAction ls+	sequence_ nbf+	undoLayersAction ls+	mapM_ snd $ concat nls+	return ls{layers = nls, buffed = nbf}++addCharacter :: IORef Layers -> IO Character+addCharacter rls = withLock2 $ do+	ls <- readIORef rls+	let (cid, nls) = addCharacter_ ls+	writeIORef rls nls+	return Character{characterId = cid, characterLayers = rls}++addCharacter_ :: Layers -> (Int, Layers)+addCharacter_ ls =+	(length $ characters ls,+		ls{characters = characters ls ++ [return ()]})++setCharacter :: Character -> IO () -> IO ()+setCharacter Character{characterId = cid, characterLayers = rls} act = withLock2 $+	readIORef rls >>= flip withLock (\ls -> do+	nls <- setCharacter_ ls cid act+	writeIORef rls nls+--	flush ls)+	)++setCharacter_ :: Layers -> Int -> IO () -> IO Layers+setCharacter_ ls c act = do+	let cs = setAt (characters ls) c act+	clearCharactersAction ls+	sequence_ cs+	return ls{characters = cs}
+ src/Graphics/X11/Turtle/Move.hs view
@@ -0,0 +1,136 @@+module Graphics.X11.Turtle.Move (+	Field,+	Layer,+	Character,++	forkIOX,+	openField,+	closeField,+	addLayer,+	addCharacter,+	fieldSize,+	clearLayer,+	clearCharacter,+	addThread,+	fieldColor,+	onclick,+	onrelease,+	ondrag,+	onkeypress,+	waitField,+	writeString,+--	Color'(..),++	moveTurtle+) where++import Graphics.X11.Turtle.State(TurtleState(..))+import Graphics.X11.Turtle.Field(+	withLock2,+	Field, Layer, Character,+	forkIOX, openField, closeField, flushLayer,+	addLayer, addCharacter, fieldSize, clearLayer,+	drawCharacter, drawCharacterAndLine, undoLayer,+	drawLine,+	clearCharacter, addThread,+	fieldColor, onkeypress, onclick, onrelease, ondrag, waitField, writeString+ )+import Text.XML.YJSVG++import Control.Concurrent(threadDelay)+import Control.Monad(when, unless, forM_)+import Control.Arrow((***))+import Data.Maybe++type Pos = (Double, Double)++step :: Double+step = 10++moveSpeed :: Int+moveSpeed = 50000++stepDir :: Double+stepDir = 1 / 72++rotateSpeed :: Int+rotateSpeed = 10000++dir :: TurtleState -> Double+dir t = direction t / degrees t++lock :: Field -> IO a -> IO a+lock f = flip withLock2 f . const++moveTurtle :: Field -> Character -> Layer -> TurtleState -> TurtleState -> IO ()+moveTurtle f c l t0 t1 = do+	when (undo t1 && clear t0) $ lock f $ drawLines f l $ drawed t1+	when (undo t1 && isJust (draw t0)) $ lock f $ do+		done <- undoLayer l+		unless done $ clearLayer l >> drawLines f l (drawed t1)+		drawTurtle f c (pencolor t1) (shape t1) (shapesize t1)+			(dir t1) (pensize t1) (x0, y0) lineOrigin+	when (visible t1) $ do+		forM_ (getDirections (dir t0) (dir t1)) $ \d -> lock f $ do+			drawTurtle f c (pencolor t1) (shape t1) (shapesize t1) d+				(pensize t1) p0 Nothing+			flushLayer f+			threadDelay rotateSpeed+		forM_ (getPositions x0 y0 x1 y1) $ \p -> lock f $ do+			drawTurtle f c (pencolor t1) (shape t1) (shapesize t1)+				(dir t1) (pensize t1) p lineOrigin+			flushLayer f+			threadDelay moveSpeed+		lock f $ do+			drawTurtle f c (pencolor t1) (shape t1) (shapesize t1) (dir t1)+				(pensize t1) p1 lineOrigin+			flushLayer f+	unless (visible t1) $ clearCharacter f c+	when (clear t1) $ lock f $ clearLayer l >> flushLayer f+	unless (undo t1) $ lock f $ drawDraw f l (draw t1) >> flushLayer f+	where+	(tl, to) = if undo t1 then (t0, t1) else (t1, t0)+	lineOrigin = if pendown tl then Just $ position to else Nothing+	p0@(x0, y0) = position t0+	p1@(x1, y1) = position t1++drawLines :: Field -> Layer -> [SVG] -> IO ()+drawLines f l = mapM_ (drawDraw f l . Just) . reverse++drawDraw :: Field -> Layer -> Maybe SVG -> IO ()+drawDraw _ _ Nothing = return ()+drawDraw f l (Just (Line (Center x0 y0) (Center x1 y1) clr lw)) =+	drawLine f l lw clr x0 y0 x1 y1+-- drawDraw l (Line clr lw (x0, y0) (x1, y1)) = drawLine l lw (clr) x0 y0 x1 y1+drawDraw f l (Just (Text (Center x y) sz clr fnt str)) =+-- drawDraw l (Just (Text clr fnt sz (x, y) str)) =+	writeString f l fnt sz clr x y str+{-+	where+	[r, g, b] = map ((/ 0xff) . fromIntegral) [r_, g_, b_]+-}+drawDraw _ _ _ = error "not implemented"++getPositions :: Double -> Double -> Double -> Double -> [Pos]+getPositions x0 y0 x1 y1 = take num $ zip [x0, x0 + dx .. ] [y0, y0 + dy .. ]+	where+	num = floor $ dist / step+	dist = ((x1 - x0) ** 2 + (y1 - y0) ** 2) ** (1/2)+	dx = step * (x1 - x0) / dist+	dy = step * (y1 - y0) / dist++getDirections :: Double -> Double -> [Double]+getDirections ds de = [ds, ds + dd .. de - dd]+	where+	dd = if de > ds then stepDir else - stepDir++drawTurtle :: Field -> Character -> Color -> [Pos] -> Double -> Double -> Double ->+	Pos -> Maybe Pos -> IO ()+drawTurtle f c clr sh s d lw (px, py) org = do+	let sp = map (((+ px) *** (+ py)) . rotatePoint . ((* s) *** (* s))) sh+	maybe (drawCharacter f c clr sp)+		(\(x0, y0) -> (drawCharacterAndLine f c clr sp lw x0 y0 px py)) org+--	flushLayer f+	where+	rotatePoint (x, y) = let rad = d * 2 * pi in+		(x * cos rad - y * sin rad, x * sin rad + y * cos rad)
+ src/Graphics/X11/Turtle/Shape.hs view
@@ -0,0 +1,14 @@+module Graphics.X11.Turtle.Shape(nameToShape) where++import Control.Arrow(second, (&&&))++nameToShape :: String -> [(Double, Double)]+nameToShape "classic" = unfold [(- 10, 0), (- 16, 6), (0, 0)]+nameToShape "turtle" = unfold [+	(- 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)+ ]+nameToShape name = error $ "There is no shape named " ++ name++unfold :: [(Double, Double)] -> [(Double, Double)]+unfold = uncurry (++) . (id &&& (reverse . map (second negate)))
+ src/Graphics/X11/Turtle/State.hs view
@@ -0,0 +1,41 @@+module Graphics.X11.Turtle.State (+	TurtleState(..),+	initialTurtleState,+) where++import Text.XML.YJSVG(SVG, Color(RGB))++data TurtleState = TurtleState {+	position :: (Double, Double),+	direction :: Double,+	degrees :: Double,+	pendown :: Bool,+	pensize :: Double,+	pencolor :: Color,+	shape :: [(Double, Double)],+	shapesize :: Double,+	visible :: Bool,+	clear :: Bool,+	undo :: Bool,+	undonum :: Int,+	draw :: Maybe SVG,+	drawed :: [SVG]+ } deriving Show++initialTurtleState :: TurtleState+initialTurtleState = TurtleState {+	position = (0, 0),+	direction = 0,+	degrees = 360,+	pendown = True,+	pensize = 1,+	pencolor = RGB 0 0 0,+	shape = [],+	shapesize = 1,+	visible = True,+	clear = False,+	undo = False,+	undonum = 1,+	draw = Nothing,+	drawed = []+ }
− src/Graphics/X11/TurtleField.hs 
@@ -1,513 +0,0 @@-module Graphics.X11.TurtleField(-	Field,-	Layer,-	Character,--	openField,-	closeField,-	waitField,-	fieldColor,-	fieldSize,--	addLayer,-	addCharacter,--	drawLine,-	drawLineNotFlush,-	writeString,-	drawCharacter,-	drawCharacterAndLine,-	clearCharacter,--	undoLayer,-	clearLayer,-	flushLayer,--	onclick,-	onrelease,-	ondrag,-	onkeypress,--	forkIOX,-	addThread-) where--import Graphics.X11(-	Display, Window, Pixmap, Atom, GC, Point(..), Dimension, Position, Pixel,--	setLineAttributes, lineSolid, capRound, joinRound,--	openDisplay, closeDisplay, flush, defaultScreen, rootWindow,-	whitePixel, blackPixel,	defaultDepth,-	createSimpleWindow, mapWindow, createPixmap, internAtom, createGC,--	setForeground, copyArea,-	fillRectangle, fillPolygon, nonconvex, coordModeOrigin,--	setWMProtocols, selectInput, allocaXEvent, nextEvent, XEventPtr,-	keyPressMask, exposureMask, buttonPressMask, buttonReleaseMask,-	button1MotionMask,--	getGeometry, initThreads, connectionNumber, pending, destroyWindow,--	defaultVisual, defaultColormap, defaultScreenOfDisplay,--	supportsLocale, setLocaleModifiers,-	xK_VoidSymbol, buttonPress, buttonRelease,-	allocNamedColor- )-import qualified Graphics.X11 as X (drawLine, Color(..))-import Graphics.X11.Xlib.Extras(Event(..), getEvent)-import Graphics.X11.Xft-import Graphics.X11.Xrender-import Graphics.X11.Xim--import Data.IORef(IORef, newIORef, readIORef, writeIORef, modifyIORef)-import Data.Bits((.|.), shift)-import Data.Convertible(convert)-import Data.List.Tools(modifyAt, setAt)-import Data.Bool.Tools(whether)-import Data.Maybe--import Control.Monad(replicateM, forM_, forever, replicateM_, when, unless)-import Control.Monad.Tools(doWhile_, whenM, unlessM)-import Control.Arrow((***))-import Control.Concurrent(-	forkIO, ThreadId, Chan, newChan, writeChan, readChan, threadWaitRead,-	killThread)--import System.Posix.Types-import System.Locale.SetLocale-import Foreign.C.Types--import Text.XML.YJSVG(Color(..))--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 ()],-	fWait :: Chan (),-	fEvent :: Chan (Maybe Event),-	fClose :: Chan (),-	fClosed :: IORef Bool,-	fRunning :: IORef [ThreadId],-	fOnclick :: IORef (Int -> Double -> Double -> IO Bool),-	fOnrelease :: IORef (Double -> Double -> IO Bool),-	fOndrag :: IORef (Double -> Double -> IO ()),-	fPress :: IORef Bool,-	fKeypress :: IORef (Char -> IO Bool),-	fEnd :: Chan ()- }--data Layer = Layer{-	layerField :: Field,-	layerId :: Int- }--data Character = Character{-	characterField :: Field,-	characterId :: Int- }--openField :: IO Field-openField = do-	_ <- setLocale LC_CTYPE Nothing >>= maybe (error "Can't set locale.") return-	_ <- initThreads-	unlessM supportsLocale $ error "Current locale is notSupported."-	_ <- setLocaleModifiers ""-	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-	bufs <- replicateM 3 $ createPixmap dpy root rWidth rHeight depth-	win <- createSimpleWindow dpy root 0 0 rWidth rHeight 1 black white-	im <- openIM dpy Nothing Nothing Nothing-	ic <- createIC im [XIMPreeditNothing, XIMStatusNothing] win-	fevent <- getICValue ic "filterEvents"-	[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 .|.-		buttonPressMask .|. buttonReleaseMask .|. button1MotionMask .|.-		fevent-	mapWindow dpy win-	[widthRef, heightRef] <- mapM newIORef [rWidth, rHeight]-	buffActions <- newIORef []-	layerActions <- newIORef []-	characterActions <- newIORef []-	wait <- newChan-	event <- newChan-	close <- newChan-	closed <- newIORef False-	running <- newIORef []-	onclickRef <- newIORef $ const $ const $ const $ return True-	onreleaseRef <- newIORef $ const $ const $ return True-	ondragRef <- newIORef $ const $ const $ return ()-	pressRef <- newIORef False-	keypressRef <- newIORef $ const $ return True-	endRef <- newChan-	writeChan wait ()-	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,-		fWait = wait,-		fEvent = event,-		fClose = close,-		fClosed = closed,-		fRunning = running,-		fOnclick = onclickRef,-		fOnrelease = onreleaseRef,-		fOndrag = ondragRef,-		fPress = pressRef,-		fKeypress = keypressRef,-		fEnd = endRef-	 }-	_ <- forkIOX $ runLoop ic f-	flushWindow f-	return f--runLoop :: XIC -> Field -> IO ()-runLoop ic f = allocaXEvent $ \e -> do-	endc <- waitInput f-	th1 <- forkIOX $ forever $ do-		evN <- pending $ fDisplay f-		replicateM_ (fromIntegral evN) $ do-			nextNotFilteredEvent (fDisplay f) e-			ev <- getEvent e-			writeChan (fEvent f) $ Just ev-		end <- readChan endc-		when end $ writeChan (fEvent f) Nothing-	(>> (closeDisplay (fDisplay f) >> writeChan (fEnd f) ())) $-		(>> destroyWindow (fDisplay f) (fWindow f)) $ doWhile_ $ do-		mev <- readChan $ fEvent f-		case mev of-			Just (ExposeEvent{}) -> do-				(_, _, _, width, height, _, _) <--					getGeometry (fDisplay f) (fWindow f)-				writeIORef (fWidth f) width-				writeIORef (fHeight f) height-				redrawAll f-				return True-			Just (KeyEvent{}) -> do-				(mstr, mks) <- utf8LookupString ic e-				let	str = fromMaybe " " mstr-					_ks = fromMaybe xK_VoidSymbol mks-				readIORef (fKeypress f) >>= fmap and . ($ str) . mapM-			Just ev@ButtonEvent{} -> do-				pos <- convertPosRev f (ev_x ev) (ev_y ev)-				case ev_event_type ev of-					et	| et == buttonPress -> do-							writeIORef (fPress f) True-							fun <- readIORef (fOnclick f)-							uncurry (fun $ fromIntegral $ ev_button ev)-								pos-						| et == buttonRelease -> do-							writeIORef (fPress f) False-							readIORef (fOnrelease f) >>=-								($ pos) . uncurry-					_ -> error "not implement event"-			Just ev@MotionEvent{} -> do-				pos <- convertPosRev f (ev_x ev) (ev_y ev)-				whenM (readIORef $ fPress f) $-					readIORef (fOndrag f) >>= ($ pos) . uncurry-				return True-			Just ev@ClientMessageEvent{} ->-				return $ convert (head $ ev_data ev) /= fDel f-			Nothing -> killThread th1 >> return False-			_ -> return True--onclick :: Field -> (Int -> Double -> Double -> IO Bool) -> IO ()-onrelease :: Field -> (Double -> Double -> IO Bool) -> IO ()-onclick f = writeIORef $ fOnclick f-onrelease f = writeIORef $ fOnrelease f--ondrag :: Field -> (Double -> Double -> IO ()) -> IO ()-ondrag f = writeIORef $ fOndrag f--onkeypress :: Field -> (Char -> IO Bool) -> IO ()-onkeypress f = writeIORef $ fKeypress f--fieldColor :: Field -> Color -> IO ()-fieldColor f@Field{fDisplay = dpy} c = do-	clr <- getColorPixel dpy c-	setForeground (fDisplay f) (fGCBG f) clr-	let bufs = [fUndoBuf f, fBG f, fBuf f]-	width <- readIORef $ fWidth f-	height <- readIORef $ fHeight f-	forM_ bufs $ \bf -> fillRectangle (fDisplay f) bf (fGCBG f) 0 0 width height-	redrawAll f--getColorPixel :: Display -> Color -> IO Pixel-getColorPixel _ (RGB r g b) = return $ shift (fromIntegral r) 16 .|.-	shift (fromIntegral g) 8 .|. fromIntegral b-getColorPixel dpy (ColorName cn) = do-	let	scr = defaultScreen dpy-		colormap = defaultColormap dpy scr-	fmap (X.color_pixel . fst) $ allocNamedColor dpy colormap cn--getConnection :: Field -> Fd-getConnection = Fd . connectionNumber . fDisplay--waitInput :: Field -> IO (Chan Bool)-waitInput f = do-	c <- newChan-	_ <- forkIOX $ forever $ do-		threadWaitRead $ getConnection f-		writeChan c False-	_ <- forkIO $ do-		readChan $ fClose f-		writeChan c True-	return c--closeField :: Field -> IO ()-closeField f = do-	readIORef (fRunning f) >>= mapM_ killThread-	writeChan (fClose f) ()-	writeIORef (fClosed f) True--addThread :: Field -> ThreadId -> IO ()-addThread f tid = modifyIORef (fRunning f) (tid :)--flushLayer :: Layer -> IO ()-flushLayer = flushWindow . layerField--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}--runIfOpened :: Field -> IO a -> IO ()-runIfOpened f act = do-	cl <- readIORef $ fClosed f-	unless cl $ act >> return ()--drawLineNotFlush ::-	Layer -> Double -> Color -> Double -> Double -> Double -> Double -> IO ()-drawLineNotFlush l@Layer{layerField = f} lw_ clr x1 y1 x2 y2 = runIfOpened f $ do-	drawLineBuf f lw clr fBG x1 y1 x2 y2-	addLayerAction l $ whether-		(drawLineBuf f lw clr fUndoBuf x1 y1 x2 y2)-		(drawLineBuf f lw clr fBG x1 y1 x2 y2)-	where-	lw = round lw_--drawLine :: Layer -> Double -> Color -> Double -> Double -> Double -> Double -> IO ()-drawLine l@Layer{layerField = f} lw_ clr x1 y1 x2 y2 = runIfOpened f $ do-	drawLineBuf f lw clr fBG x1 y1 x2 y2 >> redrawCharacters f-	addLayerAction l $ whether-		(drawLineBuf f lw clr fUndoBuf x1 y1 x2 y2)-		(drawLineBuf f lw clr fBG x1 y1 x2 y2)-	where-	lw = round lw_--writeString :: Layer -> String -> Double -> Double -> Double -> Double ->-	Double -> Double -> String -> IO ()-writeString l@Layer{layerField = f} fname size r g b x y str = do-	writeStringBuf f fBG fname size r g b x y str-	redrawCharacters f-	addLayerAction l $ whether-		(writeStringBuf f fUndoBuf fname size r g b x y str)-		(writeStringBuf f fBG fname size r g b x y str)--writeStringBuf :: Field -> (Field -> Pixmap) -> String -> Double -> Double -> Double -> Double ->-	Double -> Double -> String -> IO ()-writeStringBuf f buf fname size r g b x_ y_ str = do-	let	dpy = fDisplay f-		scr = defaultScreen dpy-		scrN = defaultScreenOfDisplay dpy-		visual = defaultVisual dpy scr-		colormap = defaultColormap dpy scr-	xftDraw <- xftDrawCreate dpy (buf f) visual colormap-	xftFont <- xftFontOpen dpy scrN $ fname ++ "-" ++ show (round size :: Int) -- "KochiGothic-20"-	[(x, y)] <- convertPos f [(x_, y_)]-	withXftColorValue dpy visual colormap color $ \c ->-		xftDrawString xftDraw c xftFont x y str-	where-	color = XRenderColor {-		xrendercolor_red = round $ r * 0xffff,-		xrendercolor_green = round $ b * 0xffff,-		xrendercolor_blue = round $ g * 0xffff,-		xrendercolor_alpha = 0xffff-	 }--clearCharacter :: Character -> IO ()-clearCharacter c = runIfOpened (characterField c) $-	setCharacter c $ return ()--drawCharacter :: Character -> Color -> [(Double, Double)] -> IO ()-drawCharacter c@Character{characterField = f} cl sh =-	runIfOpened (characterField c) $ setCharacter c $ do-		clr <- getColorPixel (fDisplay f) cl-		setForeground (fDisplay f) (fGC f) clr-		fillPolygonBuf (characterField c) sh--drawCharacterAndLine ::	Character -> Color -> [(Double, Double)] -> Double ->-	Double -> Double -> Double -> Double -> IO ()-drawCharacterAndLine c@Character{characterField = f} cl ps lw_ x1 y1 x2 y2 =-	runIfOpened f $ setCharacter c $ do-		clr <- getColorPixel (fDisplay f) cl-		setForeground (fDisplay f) (fGC f) clr-		fillPolygonBuf f ps >> drawLineBuf f lw cl fBuf x1 y1 x2 y2-	where-	lw = round lw_--undoLayer :: Layer -> IO Bool-undoLayer Layer{layerField = f, layerId = lid} = do-	ls <- readIORef $ fLayers 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-	ls <- readIORef $ fLayers f-	writeIORef (fLayers f) $ setAt ls lid []-	buffed <- readIORef $ fBuffed f-	writeIORef (fBuffed f) $ setAt buffed lid $ return ()-	redrawBuf f-	redraw f--forkIOX :: IO () -> IO ThreadId-forkIOX = (initThreads >>) . forkIO------------------------------------------------------------------------------------undoN :: Int-undoN = 100--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])--setCharacter :: Character -> IO () -> IO ()-setCharacter Character{characterField = f, characterId = cid} act = do-	cs <- readIORef $ fCharacters f-	writeIORef (fCharacters f) $ setAt cs cid act-	redrawCharacters f-	flushWindow f--fillPolygonBuf :: Field -> [(Double, Double)] -> IO ()-fillPolygonBuf f ps_ = do-	ps <- convertPos f ps_-	fillPolygon (fDisplay f) (fBuf f) (fGC f) (map (uncurry Point) ps)-		nonconvex coordModeOrigin--drawLineBuf :: Field -> Int -> Color -> (Field -> Pixmap) ->-	Double -> Double -> Double -> Double -> IO ()-drawLineBuf f@Field{fDisplay = dpy, fGC = gc} lw c bf x1_ y1_ x2_ y2_ = do-	clr <- getColorPixel dpy c-	setForeground (fDisplay f) (fGC f) clr-	setLineAttributes (fDisplay f) (fGC f) (fromIntegral lw) lineSolid capRound joinRound-	[(x1, y1), (x2, y2)] <- convertPos f [(x1_, y1_), (x2_, y2_)]-	X.drawLine dpy (bf f) gc x1 y1 x2 y2--convertPos :: Field -> [(Double, Double)] -> IO [(Position, Position)]-convertPos f ps = do-	(width, height) <- fieldSize f-	return $ (round . (+ width / 2) *** round . (+ height / 2) . negate)-		`map` ps--convertPosRev :: Field -> CInt -> CInt -> IO (Double, Double)-convertPosRev f x y = do-	(width, height) <- fieldSize f-	return (fromIntegral x - width / 2, fromIntegral (- y) + height / 2)--fieldSize :: Field -> IO (Double, Double)-fieldSize w = fmap (fromIntegral *** fromIntegral) $ winSize w--winSize :: Field -> IO (Dimension, Dimension)-winSize f = do-	width <- readIORef $ fWidth f-	height <- readIORef $ fHeight f-	return (width, height)--redrawAll :: Field -> IO ()-redrawAll f = do-	redrawBuf f-	redraw f-	flushWindow f--redrawBuf :: Field -> IO ()-redrawBuf f = do-	winSize f >>=-		uncurry (fillRectangle (fDisplay f) (fUndoBuf f) (fGCBG f) 0 0)-	readIORef (fBuffed f) >>= sequence_--redraw :: Field -> IO ()-redraw = withLock $ \f -> do-	(width, height) <- winSize f-	copyArea (fDisplay f) (fUndoBuf f) (fBG f) (fGC f) 0 0 width height 0 0-	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_--redrawCharacters :: Field -> IO ()-redrawCharacters = withLock $ \f -> do-	(width, height) <- winSize f-	copyArea (fDisplay f) (fBG f) (fBuf f) (fGC f) 0 0 width height 0 0-	readIORef (fCharacters f) >>= sequence_--flushWindow :: Field -> IO ()-flushWindow = withLock $ \f -> do-	(width, height) <- winSize 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--waitField :: Field -> IO ()-waitField = readChan . fEnd--nextNotFilteredEvent :: Display -> XEventPtr -> IO ()-nextNotFilteredEvent dpy e = do-	nextEvent dpy e-	whenM (filterEvent e 0) $ nextNotFilteredEvent dpy e
− src/Graphics/X11/TurtleInput.hs 
@@ -1,100 +0,0 @@-module Graphics.X11.TurtleInput (-	TurtleState,-	TurtleInput(..),--	getTurtleStates,-	getPosition,-	getPendown,-	undonum,-	visible,-	direction,-	degrees,-	drawed,--	SVG,-	Color(..)-) where--import Graphics.X11.TurtleState(TurtleState(..), initialTurtleState,-	SVG(..), Position(..), Color(..))-import Control.Concurrent.Chan(Chan, newChan, getChanContents)-import Prelude hiding(Left)--getPosition :: TurtleState -> (Double, Double)-getPosition = position--getPendown :: TurtleState -> Bool-getPendown = pendown--data TurtleInput-	= Shape [(Double, Double)]-	| ShapeSize Double-	| Goto Double Double-	| Rotate Double-	| Penup-	| Pendown-	| SetVisible Bool-	| Undo-	| Clear-	| Forward Double-	| Left Double-	| Undonum Int-	| Pencolor Color-	| Pensize Double-	| Degrees Double-	| Write String Double String-	deriving (Show, Read)--getTurtleStates :: [(Double, Double)] -> IO (Chan TurtleInput, [TurtleInput], [TurtleState])-getTurtleStates sh = do-	let	ts0 = initialTurtleState sh-	c <- newChan-	tis <- getChanContents c-	return (c, tis, ts0 : ts0 : inputToTurtle [] ts0 tis)--nextTurtle :: TurtleState -> TurtleInput -> TurtleState-nextTurtle t (Shape sh) = (clearState t){shape = sh}-nextTurtle t (ShapeSize ss) = (clearState t){shapesize = ss}-nextTurtle t (Goto x y) = (clearState t){position = (x, y), line = pendown t,-	drawed = if pendown t then ln : drawed t else drawed t}-	where-	ln = Line (uncurry Center $ position t) (Center x y) (pencolor t)-		(pensize 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 (SetVisible v) = (clearState t){visible = v}-nextTurtle t (Undonum un) = (clearState t){undonum = un}-nextTurtle t (Clear) = (clearState t){clear = True, drawed = []}-nextTurtle t (Pencolor c) = (clearState t){pencolor = c}-nextTurtle t (Pensize ps) = (clearState t){pensize = ps}-nextTurtle t (Degrees ds) = (clearState t){-	degrees = ds,-	direction = direction t * ds / degrees t- }-nextTurtle t (Write fnt sz str) = (clearState t){-	draw = Just d, drawed = d : drawed t- }-	where-	(x, y) = position t-	d = Text (Center x y) sz (pencolor t) fnt str-nextTurtle _ _ = error "not defined"--clearState :: TurtleState -> TurtleState-clearState t = t{line = False, undo = False, undonum = 1, clear = False, draw = Nothing}--inputToTurtle :: [TurtleState] -> TurtleState -> [TurtleInput] -> [TurtleState]-inputToTurtle [] ts0 (Undo : tis) = ts0 : inputToTurtle [] ts0 tis-inputToTurtle (tsb : tsbs) _ (Undo : tis) =-	let ts1 = tsb{undo = True} in ts1 : inputToTurtle tsbs ts1 tis-inputToTurtle tsbs ts0 (Forward len : tis) = let-	(x0, y0) = position ts0-	dir = direction ts0 / degrees ts0-	x = x0 + len * cos (dir * 2 * pi)-	y = y0 + len * sin (dir * 2 * pi) in-	inputToTurtle tsbs ts0 $ Goto x y : tis-inputToTurtle tsbs ts0 (Left dd : tis) =-	inputToTurtle tsbs ts0 $ Rotate (direction ts0 + dd) : tis-inputToTurtle tsbs ts0 (ti : tis) =-	let ts1 = nextTurtle ts0 ti in ts1 : inputToTurtle (ts0 : tsbs) ts1 tis-inputToTurtle _ _ [] = error "no more input"
− src/Graphics/X11/TurtleMove.hs 
@@ -1,125 +0,0 @@-module Graphics.X11.TurtleMove (-	Field,-	Layer,-	Character,--	forkIOX,-	openField,-	closeField,-	addLayer,-	addCharacter,-	fieldSize,-	clearLayer,-	clearCharacter,-	addThread,-	fieldColor,-	onclick,-	onrelease,-	ondrag,-	onkeypress,-	waitField,-	writeString,---	Color'(..),--	moveTurtle-) where--import Graphics.X11.TurtleState(TurtleState(..), SVG(..), Position(..),-	Color(..))-import Graphics.X11.TurtleField(-	Field, Layer, Character,-	forkIOX, openField, closeField, flushLayer,-	addLayer, addCharacter, fieldSize, clearLayer,-	drawLine, drawCharacter, drawCharacterAndLine, undoLayer,-	drawLineNotFlush,-	clearCharacter, addThread,-	fieldColor, onkeypress, onclick, onrelease, ondrag, waitField, writeString- )--import Control.Concurrent(threadDelay)-import Control.Monad(when, unless, forM_)-import Control.Arrow((***))-import Data.Maybe--type Pos = (Double, Double)--step :: Double-step = 10--moveSpeed :: Int-moveSpeed = 50000--stepDir :: Double-stepDir = 1 / 72--rotateSpeed :: Int-rotateSpeed = 10000--dir :: TurtleState -> Double-dir t = direction t / degrees t--moveTurtle :: Character -> Layer -> TurtleState -> TurtleState -> IO ()-moveTurtle c l t0 t1 = do-	when (undo t1 && (line t0 || isJust (draw t0))) $ do-		done <- undoLayer l-		unless done $ clearLayer l >> drawLines l (drawed t1)-	when (undo t1 && clear t0) $ drawLines l $ drawed t1-	when (visible t1) $ do-		forM_ (getDirections (dir t0) (dir t1)) $ \d -> do-			drawTurtle c (pencolor t1) (shape t1) (shapesize t1) d-				(pensize t1) p0 Nothing-			threadDelay rotateSpeed-		forM_ (getPositions x0 y0 x1 y1) $ \p -> do-			drawTurtle c (pencolor t1) (shape t1) (shapesize t1)-				(dir t1) (pensize t1) p lineOrigin-			threadDelay moveSpeed-		drawTurtle c (pencolor t1) (shape t1) (shapesize t1) (dir t1)-			(pensize t1) p1 lineOrigin-	unless (visible t1) $ clearCharacter c-	when (not (undo t1) && line t1) $-		drawLine l (pensize t1) (pencolor t1) x0 y0 x1 y1 >> flushLayer l-	when (clear t1) $ clearLayer l >> flushLayer l-	unless (undo t1) $ drawDraw l (draw t1) >> 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 -> [SVG] -> IO ()-drawLines l = mapM_ (drawDraw l . Just) . reverse--drawDraw :: Layer -> Maybe SVG -> IO ()-drawDraw _ Nothing = return ()-drawDraw l (Just (Line (Center x0 y0) (Center x1 y1) clr lw)) =-	drawLineNotFlush l lw clr x0 y0 x1 y1--- drawDraw l (Line clr lw (x0, y0) (x1, y1)) = drawLineNotFlush l lw (clr) x0 y0 x1 y1-drawDraw l (Just (Text (Center x y) sz (RGB r_ g_ b_) fnt str)) =--- drawDraw l (Just (Text (r, g, b) fnt sz (x, y) str)) =-	writeString l fnt sz r g b x y str-	where-	[r, g, b] = map ((/ 0xff) . fromIntegral) [r_, g_, b_]-drawDraw _ _ = error "not implemented"--getPositions :: Double -> Double -> Double -> Double -> [Pos]-getPositions x0 y0 x1 y1 = take num $ zip [x0, x0 + dx .. ] [y0, y0 + dy .. ]-	where-	num = floor $ dist / step-	dist = ((x1 - x0) ** 2 + (y1 - y0) ** 2) ** (1/2)-	dx = step * (x1 - x0) / dist-	dy = step * (y1 - y0) / dist--getDirections :: Double -> Double -> [Double]-getDirections ds de = [ds, ds + dd .. de - dd]-	where-	dd = if de > ds then stepDir else - stepDir--drawTurtle :: Character -> Color -> [Pos] -> Double -> Double -> Double ->-	Pos -> Maybe Pos -> IO ()-drawTurtle c clr sh s d lw (px, py) org = do-	let sp = map (((+ px) *** (+ py)) . rotatePoint . ((* s) *** (* s))) sh-	maybe (drawCharacter c clr sp)-		(\(x0, y0) -> (drawCharacterAndLine c clr sp lw x0 y0 px py)) org-	where-	rotatePoint (x, y) = let rad = d * 2 * pi in-		(x * cos rad - y * sin rad, x * sin rad + y * cos rad)
− src/Graphics/X11/TurtleShape.hs 
@@ -1,14 +0,0 @@-module Graphics.X11.TurtleShape(lookupShape) where--import Control.Arrow(second, (&&&))--lookupShape :: String -> [(Double, Double)]-lookupShape "classic" = unfold [(- 10, 0), (- 16, 6), (0, 0)]-lookupShape "turtle" = unfold [-	(- 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)- ]-lookupShape name = error $ "There is no shape named " ++ name--unfold :: [(Double, Double)] -> [(Double, Double)]-unfold = uncurry (++) . (id &&& (reverse . map (second negate)))
− src/Graphics/X11/TurtleState.hs 
@@ -1,70 +0,0 @@-module Graphics.X11.TurtleState (-	TurtleState(..),-	initialTurtleState,-	pencolor_,-	setPencolor,-	SVG(..),-	Position(..),-	Color(..),-	colorToWord32-) where--import Data.Word(Word32)-import Data.Bits-import Text.XML.YJSVG--pencolor_ :: TurtleState -> Word32-pencolor_ TurtleState{pencolor = RGB r g b} = c'-	where-	c' = shift (fromIntegral r) 16 .|. shift (fromIntegral g) 8 .|. fromIntegral b-pencolor_ TurtleState{pencolor = ColorName _} = error "not implemented"--colorToWord32 :: Color -> Word32-colorToWord32 (RGB r g b) =-	shift (fromIntegral r) 16 .|. shift (fromIntegral g) 8 .|. fromIntegral b-colorToWord32 _ = error "colorToWord32 (ColorName _) is not implemented"--setPencolor :: TurtleState -> Word32 -> TurtleState-setPencolor t c = t{-	pencolor = RGB r_ g_ b_}-	where-	r_ = fromIntegral $ shiftR c 16 .&. 0xff-	g_ = fromIntegral $ shiftR c 8 .&. 0xff-	b_ = fromIntegral $ c .&. 0xff--data TurtleState = TurtleState {-	position :: (Double, Double),-	direction :: Double,-	degrees :: Double,-	pendown :: Bool,-	pensize :: Double,-	pencolor :: Color,-	shape :: [(Double, Double)],-	shapesize :: Double,-	visible :: Bool,-	clear :: Bool,-	undo :: Bool,-	line :: Bool,-	undonum :: Int,-	draw :: Maybe SVG,-	drawed :: [SVG]- } deriving Show--initialTurtleState :: [(Double, Double)] -> TurtleState-initialTurtleState sh = TurtleState {-	position = (0, 0),-	direction = 0,-	degrees = 360,-	pendown = True,-	pensize = 0,-	pencolor = RGB 0 0 0,-	shape = sh,-	shapesize = 1,-	visible = True,-	clear = False,-	undo = False,-	line = False,-	undonum = 1,-	draw = Nothing,-	drawed = []- }
xturtle.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.6  name:		xturtle-version:	0.0.15+version:	0.0.16 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -33,5 +33,6 @@   Build-depends:	base > 3 && < 5, yjtools >= 0.9.13, convertible >= 1.0.8, X11,     X11-xft <= 3.1, x11-xim, setlocale, yjsvg >= 0.1.11   Ghc-options:		-Wall-  Other-modules:	Graphics.X11.TurtleField, Graphics.X11.TurtleInput,-    Graphics.X11.TurtleMove, Graphics.X11.TurtleState, Graphics.X11.TurtleShape+  Other-modules:	Graphics.X11.Turtle.Field, Graphics.X11.Turtle.Input,+    Graphics.X11.Turtle.Move, Graphics.X11.Turtle.State, Graphics.X11.Turtle.Shape,+    Graphics.X11.Turtle.Layers