packages feed

xturtle 0.0.16 → 0.0.17

raw patch · 9 files changed

+670/−696 lines, 9 filesdep ~yjsvg

Dependency ranges changed: yjsvg

Files

src/Graphics/X11/Turtle.hs view
@@ -35,6 +35,7 @@ 	-- * change turtle state 	shape, 	shapesize,+	speed, 	showturtle, 	hideturtle, 	pendown,@@ -71,27 +72,26 @@  import Graphics.X11.Turtle.Move( 	Field, Layer, Character,-	forkIOX, openField, closeField,+	forkField, openField, closeField, 	addCharacter, addLayer, fieldSize, clearLayer, clearCharacter,-	addThread, fieldColor, onclick, onrelease, ondrag, onkeypress, waitField,-	moveTurtle+	onclick, onrelease, ondrag, onkeypress, waitField,+	moveTurtle, flushField  ) import Graphics.X11.Turtle.Input( 	TurtleInput(..), TurtleState,-	getTurtleStates, undonum, visible, direction,+	turtleSeries, undonum, visible, direction, 	drawed  ) 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.Concurrent(Chan, writeChan, ThreadId, killThread) import Control.Monad(replicateM_, zipWithM_)-import Prelude hiding(Left) import Data.IORef(IORef, newIORef, readIORef, modifyIORef) import Data.Fixed(mod')  xturtleVersion :: (Int, String)-xturtleVersion = (34, "0.0.16")+xturtleVersion = (41, "0.0.17")  data Turtle = Turtle { 	field :: Field,@@ -108,7 +108,7 @@ newTurtle f = do 	ch <- addCharacter f 	l <- addLayer f-	(ic, tis, sts) <- getTurtleStates+	(ic, tis, sts) <- turtleSeries 	si <- newIORef 1 	let	t = Turtle { 			field = f,@@ -120,15 +120,15 @@ 			stateIndex = si, 			thread = undefined 		 }-	tid <- forkIOX $ zipWithM_ (moveTurtle f ch l) sts $ tail sts-	addThread f tid+	tid <- forkField f $ zipWithM_ (moveTurtle f ch l) sts $ tail sts 	shape t "classic"+	sendCommand t $ Undonum 0 	return t{thread = tid} -killTurtle :: Field -> Turtle -> IO ()-killTurtle f t = do+killTurtle :: Turtle -> IO ()+killTurtle t = flushField (field t) $ do 	clearLayer $ layer t-	clearCharacter f $ character t+	clearCharacter $ character t 	killThread $ thread t  hideturtle, showturtle :: Turtle -> IO ()@@ -139,20 +139,19 @@ sendCommand Turtle{inputChan = c, stateIndex = si} ti = do 	modifyIORef si (+ 1) 	writeChan c ti-	threadDelay 10000  shape :: Turtle -> String -> IO () shape t = sendCommand t . Shape . nameToShape -shapesize :: Turtle -> Double -> IO ()-shapesize t = sendCommand t . ShapeSize+shapesize :: Turtle -> Double -> Double -> IO ()+shapesize t sx sy = sendCommand t $ Shapesize sx sy  forward, backward :: Turtle -> Double -> IO () forward t = sendCommand t . Forward backward t = forward t . negate  left, right, setheading :: Turtle -> Double -> IO ()-left t = sendCommand t . Left+left t = sendCommand t . TurnLeft right t = left t . negate setheading t = sendCommand t . Rotate @@ -187,8 +186,8 @@ 	fmap (S.degrees . (s !!)) $ readIORef si  penup, pendown :: Turtle -> IO ()-penup = flip sendCommand Penup-pendown = flip sendCommand Pendown+penup = flip sendCommand $ SetPendown False+pendown = flip sendCommand $ SetPendown True  pencolor :: ColorClass c => Turtle -> c -> IO () pencolor t c = sendCommand t $ Pencolor $ getColor c@@ -202,12 +201,30 @@ instance (Integral r, Integral g, Integral b) => ColorClass (r, g, b) where 	getColor (r, g, b) = RGB (fromIntegral r) (fromIntegral g) (fromIntegral b) -bgcolor :: ColorClass c => Field -> c -> IO ()-bgcolor f = fieldColor f . getColor+bgcolor :: ColorClass c => Turtle -> c -> IO ()+bgcolor t = sendCommand t . Bgcolor . getColor  pensize :: Turtle -> Double -> IO () pensize t = sendCommand t . Pensize +speed :: Turtle -> String -> IO ()+speed t "fastest" = do+	sendCommand t $ PositionStep Nothing+	sendCommand t $ DirectionStep Nothing+speed t "fast" = do+	sendCommand t $ PositionStep $ Just 60+	sendCommand t $ DirectionStep $ Just $ pi / 3+speed t "normal" = do+	sendCommand t $ PositionStep $ Just 20+	sendCommand t $ DirectionStep $ Just $ pi / 9+speed t "slow" = do+	sendCommand t $ PositionStep $ Just 10+	sendCommand t $ DirectionStep $ Just $ pi / 18+speed t "slowest" = do+	sendCommand t $ PositionStep $ Just 3+	sendCommand t $ DirectionStep $ Just $ pi / 60+speed _ _ = putStrLn "no such speed"+ degrees :: Turtle -> Double -> IO () degrees t = sendCommand t . Degrees @@ -236,7 +253,7 @@ heading :: Turtle -> IO Double heading t = do 	deg <- getDegrees t-	dir <- fmap (direction . (states t !!)) $ readIORef $ stateIndex t+	dir <- fmap ((* (deg / (2 * pi))) . direction . (states t !!)) $ readIORef $ stateIndex t 	return $ dir `mod'` deg  towards :: Turtle -> Double -> Double -> IO Double
src/Graphics/X11/Turtle/Field.hs view
@@ -1,443 +1,287 @@ module Graphics.X11.Turtle.Field(+	-- * types and classes 	Field,-	withLock2,- 	Layer, 	Character, +	-- * open and close 	openField, 	closeField, 	waitField,-	fieldColor, 	fieldSize, -	addLayer,-	addCharacter,+	-- * draw+	forkField,+	flushField,+	fieldColor, +	-- ** to Layer+	addLayer, 	drawLine, 	writeString,+	undoLayer,+	clearLayer,++	-- ** to Character+	addCharacter, 	drawCharacter, 	drawCharacterAndLine, 	clearCharacter, -	undoLayer,-	clearLayer,-	flushLayer,-+	-- * event driven 	onclick, 	onrelease, 	ondrag,-	onkeypress,--	forkIOX,-	addThread+	onkeypress ) 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 Graphics.X11.Turtle.XTools(+	Display, Window, Pixmap, Atom, Point(..), Position, Dimension,+	XEventPtr, XIC, Bufs, undoBuf, bgBuf, topBuf,+	GCs, gcForeground, gcBackground, Event(..),+	forkIOX, openWindow, destroyWindow, closeDisplay, windowSize,+	flush, getColorPixel, setForeground, copyArea, fillRectangle,+	fillPolygon, drawLineXT, writeStringXT,+	allocaXEvent, waitEvent, pending, nextEvent, getEvent, filterEvent,+	utf8LookupString, buttonPress, buttonRelease, xK_VoidSymbol)+import Graphics.X11.Turtle.Layers(+	Layers, Layer, Character, newLayers, redrawLayers,+	makeLayer, addDraw, setBackground, undoLayer, clearLayer,+	makeCharacter, setCharacter)+import Text.XML.YJSVG(Color(..)) -import Control.Monad(replicateM, forM_, forever, replicateM_, when, unless)-import Control.Monad.Tools(doWhile_, whenM, unlessM)+import Control.Monad(forever, replicateM)+import Control.Monad.Tools(doWhile_, doWhile, whenM) import Control.Arrow((***)) import Control.Concurrent(-	forkIO, ThreadId, Chan, newChan, writeChan, readChan, threadWaitRead,-	killThread)+	forkIO, ThreadId, killThread, Chan, newChan, readChan, writeChan) -import System.Posix.Types-import System.Locale.SetLocale-import Foreign.C.Types+import Data.IORef(IORef, newIORef, readIORef, writeIORef, modifyIORef)+import Data.Maybe(fromMaybe)+import Data.Convertible(convert) -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,+	fDisplay :: Display, fWindow :: Window, fBufs :: Bufs, fGCs :: GCs,+	fIC :: XIC, fDel :: Atom, fSize :: IORef (Dimension, Dimension), -	fLayers :: IORef Layers,+	fClick, fRelease :: IORef (Int -> Double -> Double -> IO Bool),+	fDrag :: IORef (Double -> Double -> IO ()),+	fKeypress :: IORef (Char -> IO Bool), fPressed :: IORef Bool, -	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 ()+	fLayers :: IORef Layers, fRunning :: IORef [ThreadId],+	fLock, fClose, 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+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 ()+	keypress <- newIORef $ \_ -> return True+	pressed <- 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,+	[lock, close, end] <- replicateM 3 newChan+	writeChan lock ()+	return Field{+		fDisplay = dpy, fWindow = win, fBufs = bufs, fGCs = gcs,+		fIC = ic, fDel = del, fSize = sizeRef,++		fClick = click, fRelease = release, fDrag = drag,+		fKeypress = keypress, fPressed = pressed,++		fLayers = ls, 		fRunning = running,-		fOnclick = onclickRef,-		fOnrelease = onreleaseRef,-		fOndrag = ondragRef,-		fPress = pressRef,-		fKeypress = keypressRef,-		fEnd = endRef,-		fLayers = fllRef+		fLock = lock, fClose = close, fEnd = end 	 }-	_ <- 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+--------------------------------------------------------------------------------++openField :: IO Field+openField = do+	(dpy, win, bufs, gcs, ic, del, size) <- openWindow+	let	(ub, bb, tb) = (undoBuf bufs, bgBuf bufs, topBuf bufs)+		(gcf, gcb) = (gcForeground gcs, gcBackground gcs)+	sizeRef <- newIORef size+	let getSize = readIORef sizeRef+	ls <- newLayers 50 +		(getSize >>= uncurry (fillRectangle 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+	_ <- forkIOX $ runLoop f+	flush dpy+	return f++waitInput :: Field -> IO (Chan Bool, Chan ())+waitInput f = do+	go <- newChan+	empty <- newChan+	tid <- forkIOX $ forever $ do+		waitEvent $ fDisplay f+		writeChan go True+		readChan empty+	_ <- forkIO $ do+		readChan $ fClose f+		killThread tid+		writeChan go False+	return (go, empty)++runLoop :: Field -> IO ()+runLoop f = allocaXEvent $ \e -> do+	(go, empty) <- waitInput 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-				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+		notEnd <- readChan go+		cont <- doWhile True $ const $ do+			evN <- pending $ fDisplay f+			if evN > 0 then 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 then writeChan empty () >> return True+			else return False+	readIORef (fRunning f) >>= mapM_ killThread 	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+processEvent :: Field -> XEventPtr -> Event -> IO Bool+processEvent f e ev = case ev of+	ExposeEvent{} -> flushField f $ do+		windowSize (fDisplay f) (fWindow f) >>= writeIORef (fSize f)+		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)+		let	buttonN = fromIntegral $ ev_button ev+		case ev_event_type ev of+			et	| et == buttonPress -> do+					writeIORef (fPressed f) True+					readIORef (fClick f) >>=+						($ pos) . uncurry . ($ buttonN)+				| et == buttonRelease -> do+					writeIORef (fPressed f) False+					readIORef (fRelease f) >>=+						($ pos) . uncurry . ($ buttonN)+			_ -> error "not implement event"+	MotionEvent{} -> do+		pos <- center (ev_x ev) (ev_y ev)+		whenM (readIORef $ fPressed f) $+			readIORef (fDrag f) >>= ($ pos) . uncurry+		return True+	ClientMessageEvent{} -> return $ convert (head $ ev_data ev) /= fDel f+	_ -> return True+	where+	center x y = do+		(w, h) <- fieldSize f+		return (fromIntegral x - w / 2, fromIntegral (- y) + h / 2) -onkeypress :: Field -> (Char -> IO Bool) -> IO ()-onkeypress f = writeIORef $ fKeypress f+closeField :: Field -> IO ()+closeField = flip writeChan () . fClose -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+waitField :: Field -> IO ()+waitField = readChan . fEnd -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+fieldSize :: Field -> IO (Double, Double)+fieldSize = fmap (fromIntegral *** fromIntegral) . readIORef . fSize -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+forkField :: Field -> IO () -> IO ThreadId+forkField f act = do+	tid <- forkIOX act+	modifyIORef (fRunning f) (tid :)+	return tid -closeField :: Field -> IO ()-closeField f = do-	readIORef (fRunning f) >>= mapM_ killThread-	writeChan (fClose f) ()-	writeIORef (fClosed f) True+flushField :: Field -> IO a -> IO a+flushField f act = do+	readChan $ fLock f+	ret <- act+	(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 -addThread :: Field -> ThreadId -> IO ()-addThread f tid = modifyIORef (fRunning f) (tid :)+fieldColor :: Field -> Layer -> Color -> IO ()+fieldColor f l c = setBackground l $ do+	clr <- getColorPixel (fDisplay f) c+	(w, h) <- readIORef $ fSize f+	setForeground (fDisplay f) (gcBackground $ fGCs f) clr+	fillRectangle (fDisplay f) (undoBuf $ fBufs f) (gcBackground $ fGCs f) 0 0 w h -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 ()+addLayer = makeLayer . fLayers -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_+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)  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+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 -drawCharacterAndLine ::	Field -> Character -> Color -> [(Double, Double)] -> Double ->+drawLineBuf :: Field -> (Bufs -> Pixmap) -> Int -> Color -> 	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+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 -forkIOX :: IO () -> IO ThreadId-forkIOX = (initThreads >>) . forkIO+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)  -------------------------------------------------------------------------------- -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+addCharacter :: Field -> IO Character+addCharacter = makeCharacter . fLayers -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)+drawCharacter :: Field -> Character -> Color -> [(Double, Double)] -> IO ()+drawCharacter f c clr sh = setCharacter c $ drawShape f clr sh -fieldSize :: Field -> IO (Double, Double)-fieldSize w = fmap (fromIntegral *** fromIntegral) $ winSize w+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 -winSize :: Field -> IO (Dimension, Dimension)-winSize f = do-	width <- readIORef $ fWidth f-	height <- readIORef $ fHeight f-	return (width, height)+drawShape :: Field -> Color -> [(Double, Double)] -> IO ()+drawShape f clr psc = do+	ps <- mapM (fmap (uncurry Point) . uncurry (topLeft f)) psc+	pxl <- getColorPixel (fDisplay f) clr+	setForeground (fDisplay f) (gcForeground $ fGCs f) pxl+	fillPolygon (fDisplay f) (topBuf $ fBufs f) (gcForeground $ fGCs f) ps -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+clearCharacter :: Character -> IO ()+clearCharacter c = setCharacter c $ return () -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+onclick, onrelease :: Field -> (Int -> Double -> Double -> IO Bool) -> IO ()+(onclick, onrelease) = (writeIORef .) *** (writeIORef .) $ (fClick, fRelease) -waitField :: Field -> IO ()-waitField = readChan . fEnd+ondrag :: Field -> (Double -> Double -> IO ()) -> IO ()+ondrag = writeIORef . fDrag -nextNotFilteredEvent :: Display -> XEventPtr -> IO ()-nextNotFilteredEvent dpy e = do-	nextEvent dpy e-	whenM (filterEvent e 0) $ nextNotFilteredEvent dpy e+onkeypress :: Field -> (Char -> IO Bool) -> IO ()+onkeypress = writeIORef . fKeypress
src/Graphics/X11/Turtle/Input.hs view
@@ -1,92 +1,98 @@-module Graphics.X11.Turtle.Input (+module Graphics.X11.Turtle.Input(+	-- * types 	TurtleState, 	TurtleInput(..), -	getTurtleStates,+	-- * get TurtlsStates in timeline+	turtleSeries,++	-- * read TurtleState members 	position,-	pendown,-	undonum,-	visible, 	direction, 	degrees,+	pendown,+	visible,+	undonum, 	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(..)) +import Control.Concurrent.Chan(Chan, newChan, getChanContents)++--------------------------------------------------------------------------------+ data TurtleInput 	= Shape [(Double, Double)]-	| ShapeSize Double+	| Shapesize Double Double+	| Pencolor Color+	| Pensize Double+	| SetPendown Bool+	| SetVisible Bool+	| Degrees Double+	| PositionStep (Maybe Double)+	| DirectionStep (Maybe Double)+	| Undonum Int 	| Goto Double Double 	| Rotate Double-	| Penup-	| Pendown-	| SetVisible Bool+	| Write String Double String+	| Bgcolor Color 	| Undo 	| Clear 	| Forward Double-	| Left Double-	| Undonum Int-	| Pencolor Color-	| Pensize Double-	| Degrees Double-	| Write String Double String+	| TurnLeft Double 	deriving (Show, Read) -getTurtleStates :: IO (Chan TurtleInput, [TurtleInput], [TurtleState])-getTurtleStates = do+turtleSeries :: IO (Chan TurtleInput, [TurtleInput], [TurtleState])+turtleSeries = 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+	x = x0 + len * cos (direction ts0)+	y = y0 + len * sin (direction ts0) 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 (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"++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 (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}+	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 (Bgcolor c) = (clearState t){+	bgcolor = c,+	drawed = init (drawed t) ++ [Fill c]}+nextTurtle t (Clear) = (clearState t){clear = True, drawed = []}+nextTurtle _ _ = error "not defined"++clearState :: TurtleState -> TurtleState+clearState t = t{undonum = 1, undo = False, clear = False, draw = Nothing}
src/Graphics/X11/Turtle/Layers.hs view
@@ -1,76 +1,40 @@ module Graphics.X11.Turtle.Layers(+	-- * types 	Layers, 	Layer, 	Character, 	+	-- * initialize 	newLayers,-	addLayer,-	addCharacter,+	makeLayer,+	makeCharacter, -	addLayerAction,+	-- * draws+	redrawLayers,+	addDraw,+	setBackground, 	undoLayer, 	clearLayer,-	setCharacter,+	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+import Control.Monad(when, unless)+import Data.IORef(IORef, newIORef, readIORef, atomicModifyIORef)+import Data.List.Tools(setAt, modifyAt) -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 (),+	undoLayersAction :: IO (), 	clearCharactersAction :: IO (),-	flush :: IO (),+	background :: [IO ()], 	buffed :: [IO ()], 	layers :: [[(IO (), IO ())]],-	characters :: [IO ()],-	lock :: Chan ()+	characters :: [IO ()]  } -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@@ -81,97 +45,81 @@ 	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 ()]})+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 = [],+	layers = [],+	characters = []+ } -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)+makeLayer :: IORef Layers -> IO Layer+makeLayer rls = atomicModifyIORef rls $ \ls ->+	(ls{layers = layers ls ++ [[]], buffed = buffed ls ++ [return ()],+		background = background ls ++[return ()]},+		Layer{layerId = length $ layers ls, layerLayers = rls}) -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))}+makeCharacter :: IORef Layers -> IO Character+makeCharacter rls = atomicModifyIORef rls $ \ls ->+	(ls{characters = characters ls ++ [return ()]}, Character{+		characterId = length $ characters ls,+		characterLayers = rls}) -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}+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) -clearLayer :: Layer -> IO ()-clearLayer Layer{layerId = lid, layerLayers = rls} = withLock2 $ do-	ls <- readIORef rls-	nls <- clearLayer_ ls lid-	writeIORef rls nls+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) $+			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)} -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}+setBackground :: Layer -> IO () -> IO ()+setBackground Layer{layerId = lid, layerLayers = rls} act = do+	atomicModifyIORef_ rls $ \ls -> ls{background = setAt (background ls) lid act}+	redrawLayers rls -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}+undoLayer :: Layer -> IO Bool+undoLayer Layer{layerId = lid, layerLayers = rls} = do+	done <- atomicModifyIORef rls $ \ls -> if null $ layers ls !! lid+		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)+	return done -addCharacter_ :: Layers -> (Int, Layers)-addCharacter_ ls =-	(length $ characters ls,-		ls{characters = characters ls ++ [return ()]})+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 ()}+	redrawLayers rls  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 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) -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}+atomicModifyIORef_ :: IORef a -> (a -> a) -> IO ()+atomicModifyIORef_ ref f =  atomicModifyIORef ref $ \x -> (f x, ())
src/Graphics/X11/Turtle/Move.hs view
@@ -1,136 +1,109 @@ module Graphics.X11.Turtle.Move (+	-- * types 	Field, 	Layer, 	Character, -	forkIOX,+	-- * process Field 	openField, 	closeField,-	addLayer,-	addCharacter,+	forkField,+	waitField, 	fieldSize,+	fieldColor,++	-- * draws+	flushField,+	moveTurtle,+	addLayer, 	clearLayer,+	addCharacter, 	clearCharacter,-	addThread,-	fieldColor,++	-- * event 	onclick, 	onrelease, 	ondrag,-	onkeypress,-	waitField,-	writeString,---	Color'(..),--	moveTurtle+	onkeypress ) 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+	openField, closeField, waitField, fieldSize,+	forkField, flushField, fieldColor,+	addLayer, drawLine, writeString, undoLayer, clearLayer,+	addCharacter, drawCharacter, drawCharacterAndLine, clearCharacter,+	onclick, onrelease, ondrag, onkeypress)+import Text.XML.YJSVG(SVG(..), Position(..))  import Control.Concurrent(threadDelay) import Control.Monad(when, unless, forM_)+import Control.Monad.Tools(unlessM) 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+import Data.Maybe(isJust) -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 (undo t1) $ flushField f $ 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) $ 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+		forM_ (directions t0 t1) $ \dir -> flushField f $+			drawT dir (position t0) >> threadDelay (interval t0)+		forM_ (positions t0 t1) $ \p -> flushField f $+			drawT (direction t1) p >> threadDelay (interval t0)+		flushField f $ drawT (direction t1) $ position t1+	when (bgcolor t0 /= bgcolor t1) $ flushField f $ do+		fieldColor f l (bgcolor t1)+	unless (undo t1) $ flushField f $ do+		when (visible t0 && not (visible t1)) $ clearCharacter c+		when (clear t1) $ clearLayer l+		maybe (return ()) (drawSVG f l) (draw t1) 	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+	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 -drawDraw :: Field -> Layer -> Maybe SVG -> IO ()-drawDraw _ _ Nothing = return ()-drawDraw f l (Just (Line (Center x0 y0) (Center x1 y1) clr lw)) =+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--- 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)) =+drawSVG f l (Text (Center x y) sz clr fnt str) = 	writeString f l fnt sz clr x y str-{--	where-	[r, g, b] = map ((/ 0xff) . fromIntegral) [r_, g_, b_]--}-drawDraw _ _ _ = error "not implemented"+drawSVG _ _ (Fill _) = return ()+drawSVG _ _ _ = error "not implemented" -getPositions :: Double -> Double -> Double -> Double -> [Pos]-getPositions x0 y0 x1 y1 = take num $ zip [x0, x0 + dx .. ] [y0, y0 + dy .. ]+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 .. ] 	where-	num = floor $ dist / step+	[(x0, y0), (x1, y1)] = map position [t0, t1] 	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]+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-	dd = if de > ds then stepDir else - stepDir+	ds = direction t0+	de = direction t1 -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+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-	rotatePoint (x, y) = let rad = d * 2 * pi in+	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)
src/Graphics/X11/Turtle/Shape.hs view
@@ -6,8 +6,7 @@ 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)- ]+	(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)]
src/Graphics/X11/Turtle/State.hs view
@@ -1,41 +1,48 @@ module Graphics.X11.Turtle.State ( 	TurtleState(..),-	initialTurtleState,+	initialTurtleState ) where -import Text.XML.YJSVG(SVG, Color(RGB))+import Text.XML.YJSVG(SVG(Fill), Color(RGB))  data TurtleState = TurtleState { 	position :: (Double, Double),+	positionStep :: Maybe Double, 	direction :: Double, 	degrees :: Double,+	directionStep :: Maybe Double,+	interval :: Int, 	pendown :: Bool, 	pensize :: Double, 	pencolor :: Color,+	bgcolor :: Color, 	shape :: [(Double, Double)],-	shapesize :: Double,+	shapesize :: (Double, Double), 	visible :: Bool, 	clear :: Bool, 	undo :: Bool, 	undonum :: Int, 	draw :: Maybe SVG,-	drawed :: [SVG]- } deriving Show+	drawed :: [SVG]}+	deriving Show  initialTurtleState :: TurtleState initialTurtleState = TurtleState { 	position = (0, 0),+	positionStep = Just 10, 	direction = 0, 	degrees = 360,+	directionStep = Just $ pi / 18,+	interval = 10000, 	pendown = True, 	pensize = 1, 	pencolor = RGB 0 0 0,+	bgcolor = RGB 255 255 255, 	shape = [],-	shapesize = 1,+	shapesize = (1, 1), 	visible = True, 	clear = False, 	undo = False,-	undonum = 1,+	undonum = 0, 	draw = Nothing,-	drawed = []- }+	drawed = [Fill $ RGB 255 255 255]}
+ src/Graphics/X11/Turtle/XTools.hs view
@@ -0,0 +1,180 @@+module Graphics.X11.Turtle.XTools(+	-- * types+	Display,+	Window,+	Pixmap,+	Atom,+	Point(..),+	Position,+	Dimension,+	XEventPtr,+	XIC,+	Bufs,+	undoBuf,+	bgBuf,+	topBuf,+	GCs,+	gcForeground,+	gcBackground,+	Event(..),++	-- * open window+	forkIOX,+	openWindow,+	destroyWindow,+	closeDisplay,+	windowSize,++	-- * draws+	flush,+	getColorPixel,+	setForeground,+	copyArea,+	fillRectangle,+	fillPolygon,+	drawLineXT,+	writeStringXT,++	-- * event+	allocaXEvent,+	waitEvent,+	pending,+	nextEvent,+	getEvent,+	filterEvent,+	utf8LookupString,+	buttonPress,+	buttonRelease,+	xK_VoidSymbol,+) where++import Text.XML.YJSVG(Color(..))++import Graphics.X11(+	Display, Drawable, Window, Pixmap, Visual, Colormap, GC, Pixel, Atom,+	Point(..), Position, Dimension, XEventPtr,+	initThreads, flush, supportsLocale, setLocaleModifiers,+	connectionNumber, openDisplay, closeDisplay, internAtom,+	createSimpleWindow, destroyWindow, mapWindow, createGC, createPixmap,+	rootWindow, defaultScreen, defaultScreenOfDisplay, defaultVisual,+	defaultColormap, defaultDepth, whitePixel, blackPixel,+	copyArea, fillRectangle, drawLine, nonconvex, coordModeOrigin,+	setLineAttributes, lineSolid, capRound, joinRound, setForeground,+	allocNamedColor, color_pixel,+	allocaXEvent, pending, nextEvent,+	setWMProtocols, selectInput, button1MotionMask, buttonReleaseMask,+	buttonPressMask, keyPressMask, exposureMask,+	buttonPress, buttonRelease, xK_VoidSymbol, getGeometry)+import qualified Graphics.X11 as X(fillPolygon)+import Graphics.X11.Xlib.Extras(Event(..), getEvent)+import Graphics.X11.Xft(+	XftColor, xftDrawCreate, xftFontOpen, withXftColorValue,+	withXftColorName, xftDrawString)+import Graphics.X11.Xrender(XRenderColor(..))+import Graphics.X11.Xim(+	XIC, XNInputStyle(..), openIM, createIC, getICValue, filterEvent,+	utf8LookupString)++import Control.Monad(forM_, replicateM)+import Control.Monad.Tools(unlessM)+import Control.Concurrent(ThreadId, forkIO, threadWaitRead)+import Data.Bits((.|.), shift)+import System.Locale.SetLocale(setLocale, Category(..))+import System.Posix.Types(Fd(..))+import Numeric(showFFloat)++--------------------------------------------------------------------------------++data Bufs = Bufs{+	undoBuf :: Pixmap,+	bgBuf :: Pixmap,+	topBuf :: Pixmap}++data GCs = GCs{+	gcForeground :: GC,+	gcBackground :: GC}++--------------------------------------------------------------------------------++forkIOX :: IO () -> IO ThreadId+forkIOX = (initThreads >>) . forkIO++openWindow :: IO (Display, Window, Bufs, GCs, XIC, Atom, (Dimension, Dimension))+openWindow = do+	_ <- setLocale LC_CTYPE Nothing >>= maybe (error "setLocale") return+	_ <- initThreads+	unlessM supportsLocale $ error "Current locale is not supported."+	_ <- setLocaleModifiers ""+	dpy <- openDisplay ""+	del <- internAtom dpy "WM_DELETE_WINDOW" True+	let	scr = defaultScreen dpy+	root <- rootWindow dpy scr+	(rWidth, rHeight) <- windowSize dpy root+	bufs@[ub, bb, tb] <- replicateM 3 $+		createPixmap dpy root rWidth rHeight $ defaultDepth dpy scr+	win <- createSimpleWindow dpy root 0 0 rWidth rHeight 1+		(blackPixel dpy scr) (whitePixel dpy scr)+	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 $ fevent .|. exposureMask .|. keyPressMask .|.+		buttonPressMask .|. buttonReleaseMask .|. button1MotionMask+	size <- mapWindow dpy win >> windowSize dpy win+	return (dpy, win, Bufs ub bb tb, GCs gc gcBG, ic, del, size)++windowSize :: Display -> Window -> IO (Dimension, Dimension)+windowSize dpy win = do+	(_, _, _, width, height, _, _) <- getGeometry dpy win+	return (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) = fmap (color_pixel . fst) $+	allocNamedColor dpy (defaultColormap dpy $ defaultScreen dpy) cn++fillPolygon :: Display -> Drawable -> GC -> [Point] -> IO ()+fillPolygon d w gc ps = X.fillPolygon d w gc ps nonconvex coordModeOrigin++drawLineXT :: Display -> GC -> Drawable -> Int -> Color ->+	Position -> Position -> Position -> Position -> IO ()+drawLineXT dpy gc bf lw c x1 y1 x2 y2 = do+	getColorPixel dpy c >>= setForeground dpy gc+	setLineAttributes dpy gc (fromIntegral lw) lineSolid capRound joinRound+	drawLine dpy bf gc x1 y1 x2 y2++writeStringXT :: Display -> Drawable -> String -> Double -> Color ->+	Position -> Position -> String -> IO ()+writeStringXT dpy buf fname size clr x y str = do+	let	scrN = defaultScreenOfDisplay dpy+		visual = defaultVisual dpy $ defaultScreen dpy+		colormap = defaultColormap dpy $ defaultScreen dpy+	xftDraw <- xftDrawCreate dpy buf visual colormap+	xftFont <- xftFontOpen dpy scrN $+		fname ++ "-" ++ showFFloat (Just 0) size ""+	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++--------------------------------------------------------------------------------++waitEvent :: Display -> IO ()+waitEvent = threadWaitRead . Fd . connectionNumber
xturtle.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.6  name:		xturtle-version:	0.0.16+version:	0.0.17 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -31,8 +31,8 @@   Hs-source-dirs:	src   Exposed-modules:	Graphics.X11.Turtle   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+    X11-xft <= 3.1, x11-xim, setlocale, yjsvg >= 0.1.13   Ghc-options:		-Wall   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+    Graphics.X11.Turtle.Layers, Graphics.X11.Turtle.XTools