packages feed

xturtle 0.1.6 → 0.1.9

raw patch · 9 files changed

+537/−553 lines, 9 filesdep ~yjsvgdep ~yjtools

Dependency ranges changed: yjsvg, yjtools

Files

src/Graphics/X11/Turtle.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE RankNTypes #-} -module Graphics.X11.Turtle (+module Graphics.X11.Turtle( 	-- * meta data 	xturtleVersion, @@ -10,14 +11,31 @@ 	Turtle, 	ColorClass, -	-- * beginings and endings+	-- * Field functions+	-- ** meta 	openField, 	closeField, 	waitField,+	topleft,+	center,++	-- ** on events+	onclick,+	onrelease,+	ondrag,+	onmotion,+	onkeypress,+	ontimer,++	-- * Turtle functions+	-- ** meta 	newTurtle, 	killTurtle,+	inputs,+	runInputs,+	getSVG, -	-- * move turtle+	-- ** move turtle 	forward, 	backward, 	goto,@@ -27,62 +45,51 @@ 	right, 	setheading, 	circle,-	write,-	stamp,-	dot,-	image,-	bgcolor, 	home,-	clear, 	undo, 	sleep,-	flushoff,-	flushon, 	flush, -	-- * change turtle state+	-- ** draw+	dot,+	stamp,+	beginfill,+	endfill,+	write,+	image,+	bgcolor,+	clear,++	-- ** change states 	addshape,+	beginpoly,+	endpoly, 	getshapes, 	shape, 	shapesize,-	speed, 	hideturtle, 	showturtle, 	penup, 	pendown,-	beginfill,-	endfill,-	beginpoly,-	endpoly, 	pencolor, 	pensize,-	degrees, 	radians,+	degrees,+	speed,+	flushoff,+	flushon, -	-- * turtle information+	-- ** informations 	position, 	xcor, 	ycor,+	distance, 	heading, 	towards,-	distance, 	isdown, 	isvisible, 	windowWidth,-	windowHeight,--	-- * on events-	onclick,-	onrelease,-	ondrag,-	onmotion,-	onkeypress,-	ontimer,--	-- * save and load-	getInputs,-	sendInputs,-	getSVG+	windowHeight ) where  import Graphics.X11.Turtle.Data(shapeTable, speedTable)@@ -91,37 +98,32 @@ 	turtleSeries, direction, visible, undonum, drawed, polyPoints) import qualified Graphics.X11.Turtle.Input as S(position, degrees, pendown) import Graphics.X11.Turtle.Move(-	Field, Layer, Character,-	openField, closeField, forkField, waitField, fieldSize, flushField,-	moveTurtle, addLayer, clearLayer, addCharacter, clearCharacter,+	Field, Coordinates(..), openField, closeField, fieldSize,+	coordinates, topleft, center, waitField, forkField, flushField,+	addLayer, clearLayer, addCharacter, clearCharacter, moveTurtle, 	onclick, onrelease, ondrag, onmotion, onkeypress, ontimer)-import Text.XML.YJSVG(SVG(..), Color(..))+import Text.XML.YJSVG(SVG(..), Position(..), Color(..))+import qualified Text.XML.YJSVG as S(center, topleft) -import Control.Concurrent(Chan, writeChan, ThreadId, killThread)+import Control.Concurrent(killThread, writeChan) import Control.Monad(replicateM_, zipWithM_)-import Data.IORef(IORef, newIORef, readIORef, modifyIORef)+import Control.Arrow((&&&))+import Data.IORef(IORef, newIORef, readIORef) import Data.IORef.Tools(atomicModifyIORef_) import Data.Fixed(mod')-import Data.Maybe(fromJust)  --------------------------------------------------------------------------------  xturtleVersion :: (Int, String)-xturtleVersion = (56, "0.1.6")+xturtleVersion = (65, "0.1.9")  --------------------------------------------------------------------------------  data Turtle = Turtle {-	field :: Field,-	layer :: Layer,-	character :: Character,-	inputChan :: Chan TurtleInput,-	states :: [TurtleState],-	inputs :: [TurtleInput],-	stateIndex :: IORef Int,-	thread :: ThreadId,-	shapes :: IORef [(String, [(Double, Double)])]- }+	field :: Field, input :: TurtleInput -> IO (),+	info :: forall a . (TurtleState -> a) -> IO a,+	shapes :: IORef [(String, [(Double, Double)])],+	inputs :: IO [TurtleInput], killTurtle :: IO ()}  class ColorClass a where getColor :: a -> Color @@ -135,35 +137,34 @@  newTurtle :: Field -> IO Turtle newTurtle f = do-	l <- addLayer f-	ch <- addCharacter f-	(ic, tis, sts) <- turtleSeries-	si <- newIORef 1-	tid <- forkField f $ zipWithM_ (moveTurtle f ch l) sts $ tail sts-	shps <- newIORef shapeTable-	let	t = Turtle {-			field = f,-			layer = l,-			character = ch,-			inputChan = ic,-			states = sts,-			inputs = tis,-			stateIndex = si,-			thread = tid,-			shapes = shps}-	shape t "classic" >> input t (Undonum 0)-	return t+	index <- newIORef 1; shapesRef <- newIORef shapeTable+	(chan, hist, states) <- turtleSeries+	l <- addLayer f; c <- addCharacter f+	thr <- forkField f $ zipWithM_ (moveTurtle f c l) states $ tail states+	let t = Turtle {+		field = f,+		input = (atomicModifyIORef_ index succ >>) . writeChan chan,+		info = \n -> fmap (n . (states !!)) $ readIORef index,+		shapes = shapesRef,+		inputs = fmap (flip take hist . pred) $ readIORef index,+		killTurtle = flushField f True $+			clearLayer l >> clearCharacter c >> killThread thr}+	shape t "classic" >> input t (Undonum 0) >> return t -killTurtle :: Turtle -> IO ()-killTurtle t = flushField (field t) True $ do-	clearLayer $ layer t-	clearCharacter $ character t-	killThread $ thread t+runInputs :: Turtle -> [TurtleInput] -> IO ()+runInputs = mapM_ . input -input :: Turtle -> TurtleInput -> IO ()-input Turtle{inputChan = c, stateIndex = si} ti =-	atomicModifyIORef_ si (+ 1) >>writeChan c ti+getSVG :: Turtle -> IO [SVG]+getSVG = fmap reverse . flip info drawed +convertPosition :: Turtle -> Position -> IO Position+convertPosition t p = do+	(w, h) <- windowSize t+	coord <- coordinates $ field t+	return $ case coord of+		CoordCenter -> S.center w h p+		CoordTopLeft -> S.topleft w h p+ --------------------------------------------------------------------------------  forward, backward :: Turtle -> Double -> IO ()@@ -171,15 +172,23 @@ backward t = forward t . negate  goto :: Turtle -> Double -> Double -> IO ()-goto t x y = input t $ Goto x y+goto t@Turtle{field = f} x y = do+	coord <- coordinates f+	input t $ Goto $ case coord of+		CoordCenter -> Center x y+		CoordTopLeft -> TopLeft x y  setx, sety :: Turtle -> Double -> IO () setx t x = do-	(_, y) <- position t-	input t $ Goto x y+	pos <- info t S.position >>= convertPosition t+	input t $ Goto $ case pos of+		Center _ y -> Center x y+		TopLeft _ y -> TopLeft x y sety t y = do-	(x, _) <- position t-	input t $ Goto x y+	pos <- info t S.position >>= convertPosition t+	input t $ Goto $ case pos of+		Center x _ -> Center x y+		TopLeft x _ -> TopLeft x y  left, right, setheading :: Turtle -> Double -> IO () left t = input t . TurnLeft@@ -188,66 +197,70 @@  circle :: Turtle -> Double -> IO () circle t r = do-	deg <- getDegrees t+	deg <- info t S.degrees 	forward t (r * pi / 36) 	left t (deg / 36) 	replicateM_ 35 $ forward t (2 * r * pi / 36) >> left t (deg / 36) 	forward t (r * pi / 36) 	input t $ Undonum 74 -write :: Turtle -> String -> Double -> String -> IO ()-write t fnt sz = input t . Write fnt sz+home :: Turtle -> IO ()+home t = goto t 0 0 >> setheading t 0 >> input t (Undonum 3) -stamp :: Turtle -> IO ()-stamp = (`input` Stamp)+undo :: Turtle -> IO ()+undo t = info t undonum >>= flip replicateM_ (input t Undo) +sleep :: Turtle -> Int -> IO ()+sleep t = input t . Sleep++flush :: Turtle -> IO ()+flush = (`input` Flush)++--------------------------------------------------------------------------------+ dot :: Turtle -> Double -> IO () dot t = input t . Dot +stamp :: Turtle -> IO ()+stamp = (`input` Stamp)++beginfill, endfill :: Turtle -> IO ()+beginfill = (`input` SetFill True)+endfill = (`input` SetFill False)++write :: Turtle -> String -> Double -> String -> IO ()+write t fnt sz = input t . Write fnt sz+ image :: Turtle -> FilePath -> Double -> Double -> IO ()-image t fp w h = input t $ PutImage fp w h+image t fp = curry $ input t . uncurry (PutImage fp)  bgcolor :: ColorClass c => Turtle -> c -> IO () bgcolor t = input t . Bgcolor . getColor -home :: Turtle -> IO ()-home t = goto t 0 0 >> setheading t 0 >> input t (Undonum 3)- clear :: Turtle -> IO ()-clear t = input t Clear--undo :: Turtle -> IO ()-undo t = readIORef (stateIndex t)-	>>= flip replicateM_ (input t Undo) . undonum . (states t !!)--sleep :: Turtle -> Int -> IO ()-sleep t = input t . Sleep--flushoff, flushon :: Turtle -> IO ()-flushoff = (`input` SetFlush False)-flushon = (`input` SetFlush True)--flush :: Turtle -> IO ()-flush = (`input` Flush)+clear = (`input` Clear)  --------------------------------------------------------------------------------  addshape :: Turtle -> String -> [(Double, Double)] -> IO ()-addshape t n s = modifyIORef (shapes t) ((n, s) :)+addshape t n s = atomicModifyIORef_ (shapes t) ((n, s) :) +beginpoly :: Turtle -> IO ()+beginpoly = (`input` SetPoly True)++endpoly :: Turtle -> IO [(Double, Double)]+endpoly t = input t (SetPoly False) >> info t polyPoints >>=+	mapM (fmap (posX &&& posY) . convertPosition t)+ getshapes :: Turtle -> IO [String]-getshapes t = fmap (map fst) $ readIORef (shapes t)+getshapes = fmap (map fst) . readIORef . shapes  shape :: Turtle -> String -> IO ()-shape t n = readIORef (shapes t) >>= input t . Shape . fromJust . lookup n+shape t n = readIORef (shapes t) >>=+	maybe (putStrLn $ "no shape named " ++ n) (input t . Shape) . lookup n  shapesize :: Turtle -> Double -> Double -> IO ()-shapesize t sx sy = input t $ Shapesize sx sy--speed :: Turtle -> String -> IO ()-speed t str = case lookup str speedTable of-	Just (ps, ds) -> input t (PositionStep ps) >> input t (DirectionStep ds)-	Nothing -> putStrLn "no such speed"+shapesize t = curry $ input t . uncurry Shapesize  hideturtle, showturtle :: Turtle -> IO () hideturtle = (`input` SetVisible False)@@ -257,79 +270,64 @@ penup = (`input` SetPendown False) pendown = (`input` SetPendown True) -beginfill, endfill :: Turtle -> IO ()-beginfill = (`input` SetFill True)-endfill = (`input` SetFill False)--beginpoly :: Turtle -> IO ()-beginpoly = (`input` SetPoly True)--endpoly :: Turtle -> IO [(Double, Double)]-endpoly t@Turtle{stateIndex = si, states = s} = do-	input t $ SetPoly False-	fmap (polyPoints . (s !!)) $ readIORef si- pencolor :: ColorClass c => Turtle -> c -> IO () pencolor t = input t . Pencolor . getColor  pensize :: Turtle -> Double -> IO () pensize t = input t . Pensize +radians :: Turtle -> IO ()+radians = (`degrees` (2 * pi))+ degrees :: Turtle -> Double -> IO () degrees t = input t . Degrees -radians :: Turtle -> IO ()-radians = (`degrees` (2 * pi))+speed :: Turtle -> String -> IO ()+speed t str = case lookup str speedTable of+	Just (ps, ds) -> do+		input t $ PositionStep ps+		input t $ DirectionStep ds+		input t $ Undonum 3+	Nothing -> putStrLn "no such speed" +flushoff, flushon :: Turtle -> IO ()+flushoff = (`input` SetFlush False)+flushon = (`input` SetFlush True)+ --------------------------------------------------------------------------------  position :: Turtle -> IO (Double, Double)-position Turtle{stateIndex = si, states = s} =-	fmap (S.position . (s !!)) $ readIORef si+position t = fmap (posX &&& posY) $ info t S.position >>= convertPosition t  xcor, ycor :: Turtle -> IO Double xcor = fmap fst . position ycor = fmap snd . position +distance :: Turtle -> Double -> Double -> IO Double+distance t x0 y0 = do+	(x, y) <- position t+	return $ ((x - x0) ** 2 + (y - y0) ** 2) ** (1 / 2)+ heading :: Turtle -> IO Double-heading t@Turtle{stateIndex = si, states = s} = do-	deg <- getDegrees t-	dir <- fmap ((* (deg / (2 * pi))) . direction . (s !!)) $ readIORef si+heading t = do+	deg <- info t S.degrees+	dir <- fmap (* (deg / (2 * pi))) $ info t direction 	return $ dir `mod'` deg -getDegrees :: Turtle -> IO Double-getDegrees Turtle{stateIndex = si, states = s} =-	fmap (S.degrees . (s !!)) $ readIORef si- towards :: Turtle -> Double -> Double -> IO Double towards t x0 y0 = do 	(x, y) <- position t-	deg <- getDegrees t+	deg <- info t S.degrees 	let	dir = atan2 (y0 - y) (x0 - x) * deg / (2 * pi) 	return $ if dir < 0 then dir + deg else dir -distance :: Turtle -> Double -> Double -> IO Double-distance t x0 y0 = do-	(x, y) <- position t-	return $ ((x - x0) ** 2 + (y - y0) ** 2) ** (1 / 2)- isdown, isvisible :: Turtle -> IO Bool-isdown t = fmap (S.pendown . (states t !!)) $ readIORef $ stateIndex t-isvisible t = fmap (visible . (states t !!)) $ readIORef $ stateIndex t+isdown = flip info S.pendown+isvisible = flip info visible  windowWidth, windowHeight :: Turtle -> IO Double windowWidth = fmap fst . fieldSize . field windowHeight = fmap snd . fieldSize . field -----------------------------------------------------------------------------------getInputs :: Turtle -> IO [TurtleInput]-getInputs t = do-	i <- readIORef $ stateIndex t-	return $ take (i - 1) $ inputs t--sendInputs :: Turtle -> [TurtleInput] -> IO ()-sendInputs t = mapM_ (input t)--getSVG :: Turtle -> IO [SVG]-getSVG t = fmap (reverse . drawed . (states t !!)) $ readIORef $ stateIndex t+windowSize :: Turtle -> IO (Double, Double)+windowSize = fieldSize . field
src/Graphics/X11/Turtle/Data.hs view
@@ -11,7 +11,8 @@ 	("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)])]-	where unfold = uncurry (++) . (id &&& (reverse . map (second negate)))+	where unfold = uncurry (++) .+		(id &&& reverse . map (second negate) . init . tail)  speedTable :: [(String, (Maybe Double, Maybe Double))] speedTable = [
src/Graphics/X11/Turtle/Field.hs view
@@ -3,11 +3,15 @@ 	Field, 	Layer, 	Character,+	Coordinates(..), -	-- * open and close+	-- * basic functions 	openField, 	closeField, 	waitField,+	topleft,+	center,+	coordinates, 	fieldSize,  	-- * draw@@ -18,8 +22,8 @@ 	-- ** to Layer 	addLayer, 	drawLine,-	fillPolygon, 	fillRectangle,+	fillPolygon, 	writeString, 	drawImage, 	undoLayer,@@ -41,29 +45,28 @@ ) where  import Graphics.X11.Turtle.XTools(-	Display, Window, Pixmap, Atom, Point(..), Position, Dimension,+	Display, Window, Pixmap, Atom, Point(..), PositionXT, Dimension, 	XEventPtr, XIC, Bufs, undoBuf, bgBuf, topBuf, 	GCs, gcForeground, gcBackground, Event(..), 	forkIOX, openWindow, destroyWindow, closeDisplay, windowSize,-	flush, colorPixel, setForeground, copyArea,-	drawLineXT, writeStringXT,+	flush, copyArea, setForegroundXT,+	drawLineXT, fillRectangleXT, fillPolygonXT, writeStringXT, drawImageXT, 	allocaXEvent, waitEvent, pending, nextEvent, getEvent, filterEvent, 	utf8LookupString, buttonPress, buttonRelease, xK_VoidSymbol)-import qualified Graphics.X11.Turtle.XTools as X(fillPolygonXT, drawImageXT,-	fillRectangle) import Graphics.X11.Turtle.Layers( 	Layers, Layer, Character, newLayers, redrawLayers,-	makeLayer, addDraw, setBackground, undoLayer, clearLayer,-	makeCharacter, setCharacter)-import Text.XML.YJSVG(Color(..))+	makeLayer, background, addDraw, undoLayer, clearLayer,+	makeCharacter, character)+import Text.XML.YJSVG(Position(..), Color(..)) -import Control.Monad(forever, replicateM, when, join, unless)+import Control.Monad(when, unless, forever, replicateM, join) import Control.Monad.Tools(doWhile_, doWhile, whenM) import Control.Arrow((***)) import Control.Concurrent(-	forkIO, ThreadId, killThread, Chan, newChan, readChan, writeChan, threadDelay)--import Data.IORef(IORef, newIORef, readIORef, writeIORef, modifyIORef)+	ThreadId, forkIO, killThread, threadDelay,+	Chan, newChan, readChan, writeChan)+import Data.IORef(IORef, newIORef, readIORef, writeIORef)+import Data.IORef.Tools(atomicModifyIORef_) import Data.Maybe(fromMaybe) import Data.Convertible(convert) @@ -74,41 +77,48 @@ 	fIC :: XIC, fDel :: Atom, fSize :: IORef (Dimension, Dimension),  	fClick, fRelease :: IORef (Int -> Double -> Double -> IO Bool),-	fDrag :: IORef (Double -> Double -> IO ()),-	fMotion :: IORef (Double -> Double -> IO ()),-	fKeypress :: IORef (Char -> IO Bool), fPressed :: IORef Bool,+	fDrag, fMotion :: IORef (Double -> Double -> IO ()),+	fKeypress :: IORef (Char -> IO Bool), 	fTimerEvent :: IORef (IO Bool),+	fPressed :: IORef Bool, -	fLayers :: IORef Layers, fRunning :: IORef [ThreadId],-	fLock, fClose, fEnd :: Chan (),-	fInputChan :: Chan InputType- }+	fLayers :: IORef Layers, fInput :: Chan InputType,+	fCoordinates :: IORef Coordinates, fLock, fClose, fEnd :: Chan (),+	fRunning :: IORef [ThreadId]}  makeField :: Display -> Window -> Bufs -> GCs -> XIC -> Atom -> 	IORef (Dimension, Dimension) -> IORef Layers -> IO Field makeField dpy win bufs gcs ic del sizeRef ls = do 	[click, release] <- replicateM 2 $ newIORef $ \_ _ _ -> return True-	drag <- newIORef $ \_ _ -> return ()-	motion <- newIORef $ \_ _ -> return ()+	[drag, motion] <- replicateM 2 $ newIORef $ \_ _ -> return () 	keypress <- newIORef $ \_ -> return True-	pressed <- newIORef False 	timer <- newIORef $ return True-	running <- newIORef []+	pressed <- newIORef False+	input <- newChan+	coord <- newIORef CoordCenter 	[lock, close, end] <- replicateM 3 newChan-	inputChan <- newChan+	running <- newIORef [] 	writeChan lock () 	return Field{ 		fDisplay = dpy, fWindow = win, fBufs = bufs, fGCs = gcs, 		fIC = ic, fDel = del, fSize = sizeRef, -		fClick = click, fRelease = release, fDrag = drag, fMotion = motion,-		fKeypress = keypress, fPressed = pressed, fTimerEvent = timer,+		fClick = click, fRelease = release, fDrag = drag,+		fMotion = motion, fKeypress = keypress, fTimerEvent = timer,+		fPressed = pressed, -		fLayers = ls,-		fRunning = running,-		fLock = lock, fClose = close, fEnd = end, fInputChan = inputChan-	 }+		fLayers = ls, fInput = input, fCoordinates = coord,+		fLock = lock, fClose = close, fEnd = end, fRunning = running} +data Coordinates = CoordCenter | CoordTopLeft++coordinates :: Field -> IO Coordinates+coordinates = readIORef . fCoordinates++topleft, center :: Field -> IO ()+topleft = flip (writeIORef . fCoordinates) CoordTopLeft+center = flip (writeIORef . fCoordinates) CoordCenter+ --------------------------------------------------------------------------------  openField :: IO Field@@ -117,9 +127,10 @@ 	let	(ub, bb, tb) = (undoBuf bufs, bgBuf bufs, topBuf bufs) 		(gcf, gcb) = (gcForeground gcs, gcBackground gcs) 	sizeRef <- newIORef size-	let getSize = readIORef sizeRef+	let	getSize = readIORef sizeRef 	ls <- newLayers 50 -		(getSize >>= uncurry (X.fillRectangle dpy ub gcb 0 0))+		(setForegroundXT dpy gcb (RGB 255 255 255) >>+			getSize >>= uncurry (fillRectangleXT dpy ub gcb 0 0)) 		(getSize >>= \(w, h) -> copyArea dpy ub bb gcf 0 0 w h 0 0) 		(getSize >>= \(w, h) -> copyArea dpy bb tb gcf 0 0 w h 0 0) 	f <- makeField dpy win bufs gcs ic del sizeRef ls@@ -129,48 +140,42 @@  data InputType = XInput | End | Timer -waitInput :: Field -> IO (Chan InputType, Chan ())+waitInput :: Field -> IO (Chan ()) waitInput f = do---	go <- newChan-	let	go = fInputChan f 	empty <- newChan 	tid <- forkIOX $ forever $ do 		waitEvent $ fDisplay f-		writeChan go XInput+		writeChan (fInput f) XInput 		readChan empty-	modifyIORef (fRunning f) (tid :)+	atomicModifyIORef_ (fRunning f) (tid :) 	_ <- forkIO $ do 		readChan $ fClose f 		killThread tid-		writeChan go End-	return (go, empty)+		writeChan (fInput f) End+	return empty  runLoop :: Field -> IO () runLoop f = allocaXEvent $ \e -> do-	(go, empty) <- waitInput f+	empty <- waitInput f 	doWhile_ $ do-		iType <- readChan go-		cont' <- case iType of+		iType <- readChan $ fInput f+		cont <- case iType of+			End -> return False 			Timer -> do 				c <- join $ readIORef $ fTimerEvent f-				unless c $ readIORef (fRunning f) >>= mapM_ killThread-				return c -- readIORef (fTimerEvent f) >>= k-			_ -> return True-		let	notEnd = case iType of-				End -> False-				_ -> True-		cont <- doWhile True $ const $ do-			evN <- pending $ fDisplay f-			if evN > 0 then do+				unless c $ readIORef (fRunning f)+					>>= mapM_ killThread+				return c+			XInput -> doWhile undefined $ const $ do+				evN <- pending $ fDisplay f+				if evN <= 0 then return (True, False) else do 					nextEvent (fDisplay f) e 					filtered <- filterEvent e 0 					if filtered then return (True, True) 						else do	ev <- getEvent e 							c <- processEvent f e ev 							return (c, c)-				else return (True, False)-		if notEnd && cont && cont' then writeChan empty () >> return True-			else return False+		if cont then writeChan empty () >> return True else return False 	readIORef (fRunning f) >>= mapM_ killThread 	destroyWindow (fDisplay f) (fWindow f) 	closeDisplay $ fDisplay f@@ -180,15 +185,18 @@ processEvent f e ev = case ev of 	ExposeEvent{} -> flushField f True $ do 		windowSize (fDisplay f) (fWindow f) >>= writeIORef (fSize f)-		redrawLayers $ fLayers f-		return True+		redrawLayers (fLayers f) >> return True 	KeyEvent{} -> do 		(mstr, mks) <- utf8LookupString (fIC f) e 		let	str = fromMaybe "" mstr 			_ks = fromMaybe xK_VoidSymbol mks 		readIORef (fKeypress f) >>= fmap and . ($ str) . mapM 	ButtonEvent{} -> do-		pos <- center (ev_x ev) (ev_y ev)+		coord <- readIORef $ fCoordinates f+		pos <- case coord of+			CoordCenter -> cntr (ev_x ev) (ev_y ev)+			CoordTopLeft -> return+				(fromIntegral $ ev_x ev, fromIntegral $ ev_y ev) 		let	buttonN = fromIntegral $ ev_button ev 		case ev_event_type ev of 			et	| et == buttonPress -> do@@ -201,7 +209,7 @@ 						($ pos) . uncurry . ($ buttonN) 			_ -> error "not implement event" 	MotionEvent{} -> do-		pos <- center (ev_x ev) (ev_y ev)+		pos <- cntr (ev_x ev) (ev_y ev) 		whenM (readIORef $ fPressed f) $ 			readIORef (fDrag f) >>= ($ pos) . uncurry 		readIORef (fMotion f) >>= ($ pos) . uncurry@@ -209,7 +217,7 @@ 	ClientMessageEvent{} -> return $ convert (head $ ev_data ev) /= fDel f 	_ -> return True 	where-	center x y = do+	cntr x y = do 		(w, h) <- fieldSize f 		return (fromIntegral x - w / 2, fromIntegral (- y) + h / 2) @@ -227,27 +235,22 @@ forkField :: Field -> IO () -> IO ThreadId forkField f act = do 	tid <- forkIOX act-	modifyIORef (fRunning f) (tid :)-	return tid+	atomicModifyIORef_ (fRunning f) (tid :) >> return tid  flushField :: Field -> Bool -> IO a -> IO a flushField f real act = do-	readChan $ fLock f-	ret <- act+	ret <- readChan (fLock f) >> act 	when real $ do 		(w, h) <- readIORef $ fSize f 		copyArea (fDisplay f) (topBuf $ fBufs f) (fWindow f) 			(gcForeground $ fGCs f) 0 0 w h 0 0 		flush $ fDisplay f-	writeChan (fLock f) ()-	return ret+	writeChan (fLock f) () >> return ret  fieldColor :: Field -> Layer -> Color -> IO ()-fieldColor f l c = setBackground l $ do-	colorPixel (fDisplay f) c >>=-		maybe (return ())-			(setForeground (fDisplay f) (gcBackground $ fGCs f))-	readIORef (fSize f) >>= uncurry (X.fillRectangle+fieldColor f l clr = background l $ do+	setForegroundXT (fDisplay f) (gcBackground $ fGCs f) clr+	readIORef (fSize f) >>= uncurry (fillRectangleXT 		(fDisplay f) (undoBuf $ fBufs f) (gcBackground $ fGCs f) 0 0)  --------------------------------------------------------------------------------@@ -255,88 +258,79 @@ addLayer :: Field -> IO Layer addLayer = makeLayer . fLayers -drawLine :: Field -> Layer -> Double -> Color ->-	Double -> Double -> Double -> Double -> IO ()-drawLine f l lw clr x1 y1 x2 y2 =-	addDraw l (drawLineBuf f undoBuf (round lw) clr x1 y1 x2 y2,-		drawLineBuf f bgBuf (round lw) clr x1 y1 x2 y2)+drawLayer :: Field -> Layer -> (Pixmap -> IO ()) -> IO ()+drawLayer Field{fBufs = bufs} l draw =+	addDraw l (draw $ undoBuf bufs, draw $ bgBuf bufs) -writeString :: Field -> Layer -> String -> Double -> Color ->-	Double -> Double -> String -> IO ()-writeString f l fname size clr xc yc str = addDraw l (ws undoBuf, ws bgBuf)-	where ws bf = do-		(x, y) <- topLeft f xc yc-		writeStringXT (fDisplay f) (bf $ fBufs f) fname size clr x y str+drawLine :: Field -> Layer -> Double -> Color -> Position -> Position -> IO ()+drawLine f l lw clr p1 p2 =+	drawLayer f l $ \buf -> drawLineBuf f buf (round lw) clr p1 p2 -drawImage :: Field -> Layer -> FilePath -> Double -> Double -> Double -> Double -> IO ()-drawImage f l fp xc yc w h = addDraw l (di undoBuf, di bgBuf)-	where di bf = do-		(x, y) <- topLeft f xc yc-		X.drawImageXT (fDisplay f) (bf $ fBufs f) (gcForeground $ fGCs f)-			fp x y (round w) (round h)+writeString :: Field -> Layer -> String -> Double -> Color -> Position ->+	String -> IO ()+writeString f@Field{fDisplay = dpy} l fname size clr pos str =+	drawLayer f l $ \buf -> getPosition f pos >>=+		flip (uncurry $ writeStringXT dpy buf fname size clr) str -fillPolygon :: Field -> Layer -> [(Double, Double)] -> Color -> IO ()-fillPolygon f l psc clr = addDraw l (fp undoBuf, fp bgBuf)-	where fp bf = do-		ps <- mapM (fmap (uncurry Point) . uncurry (topLeft f)) psc-		colorPixel (fDisplay f) clr >>= maybe (return ())-			(setForeground (fDisplay f) (gcForeground $ fGCs f))-		X.fillPolygonXT (fDisplay f) (bf $ fBufs f) (gcForeground $ fGCs f) ps+drawImage :: Field -> Layer -> FilePath -> Position -> Double -> Double -> IO ()+drawImage f@Field{fDisplay = dpy} l fp pos w h = drawLayer f l $ \buf -> do+	(x, y) <- getPosition f pos+	drawImageXT dpy buf (gcForeground $ fGCs f) fp x y (round w) (round h) -fillRectangle ::-	Field -> Layer -> Double -> Double -> Double -> Double -> Color -> IO ()-fillRectangle f l xc0 yc0 w h clr = addDraw l (fr undoBuf, fr bgBuf)-	where fr bf = do-		(x0, y0) <- topLeft f xc0 yc0-		colorPixel (fDisplay f) clr >>= maybe (return ())-			(setForeground (fDisplay f) (gcForeground $ fGCs f))-		X.fillRectangle (fDisplay f) (bf $ fBufs f) (gcForeground $ fGCs f)-			x0 y0 (round w) (round h)+fillPolygon :: Field -> Layer -> [Position] -> Color -> IO ()+fillPolygon f@Field{fDisplay = dpy} l positions clr = drawLayer f l $ \buf -> do+	ps <- mapM (fmap (uncurry Point) . getPosition f) positions+	setForegroundXT dpy (gcForeground $ fGCs f) clr+	fillPolygonXT dpy buf (gcForeground $ fGCs f) ps -drawLineBuf :: Field -> (Bufs -> Pixmap) -> Int -> Color ->-	Double -> Double -> Double -> Double -> IO ()-drawLineBuf f bf lw c x1_ y1_ x2_ y2_ = do-	(x1, y1) <- topLeft f x1_ y1_-	(x2, y2) <- topLeft f x2_ y2_-	drawLineXT (fDisplay f) (gcForeground $ fGCs f) (bf $ fBufs f) lw c-		x1 y1 x2 y2+fillRectangle :: Field -> Layer -> Position -> Double -> Double -> Color -> IO ()+fillRectangle f@Field{fDisplay = dpy} l p w h clr = drawLayer f l $ \buf -> do+	(x, y) <- getPosition f p+	setForegroundXT dpy (gcForeground $ fGCs f) clr+	fillRectangleXT dpy buf (gcForeground $ fGCs f) x y (round w) (round h) -topLeft :: Field -> Double -> Double -> IO (Position, Position)-topLeft f x y = do-	(width, height) <- fieldSize f-	return (round $ x + width / 2, round $ - y + height / 2)+drawLineBuf :: Field -> Pixmap -> Int -> Color -> Position -> Position -> IO ()+drawLineBuf f@Field{fDisplay = dpy} buf lw clr p1 p2 = do+	(x1, y1) <- getPosition f p1+	(x2, y2) <- getPosition f p2+	drawLineXT dpy (gcForeground $ fGCs f) buf lw clr x1 y1 x2 y2 +getPosition :: Field -> Position -> IO (PositionXT, PositionXT)+getPosition f (Center x y) = do+	(w, h) <- fieldSize f+	return (round x + round (w / 2), - round y + round (h / 2))+getPosition _ (TopLeft x y) = return (round x, round y)+ --------------------------------------------------------------------------------  addCharacter :: Field -> IO Character addCharacter = makeCharacter . fLayers -drawCharacter :: Field -> Character -> Color -> [(Double, Double)] -> IO ()-drawCharacter f c clr sh = setCharacter c $ drawShape f clr sh+drawCharacter :: Field -> Character -> Color -> [Position] -> IO ()+drawCharacter f c clr sh = character c $ drawShape f clr sh -drawCharacterAndLine ::	Field -> Character -> Color -> [(Double, Double)] ->-	Double -> Double -> Double -> Double -> Double -> IO ()-drawCharacterAndLine f c clr sh lw x1 y1 x2 y2 = setCharacter c $-	drawShape f clr sh >> drawLineBuf f topBuf (round lw) clr x1 y1 x2 y2+drawCharacterAndLine ::	Field -> Character -> Color -> [Position] ->+	Double -> Position -> Position -> IO ()+drawCharacterAndLine f c clr sh lw p1 p2 = character c $ do+	drawShape f clr sh+	drawLineBuf f (topBuf $ fBufs f) (round lw) clr p1 p2 -drawShape :: Field -> Color -> [(Double, Double)] -> IO ()-drawShape f clr psc = do-	ps <- mapM (fmap (uncurry Point) . uncurry (topLeft f)) psc-	colorPixel (fDisplay f) clr >>= maybe (return ())-		(setForeground (fDisplay f) (gcForeground $ fGCs f))-	X.fillPolygonXT (fDisplay f) (topBuf $ fBufs f) (gcForeground $ fGCs f) ps+drawShape :: Field -> Color -> [Position] -> IO ()+drawShape f clr positions = do+	ps <- mapM (fmap (uncurry Point) . getPosition f) positions+	setForegroundXT (fDisplay f) (gcForeground $ fGCs f) clr+	fillPolygonXT (fDisplay f) (topBuf $ fBufs f) (gcForeground $ fGCs f) ps  clearCharacter :: Character -> IO ()-clearCharacter c = setCharacter c $ return ()+clearCharacter c = character c $ return ()  --------------------------------------------------------------------------------  onclick, onrelease :: Field -> (Int -> Double -> Double -> IO Bool) -> IO ()-(onclick, onrelease) = (writeIORef .) *** (writeIORef .) $ (fClick, fRelease)+(onclick, onrelease) = (writeIORef . fClick, writeIORef . fRelease)  ondrag, onmotion :: Field -> (Double -> Double -> IO ()) -> IO ()-ondrag = writeIORef . fDrag-onmotion = writeIORef . fMotion+(ondrag, onmotion) = (writeIORef . fDrag, writeIORef . fMotion)  onkeypress :: Field -> (Char -> IO Bool) -> IO () onkeypress = writeIORef . fKeypress@@ -345,4 +339,4 @@ ontimer f t fun = do 	writeIORef (fTimerEvent f) fun 	threadDelay $ t * 1000-	writeChan (fInputChan f) Timer+	writeChan (fInput f) Timer
src/Graphics/X11/Turtle/Input.hs view
@@ -17,41 +17,39 @@ 	polyPoints ) where -import Graphics.X11.Turtle.State(TurtleState(..), initialTurtleState)+import Graphics.X11.Turtle.State(TurtleState(..), initialTurtleState, makeShape) import Text.XML.YJSVG(SVG(..), Color(..), Position(..))- import Control.Concurrent.Chan(Chan, newChan, getChanContents)-import Control.Arrow  --------------------------------------------------------------------------------  data TurtleInput-	= Shape [(Double, Double)]-	| Shapesize Double Double-	| Pencolor Color-	| Pensize Double-	| SetPendown Bool-	| SetFill Bool-	| SetPoly Bool-	| SetVisible Bool-	| Degrees Double-	| PositionStep (Maybe Double)-	| DirectionStep (Maybe Double)-	| Undonum Int-	| Goto Double Double+	= Goto Position+	| Forward Double 	| Rotate Double+	| TurnLeft Double+	| Dot Double+	| Stamp 	| Write String Double String 	| PutImage FilePath Double Double-	| Stamp-	| Dot Double-	| Bgcolor Color 	| Undo+	| Undonum Int 	| Clear-	| Forward Double-	| TurnLeft Double 	| Sleep Int-	| SetFlush Bool 	| Flush+	| Shape [(Double, Double)]+	| Shapesize Double Double+	| Pensize Double+	| Pencolor Color+	| Bgcolor Color+	| SetPendown Bool+	| SetVisible Bool+	| SetFill Bool+	| SetPoly Bool+	| SetFlush Bool+	| PositionStep (Maybe Double)+	| DirectionStep (Maybe Double)+	| Degrees Double 	deriving (Show, Read)  turtleSeries :: IO (Chan TurtleInput, [TurtleInput], [TurtleState])@@ -65,78 +63,61 @@ 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-	x = x0 + len * cos (direction ts0)-	y = y0 + len * sin (direction ts0) in-	inputToTurtle tsbs ts0 $ Goto x y : tis+inputToTurtle tsbs ts0 (Forward len : tis) = case position ts0 of+	Center x0 y0 -> let+		x = x0 + len * cos (direction ts0)+		y = y0 + len * sin (direction ts0) in+		inputToTurtle tsbs ts0 $ Goto (Center x y) : tis+	TopLeft x0 y0 -> let+		x = x0 + len * cos (direction ts0)+		y = y0 - len * sin (direction ts0) in+		inputToTurtle tsbs ts0 $ Goto (TopLeft x y) : tis inputToTurtle tsbs ts0 (TurnLeft dd : tis) = inputToTurtle tsbs ts0 $ 	Rotate (direction ts0 * degrees ts0 / (2 * pi) + dd) : tis inputToTurtle tsbs ts0 (ti : tis) = 	let ts1 = nextTurtle ts0 ti in ts1 : inputToTurtle (ts0 : tsbs) ts1 tis inputToTurtle _ _ [] = error "no more input" +reset :: TurtleState -> TurtleState+reset t = t{draw = Nothing, clear = False, undo = False, undonum = 1,+	sleep = Nothing, flush = False}++set :: TurtleState -> Maybe SVG -> TurtleState+set t drw = t{draw = drw, drawed = maybe id (:) drw $ drawed t}+ nextTurtle :: TurtleState -> TurtleInput -> TurtleState-nextTurtle t (Shape sh) = (clearState t){shape = sh}-nextTurtle t (Shapesize sx sy) = (clearState t){shapesize = (sx, sy)}-nextTurtle t (Pencolor c) = (clearState t){pencolor = c}-nextTurtle t (Pensize ps) = (clearState t){pensize = ps}-nextTurtle t (SetPendown pd) = (clearState t){pendown = pd}-nextTurtle t (SetFill f) = (clearState t){-	fill = f,-	draw = if fill t && not f then Just fl else Nothing,-	drawed = if fill t && not f then fl : drawed t else drawed t,-	fillPoints = [(x0, y0) | f]}-	where-	(x0, y0) = position t-	fl = Polyline (uncurry Center `map` fillPoints t)-		(pencolor t) (pencolor t) 0-nextTurtle t (SetPoly p) = (clearState t){-	poly = p,-	polyPoints = if p then [position t] else polyPoints t}-nextTurtle t (SetVisible v) = (clearState t){visible = v}-nextTurtle t (Degrees ds) = (clearState t){degrees = ds}-nextTurtle t (PositionStep ps) = (clearState t){positionStep = ps}-nextTurtle t (DirectionStep ds) = (clearState t){directionStep = ds}-nextTurtle t (Undonum un) = (clearState t){undonum = un}-nextTurtle t (Goto x y) = (clearState t){-	position = (x, y),-	draw = if pendown t then Just ln else Nothing,-	drawed = if pendown t then ln : drawed t else drawed t,-	fillPoints = if fill t then (x, y) : fillPoints t else fillPoints t,-	polyPoints = if poly t then (x, y) : polyPoints t else polyPoints t}-	where-	(x0, y0) = position t-	ln = Line (Center x0 y0) (Center x y) (pencolor t) (pensize t)-nextTurtle t (Rotate d) = (clearState t){direction = d * 2 * pi / degrees t}-nextTurtle t (Write fnt sz str) = (clearState t){-	draw = Just txt, drawed = txt : drawed t}-	where txt = Text (uncurry Center $ position t) sz (pencolor t) fnt str-nextTurtle t (PutImage fp w h) = (clearState t){-	draw = Just img, drawed = img : drawed t}-	where img = Image (uncurry Center $ position t) w h fp-nextTurtle t Stamp = (clearState t){-	draw = Just stamp, drawed = stamp : drawed t}-	where-	(x0, y0) = position t-	sp = let (sx, sy) = shapesize t in-		map (((+ x0) *** (+ y0)) . rotate . ((* sx) *** (* sy))) $ shape t-	rotate (x, y) = let rad = direction t in-		(x * cos rad - y * sin rad, x * sin rad + y * cos rad)-	points = map (uncurry Center) sp-	stamp = Polyline points (pencolor t) (pencolor t) 0-nextTurtle t (Dot sz) = (clearState t){-	draw = Just dot, drawed = dot : drawed t}-	where-	dot = Rect (uncurry Center $ position t) sz sz 0 (pencolor t) (pencolor t)-nextTurtle t (Bgcolor c) = (clearState t){-	bgcolor = c, drawed = init (drawed t) ++ [Fill c]}-nextTurtle t Clear = (clearState t){clear = True, drawed = [last $ drawed t]}-nextTurtle t (Sleep time) = (clearState t){sleep = Just time}-nextTurtle t (SetFlush ss) = (clearState t){stepbystep = ss}-nextTurtle t Flush = (clearState t){flush = True}+nextTurtle t (Goto pos) = (reset t){position = pos,+	fillPoints = (if fill t then (pos :) else id) $ fillPoints t,+	polyPoints = (if poly t then (pos :) else id) $ polyPoints t}+	`set` if not $ pendown t then Nothing+		else Just $ Line pos (position t) (pencolor t) (pensize t)+nextTurtle t (Rotate dir) = (reset t){direction = dir * 2 * pi / degrees t}+nextTurtle t (Dot sz) =+	reset t `set` Just (Rect (position t) sz sz 0 (pencolor t) (pencolor t))+nextTurtle t@TurtleState{pencolor = clr} Stamp = reset t `set`+	Just (Polyline (makeShape t (direction t) (position t)) clr clr 0)+nextTurtle t (Write fnt sz str) =+	reset t `set` Just (Text (position t) sz (pencolor t) fnt str)+nextTurtle t (PutImage fp w h) = reset t `set` Just (Image (position t) w h fp)+nextTurtle t (Undonum un) = (reset t){undonum = un}+nextTurtle t Clear = (reset t){clear = True, drawed = [last $ drawed t]}+nextTurtle t (Sleep time) = (reset t){sleep = Just time}+nextTurtle t Flush = (reset t){flush = True}+nextTurtle t (Shape sh) = (reset t){shape = sh}+nextTurtle t (Shapesize sx sy) = (reset t){shapesize = (sx, sy)}+nextTurtle t (Pensize ps) = (reset t){pensize = ps}+nextTurtle t (Pencolor clr) = (reset t){pencolor = clr}+nextTurtle t (Bgcolor clr) = (reset t){+	draw = Just $ Fill clr, drawed = init (drawed t) ++ [Fill clr]}+nextTurtle t (SetPendown pd) = (reset t){pendown = pd}+nextTurtle t (SetVisible v) = (reset t){visible = v}+nextTurtle t (SetFill fl) = (reset t){fill = fl, fillPoints = [position t | fl]}+	`set` (if not (fill t) || fl then Nothing+		else Just $ Polyline (fillPoints t) (pencolor t) (pencolor t) 0)+nextTurtle t (SetPoly p) = (reset t){+	poly = p, polyPoints = if p then [position t] else polyPoints t}+nextTurtle t (SetFlush ss) = (reset t){stepbystep = ss}+nextTurtle t (PositionStep ps) = (reset t){positionStep = ps}+nextTurtle t (DirectionStep ds) = (reset t){directionStep = ds}+nextTurtle t (Degrees ds) = (reset t){degrees = ds} nextTurtle _ _ = error "not defined"--clearState :: TurtleState -> TurtleState-clearState t = t{undonum = 1, undo = False, clear = False, draw = Nothing,-	sleep = Nothing, flush = False}
src/Graphics/X11/Turtle/Layers.hs view
@@ -11,11 +11,11 @@  	-- * draws 	redrawLayers,+	background, 	addDraw,-	setBackground, 	undoLayer, 	clearLayer,-	setCharacter+	character ) where  import Control.Monad(when, unless)@@ -26,15 +26,14 @@ --------------------------------------------------------------------------------  data Layers = Layers{-	undoNum :: Int,-	clearLayersAction :: IO (),-	undoLayersAction :: IO (),-	clearCharactersAction :: IO (),-	background :: [IO ()],-	buffed :: [IO ()],+	backgrounds :: [IO ()],+	buffers :: [IO ()], 	layers :: [[(IO (), IO ())]],-	characters :: [IO ()]- }+	characters :: [IO ()],+	buffSize :: Int,+	clearBuffers :: IO (),+	clearLayers :: IO (),+	clearCharacters :: IO ()}  data Layer = Layer{ 	layerId :: Int,@@ -49,22 +48,21 @@ --------------------------------------------------------------------------------  newLayers :: Int -> IO () -> IO () -> IO () -> IO (IORef Layers)-newLayers un cla ula cca = newIORef Layers{-	undoNum = un,-	clearLayersAction = cla,-	undoLayersAction = ula,-	clearCharactersAction = cca,-	background = [],-	buffed = [],+newLayers bsize cbuf clyr cchr = newIORef Layers{+	backgrounds = [],+	buffers = [], 	layers = [],-	characters = []- }+	characters = [],+	buffSize = bsize,+	clearBuffers = cbuf,+	clearLayers = clyr,+	clearCharacters = cchr}  makeLayer :: IORef Layers -> IO Layer makeLayer rls = atomicModifyIORef rls $ \ls -> (ls{-		layers = layers ls ++ [[]],-		buffed = buffed ls ++ [return ()],-		background = background ls ++[return ()]},+		backgrounds = backgrounds ls ++[return ()],+		buffers = buffers ls ++ [return ()],+		layers = layers ls ++ [[]]}, 	Layer{layerId = length $ layers ls, layerLayers = rls})  makeCharacter :: IORef Layers -> IO Character@@ -77,27 +75,27 @@  redrawLayers :: IORef Layers -> IO () redrawLayers rls = readIORef rls >>= \ls -> do-	sequence_ $ background ls-	clearLayersAction ls >> sequence_ (buffed ls)-	undoLayersAction ls >> mapM_ snd (concat $ layers ls)-	clearCharactersAction ls >> sequence_ (characters ls)+	clearBuffers ls >> sequence_ (backgrounds ls) >> sequence_ (buffers ls)+	clearLayers ls >> mapM_ snd (concat $ layers ls)+	clearCharacters ls >> sequence_ (characters ls)  addDraw :: Layer -> (IO (), IO ()) -> IO () addDraw Layer{layerId = lid, layerLayers = rls} acts@(_, act) = do 	readIORef rls >>= \ls -> do-		act >> clearCharactersAction ls >> sequence_ (characters ls)-		unless (length (layers ls !! lid) < undoNum ls) $+		act >> clearCharacters ls >> sequence_ (characters ls)+		unless (length (layers ls !! lid) < buffSize ls) $ 			fst $ head $ layers ls !! lid-	atomicModifyIORef_ rls $ \ls -> if length (layers ls !! lid) < undoNum ls-		then ls{layers = modifyAt (layers ls) lid (++ [acts])}-		else let (a, _) : as = layers ls !! lid in ls{-			layers = setAt (layers ls) lid $ as ++ [acts],-			buffed = modifyAt (buffed ls) lid (>> a)}+	atomicModifyIORef_ rls $ \ls ->+		if length (layers ls !! lid) < buffSize ls+			then ls{layers = modifyAt (layers ls) lid (++ [acts])}+			else let (a, _) : as = layers ls !! lid in ls{+				layers = setAt (layers ls) lid $ as ++ [acts],+				buffers = modifyAt (buffers ls) lid (>> a)} -setBackground :: Layer -> IO () -> IO ()-setBackground Layer{layerId = lid, layerLayers = rls} act = do+background :: Layer -> IO () -> IO ()+background Layer{layerId = lid, layerLayers = rls} act = do 	atomicModifyIORef_ rls $ \ls ->-		ls{background = setAt (background ls) lid act}+		ls{backgrounds = setAt (backgrounds ls) lid act} 	redrawLayers rls  undoLayer :: Layer -> IO Bool@@ -106,20 +104,21 @@ 		then (ls, False) 		else (ls{layers = modifyAt (layers ls) lid init}, True) 	when done $ readIORef rls >>= \ls -> do-		undoLayersAction ls >> mapM_ snd (concat $ layers ls)-		clearCharactersAction ls >> sequence_ (characters ls)+		clearLayers ls >> mapM_ snd (concat $ layers ls)+		clearCharacters ls >> sequence_ (characters ls) 	return done  clearLayer :: Layer -> IO () clearLayer Layer{layerId = lid, layerLayers = rls} = do 	atomicModifyIORef_ rls $ \ls -> ls{-		layers = setAt (layers ls) lid [],-		buffed = setAt (buffed ls) lid $ return ()}+		backgrounds = setAt (backgrounds ls) lid $ return (),+		buffers = setAt (buffers ls) lid $ return (),+		layers = setAt (layers ls) lid []} 	redrawLayers rls -setCharacter :: Character -> IO () -> IO ()-setCharacter Character{characterId = cid, characterLayers = rls} act = do+character :: Character -> IO () -> IO ()+character Character{characterId = cid, characterLayers = rls} act = do 	atomicModifyIORef_ rls $ \ls -> 		ls{characters = setAt (characters ls) cid act} 	readIORef rls >>= \ls ->-		clearCharactersAction ls >> sequence_ (characters ls)+		clearCharacters ls >> sequence_ (characters ls)
src/Graphics/X11/Turtle/Move.hs view
@@ -1,23 +1,25 @@-module Graphics.X11.Turtle.Move (+module Graphics.X11.Turtle.Move( 	-- * types 	Field,-	Layer,-	Character,+	Coordinates(..),  	-- * process Field 	openField, 	closeField,-	forkField,-	waitField, 	fieldSize,+	coordinates,+	topleft,+	center,+	waitField,  	-- * draws+	forkField, 	flushField,-	moveTurtle, 	addLayer, 	clearLayer, 	addCharacter, 	clearCharacter,+	moveTurtle,  	-- * event 	onclick,@@ -28,21 +30,21 @@ 	ontimer ) where -import Graphics.X11.Turtle.State(TurtleState(..))+import Graphics.X11.Turtle.State(TurtleState(..), makeShape) import Graphics.X11.Turtle.Field(-	Field, Layer, Character,-	openField, closeField, waitField, fieldSize,-	forkField, flushField, fieldColor,-	addLayer, drawLine, writeString, undoLayer, clearLayer, fillPolygon,-	fillRectangle,-	addCharacter, drawCharacter, drawCharacterAndLine, clearCharacter,-	onclick, onrelease, ondrag, onmotion, onkeypress, drawImage, ontimer)+	Field, Layer, Character, Coordinates(..),+	openField, closeField, fieldSize, coordinates, topleft, center,+	waitField, forkField, flushField,+	addLayer, clearLayer, addCharacter, clearCharacter,+	onclick, onrelease, ondrag, onmotion, onkeypress, ontimer,+	fieldColor, drawLine, fillRectangle, fillPolygon, writeString,+	drawImage, undoLayer, drawCharacter, drawCharacterAndLine) import Text.XML.YJSVG(SVG(..), Position(..))+import qualified Text.XML.YJSVG as S(topleft)  import Control.Concurrent(threadDelay) import Control.Monad(when, unless, forM_) import Control.Monad.Tools(unlessM)-import Control.Arrow((***)) import Data.Maybe(isJust)  --------------------------------------------------------------------------------@@ -51,70 +53,64 @@ moveTurtle _ _ _ _ TurtleState{sleep = Just t} = threadDelay $ 1000 * t moveTurtle f _ _ _ TurtleState{flush = True} = flushField f True $ return () moveTurtle f c l t0 t1 = do-	when (undo t1) $ flushField f fl $ do+	(w, h) <- fieldSize f+	when (undo t1) $ fl $ do 		when (clear t0) redraw 		when (isJust $ draw t0) $ do 			unlessM (undoLayer l) $ clearLayer l >> redraw-			when (visible t1) $ drawT (direction t1) $ position t0+			when (visible t1) $ drawTtl (direction t0) $ position t0 	when (visible t1) $ do-		forM_ (directions t0 t1) $ \dir -> flushField f fl $-			drawT dir (position t0) >> threadDelay (interval t0)-		forM_ (positions t0 t1) $ \p -> flushField f fl $-			drawT (direction t1) p >> threadDelay (interval t0)-		flushField f fl $ drawT (direction t1) $ position t1-	when (bgcolor t0 /= bgcolor t1) $-		flushField f fl $ fieldColor f l $ bgcolor t1-	unless (undo t1) $ flushField f fl $ do-		when (visible t0 && not (visible t1)) $ clearCharacter c-		when (clear t1) $ clearLayer l-		maybe (return ()) (drawSVG f l) (draw t1)+		forM_ (directions t0 t1) $ \dir -> fl $+			drawTtl dir (position t0) >> threadDelay (interval t0)+		forM_ (positions w h t0 t1) $ \p -> fl $+			drawTtl (direction t1) p >> threadDelay (interval t0)+		fl $ drawTtl (direction t1) $ position t1+	when (visible t0 && not (visible t1)) $ fl $ clearCharacter c+	when (clear t1) $ fl $ clearLayer l+	unless (undo t1) $ fl $ maybe (return ()) (drawSVG f l) (draw t1) 	where-	fl = stepbystep t0+	fl = flushField f $ stepbystep t0 	redraw = mapM_ (drawSVG f l) $ reverse $ drawed t1-	drawT d p = drawTurtle f c t1 d p lineOrigin-	lineOrigin	| undo t1 && pendown t0 = Just $ position t1-			| pendown t1 = Just $ position t0-			| otherwise = Nothing+	drawTtl dir pos = drawTurtle f c t1 dir pos begin+	begin	| undo t1 && pendown t0 = Just $ position t1+		| pendown t1 = Just $ position t0+		| otherwise = Nothing  drawSVG :: Field -> Layer -> SVG -> IO ()-drawSVG f l (Line (Center x0 y0) (Center x1 y1) clr lw) =-	drawLine f l lw clr x0 y0 x1 y1-drawSVG f l (Text (Center x y) sz clr fnt str) =-	writeString f l fnt sz clr x y str-drawSVG f l (Polyline ps fc _ 0) = fillPolygon f l (map posToTup ps) fc-	where-	posToTup (Center x y) = (x, y)-	posToTup _ = error "not implemented"-drawSVG f l (Rect (Center x y) w h 0 fc _) = fillRectangle f l x y w h fc-drawSVG f l (Image (Center x0 y0) w h fp) = drawImage f l fp x0 y0 w h-drawSVG _ _ (Fill _) = return ()+drawSVG f l (Line p0 p1 clr lw) = drawLine f l lw clr p0 p1+drawSVG f l (Rect pos w h 0 fc _) = fillRectangle f l pos w h fc+drawSVG f l (Polyline ps fc _ 0) = fillPolygon f l ps fc+drawSVG f l (Fill clr) = fieldColor f l clr+drawSVG f l (Text pos sz clr fnt str) = writeString f l fnt sz clr pos str+drawSVG f l (Image pos w h fp) = drawImage f l fp pos w h drawSVG _ _ _ = error "not implemented" -positions :: TurtleState -> TurtleState -> [(Double, Double)]-positions t0 t1 = case positionStep t0 of-	Nothing -> []-	Just step -> take (floor $ dist / step) $ zip-		[x0, x0 + step * (x1 - x0) / dist .. ]-		[y0, y0 + step * (y1 - y0) / dist .. ]+positions :: Double -> Double -> TurtleState -> TurtleState -> [Position]+positions w h t0 t1 =+	maybe [] (mkPositions w h (position t0) (position t1)) $ positionStep t0++mkPositions :: Double -> Double -> Position -> Position -> Double -> [Position]+mkPositions w h p1 p2 step = case (p1, p2) of+	(Center x0 y0, Center x1 y1) -> map (uncurry Center) $ mp x0 y0 x1 y1+	(TopLeft x0 y0, TopLeft x1 y1) -> map (uncurry TopLeft) $ mp x0 y0 x1 y1+	_ -> mkPositions w h (S.topleft w h p1) (S.topleft w h p2) step 	where-	[(x0, y0), (x1, y1)] = map position [t0, t1]-	dist = ((x1 - x0) ** 2 + (y1 - y0) ** 2) ** (1/2)+	mp x0 y0 x1 y1 = let dist = ((x1 - x0) ** 2 + (y1 - y0) ** 2) ** (1 / 2)+		in take (floor $ dist / step) $ zip+			[x0, x0 + step * (x1 - x0) / dist .. ]+			[y0, y0 + step * (y1 - y0) / dist .. ]  directions :: TurtleState -> TurtleState -> [Double] directions t0 t1 = case directionStep t0 of 	Nothing -> []-	Just step -> let dd = if de > ds then step else - step in-		[ds, ds + dd .. de - dd]-	where-	ds = direction t0-	de = direction t1+	Just step -> [ds, ds + dd .. de - dd]+		where+		dd = if de > ds then step else - step+		ds = direction t0+		de = direction t1 -drawTurtle :: Field -> Character -> TurtleState -> Double ->-	(Double, Double) -> Maybe (Double, Double) -> IO ()-drawTurtle f c t d (px, py) = maybe (drawCharacter f c (pencolor t) sp)-	(uncurry $ drawCharacterAndLine f c (pencolor t) sp (pensize t) px py)-	where-	sp = let (sx, sy) = shapesize t in-		map (((+ px) *** (+ py)) . rotate . ((* sx) *** (* sy))) $ shape t-	rotate (x, y) = let rad = d in-		(x * cos rad - y * sin rad, x * sin rad + y * cos rad)+drawTurtle :: Field -> Character -> TurtleState -> Double -> Position ->+	Maybe Position -> IO ()+drawTurtle f c ts@TurtleState{pencolor = clr} dir pos = maybe+	(drawCharacter f c clr $ makeShape ts dir pos)+	(drawCharacterAndLine f c clr (makeShape ts dir pos) (pensize ts) pos)
src/Graphics/X11/Turtle/State.hs view
@@ -1,62 +1,72 @@-module Graphics.X11.Turtle.State (-	TurtleState(..),-	initialTurtleState-) where+module Graphics.X11.Turtle.State(+	TurtleState(..), initialTurtleState, makeShape) where -import Text.XML.YJSVG(SVG(Fill), Color(RGB))+import Text.XML.YJSVG(Position(..), SVG(Fill), Color(RGB))+import Control.Arrow((***))+import Data.Tuple.Tools(rotate)  data TurtleState = TurtleState {-	position :: (Double, Double),-	positionStep :: Maybe Double,+	position :: Position, 	direction :: Double, 	degrees :: Double,-	directionStep :: Maybe Double,-	interval :: Int,-	pendown :: Bool,-	fill :: Bool,-	poly :: Bool,-	pensize :: Double,-	pencolor :: Color,-	bgcolor :: Color, 	shape :: [(Double, Double)], 	shapesize :: (Double, Double),+	pensize :: Double,+	pencolor :: Color,+	pendown :: Bool, 	visible :: Bool,+	stepbystep :: Bool,++	draw :: Maybe SVG,+	drawed :: [SVG], 	clear :: Bool, 	undo :: Bool, 	undonum :: Int,-	draw :: Maybe SVG,-	drawed :: [SVG],-	fillPoints :: [(Double, Double)],-	polyPoints :: [(Double, Double)], 	sleep :: Maybe Int,-	stepbystep :: Bool,-	flush :: Bool}-	deriving Show+	flush :: Bool,+	fill :: Bool,+	poly :: Bool,+	fillPoints :: [Position],+	polyPoints :: [Position], +	positionStep :: Maybe Double,+	directionStep :: Maybe Double,+	interval :: Int}+ initialTurtleState :: TurtleState initialTurtleState = TurtleState {-	position = (0, 0),-	positionStep = Just 10,+	position = Center 0 0, 	direction = 0, 	degrees = 360,-	directionStep = Just $ pi / 18,-	interval = 10000,-	pendown = True,-	fill = False,-	poly = False,-	pensize = 1,-	pencolor = RGB 0 0 0,-	bgcolor = RGB 255 255 255, 	shape = [], 	shapesize = (1, 1),+	pensize = 1,+	pencolor = RGB 0 0 0,+	pendown = True, 	visible = True,+	stepbystep = True,++	draw = Nothing,+	drawed = [Fill $ RGB 255 255 255], 	clear = False, 	undo = False, 	undonum = 0,-	draw = Nothing,-	drawed = [Fill $ RGB 255 255 255],+	sleep = Nothing,+	flush = False,+	fill = False,+	poly = False, 	fillPoints = [], 	polyPoints = [],-	sleep = Nothing,-	stepbystep = True,-	flush = False}++	positionStep = Just 10,+	directionStep = Just $ pi / 18,+	interval = 10000}++makeShape :: TurtleState -> Double -> Position -> [Position]+makeShape ts dir_ pos = (mkPos . move . rotate dir . resize) `map` shape ts+	where+	move = (+ posX pos) *** (+ posY pos)+	resize = uncurry (***) $ ((*) *** (*)) $ shapesize ts+	(mkPos, dir) = case pos of+		Center{} -> (uncurry Center, dir_)+		TopLeft{} -> (uncurry TopLeft, - dir_)
src/Graphics/X11/Turtle/XTools.hs view
@@ -6,7 +6,7 @@ 	XIC, 	Atom, 	Point(..),-	Position,+	PositionXT, 	Dimension, 	Bufs, 	undoBuf,@@ -29,10 +29,9 @@  	-- * draw functions 	flush,-	colorPixel,-	setForeground,+	setForegroundXT, 	copyArea,-	fillRectangle,+	fillRectangleXT, 	fillPolygonXT, 	drawLineXT, 	writeStringXT,@@ -54,7 +53,7 @@ import Text.XML.YJSVG(Color(..))  import Graphics.X11(-	Display, Drawable, Window, Pixmap, GC, Pixel, Atom, Point(..), Position,+	Display, Drawable, Window, Pixmap, GC, Atom, Point(..), Position, 	Dimension, XEventPtr, 	initThreads, flush, supportsLocale, setLocaleModifiers, 	connectionNumber, openDisplay, closeDisplay, internAtom,@@ -97,6 +96,7 @@  -------------------------------------------------------------------------------- +type PositionXT = Position data Bufs = Bufs{undoBuf :: Pixmap, bgBuf :: Pixmap, topBuf :: Pixmap} data GCs = GCs{gcForeground :: GC, gcBackground :: GC} @@ -139,20 +139,26 @@  -------------------------------------------------------------------------------- -colorPixel :: Display -> Color -> IO (Maybe Pixel)-colorPixel _ (RGB r g b) = return $ Just $ shift (fromIntegral r) 16 .|.-	shift (fromIntegral g) 8 .|. fromIntegral b-colorPixel dpy (ColorName cn) = fmap (Just . color_pixel . fst)-	(allocNamedColor dpy (defaultColormap dpy $ defaultScreen dpy) cn)-		`catch` const (putStrLn "no such color" >> return Nothing)+setForegroundXT :: Display -> GC -> Color -> IO ()+setForegroundXT dpy gc (RGB r g b) =+	setForeground dpy gc $ shift (fromIntegral r) 16 .|.+		shift (fromIntegral g) 8 .|. fromIntegral b+setForegroundXT dpy gc (ColorName cn) =+	(allocNamedColor dpy (defaultColormap dpy $ defaultScreen dpy) cn+		>>= setForeground dpy gc . color_pixel . fst)+	`catch` const (putStrLn "no such color") +fillRectangleXT :: Display -> Drawable -> GC ->+	Position -> Position -> Dimension -> Dimension -> IO ()+fillRectangleXT = fillRectangle+ fillPolygonXT :: Display -> Drawable -> GC -> [Point] -> IO () fillPolygonXT d w gc ps = fillPolygon d w gc ps nonconvex coordModeOrigin  drawLineXT :: Display -> GC -> Drawable -> Int -> Color -> 	Position -> Position -> Position -> Position -> IO ()-drawLineXT dpy gc buf lw c x1 y1 x2 y2 = do-	colorPixel dpy c >>= maybe (return ()) (setForeground dpy gc)+drawLineXT dpy gc buf lw clr x1 y1 x2 y2 = do+	setForegroundXT dpy gc clr 	setLineAttributes dpy gc (fromIntegral lw) lineSolid capRound joinRound 	drawLine dpy buf gc x1 y1 x2 y2 @@ -170,8 +176,8 @@ 			where 			color = XRenderColor { 				xrendercolor_red = fromIntegral r * 0x100,-				xrendercolor_green = fromIntegral b * 0x100, 				xrendercolor_blue = fromIntegral g * 0x100,+				xrendercolor_green = fromIntegral b * 0x100, 				xrendercolor_alpha = 0xffff} 		ColorName cn -> withXftColorName dpy visual colormap cn $ \c -> 			xftDrawString xftDraw c xftFont x y str@@ -187,9 +193,9 @@ 	case err of 		ImlibLoadErrorNone -> do 			contextSetImage img-			let	zero = 0 :: Int-			w <- fmap fromIntegral imageGetWidth :: IO Int-			h <- fmap fromIntegral imageGetHeight :: IO Int+			let	zero = 0 :: Position+			w <- fmap fromIntegral imageGetWidth :: IO Dimension+			h <- fmap fromIntegral imageGetHeight :: IO Dimension 			img' <- createCroppedScaledImage zero zero w h nw nh 			contextSetImage img' 			fmap Just imageGetData@@ -197,14 +203,13 @@  drawBitmap :: Display -> Drawable -> GC -> Position -> Position -> Dimension -> 	Dimension -> Ptr Word32 -> IO ()-drawBitmap dpy win gc x0 y0 w h dat = do+drawBitmap dpy win gc x0 y0 w_ h_ dat = do 	ptr <- newIORef dat-	forM_ [0 .. w * h - 1] $ \i -> do+	forM_ [0 .. w * h - 1]  $ \i -> do 		readIORef ptr >>= peek >>= setForeground dpy gc-		let	x = fromIntegral i `mod` w-			y = fromIntegral i `div` w-		drawPoint dpy win gc (x0 + fromIntegral x) (y0 + fromIntegral y)+		drawPoint dpy win gc (x0 + i `mod` w) (y0 + i `div` w) 		atomicModifyIORef_ ptr $ flip advancePtr 1+	where [w, h] = map fromIntegral [w_, h_]  --------------------------------------------------------------------------------
xturtle.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.6  name:		xturtle-version:	0.1.6+version:	0.1.9 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -30,8 +30,8 @@ library   Hs-source-dirs:	src   Exposed-modules:	Graphics.X11.Turtle-  Build-depends:	base > 3 && < 5, yjtools >= 0.9.14, convertible >= 1.0.8, X11,-    X11-xft <= 3.1, x11-xim, setlocale, yjsvg >= 0.1.13, Imlib >= 0.1.2+  Build-depends:	base > 3 && < 5, yjtools >= 0.9.15, convertible >= 1.0.8, X11,+    X11-xft <= 3.1, x11-xim, setlocale, yjsvg >= 0.1.14, Imlib >= 0.1.2   Ghc-options:		-Wall   Other-modules:	Graphics.X11.Turtle.Field, Graphics.X11.Turtle.Input,     Graphics.X11.Turtle.Move, Graphics.X11.Turtle.State, Graphics.X11.Turtle.Data,