packages feed

xturtle 0.1.9 → 0.1.11

raw patch · 9 files changed

+230/−267 lines, 9 filesdep ~yjtools

Dependency ranges changed: yjtools

Files

src/Graphics/X11/Turtle.hs view
@@ -93,19 +93,19 @@ ) where  import Graphics.X11.Turtle.Data(shapeTable, speedTable)-import Graphics.X11.Turtle.Input(-	TurtleState, TurtleInput(..),-	turtleSeries, direction, visible, undonum, drawed, polyPoints)-import qualified Graphics.X11.Turtle.Input as S(position, degrees, pendown)+import Graphics.X11.Turtle.State(+	TurtleState, direction, visible, undonum, drawed, polyPoints)+import qualified Graphics.X11.Turtle.State as S(position, degrees, pendown)+import Graphics.X11.Turtle.Input(TurtleInput(..), turtleSeries) import Graphics.X11.Turtle.Move(-	Field, Coordinates(..), openField, closeField, fieldSize,-	coordinates, topleft, center, waitField, forkField, flushField,+	Field, Coordinates(..), openField, closeField, waitField,+	topleft, center, coordinates, fieldSize, forkField, flushField, 	addLayer, clearLayer, addCharacter, clearCharacter, moveTurtle, 	onclick, onrelease, ondrag, onmotion, onkeypress, ontimer) import Text.XML.YJSVG(SVG(..), Position(..), Color(..)) import qualified Text.XML.YJSVG as S(center, topleft) -import Control.Concurrent(killThread, writeChan)+import Control.Concurrent(killThread, newChan, writeChan, getChanContents) import Control.Monad(replicateM_, zipWithM_) import Control.Arrow((&&&)) import Data.IORef(IORef, newIORef, readIORef)@@ -115,7 +115,7 @@ --------------------------------------------------------------------------------  xturtleVersion :: (Int, String)-xturtleVersion = (65, "0.1.9")+xturtleVersion = (69, "0.1.11")  -------------------------------------------------------------------------------- @@ -138,7 +138,8 @@ newTurtle :: Field -> IO Turtle newTurtle f = do 	index <- newIORef 1; shapesRef <- newIORef shapeTable-	(chan, hist, states) <- turtleSeries+	chan <- newChan; hist <- getChanContents chan+	let states = turtleSeries hist 	l <- addLayer f; c <- addCharacter f 	thr <- forkField f $ zipWithM_ (moveTurtle f c l) states $ tail states 	let t = Turtle {@@ -326,8 +327,8 @@ isvisible = flip info visible  windowWidth, windowHeight :: Turtle -> IO Double-windowWidth = fmap fst . fieldSize . field-windowHeight = fmap snd . fieldSize . field+windowWidth = fmap fst . windowSize+windowHeight = fmap snd . windowSize  windowSize :: Turtle -> IO (Double, Double) windowSize = fieldSize . field
src/Graphics/X11/Turtle/Data.hs view
@@ -1,7 +1,6 @@ module Graphics.X11.Turtle.Data( 	-- * tables-	shapeTable, speedTable-) where+	shapeTable, speedTable) where  import Control.Arrow(second, (&&&))
src/Graphics/X11/Turtle/Field.hs view
@@ -46,10 +46,10 @@  import Graphics.X11.Turtle.XTools( 	Display, Window, Pixmap, Atom, Point(..), PositionXT, Dimension,-	XEventPtr, XIC, Bufs, undoBuf, bgBuf, topBuf,-	GCs, gcForeground, gcBackground, Event(..),+	XEventPtr, Event(..), XIC, Bufs, undoBuf, bgBuf, topBuf,+	GCs, gcForeground, gcBackground, 	forkIOX, openWindow, destroyWindow, closeDisplay, windowSize,-	flush, copyArea, setForegroundXT,+	flush, setForegroundXT, copyAreaXT, 	drawLineXT, fillRectangleXT, fillPolygonXT, writeStringXT, drawImageXT, 	allocaXEvent, waitEvent, pending, nextEvent, getEvent, filterEvent, 	utf8LookupString, buttonPress, buttonRelease, xK_VoidSymbol)@@ -59,8 +59,8 @@ 	makeCharacter, character) import Text.XML.YJSVG(Position(..), Color(..)) -import Control.Monad(when, unless, forever, replicateM, join)-import Control.Monad.Tools(doWhile_, doWhile, whenM)+import Control.Monad(when, unless, forever, replicateM, forM_, join)+import Control.Monad.Tools(doWhile_, doWhile) import Control.Arrow((***)) import Control.Concurrent( 	ThreadId, forkIO, killThread, threadDelay,@@ -68,7 +68,9 @@ import Data.IORef(IORef, newIORef, readIORef, writeIORef) import Data.IORef.Tools(atomicModifyIORef_) import Data.Maybe(fromMaybe)+import Data.List(delete) import Data.Convertible(convert)+import Data.Function.Tools(const2, const3)  -------------------------------------------------------------------------------- @@ -77,23 +79,24 @@ 	fIC :: XIC, fDel :: Atom, fSize :: IORef (Dimension, Dimension),  	fClick, fRelease :: IORef (Int -> Double -> Double -> IO Bool),-	fDrag, fMotion :: IORef (Double -> Double -> IO ()),-	fKeypress :: IORef (Char -> IO Bool),-	fTimerEvent :: IORef (IO Bool),-	fPressed :: IORef Bool,+	fDrag :: IORef (Int -> Double -> Double -> IO ()),+	fPressed :: IORef [Int],+	fMotion :: IORef (Double -> Double -> IO ()),+	fKeypress :: IORef (Char -> IO Bool), fTimerEvent :: IORef (IO Bool), -	fLayers :: IORef Layers, fInput :: Chan InputType,-	fCoordinates :: IORef Coordinates, fLock, fClose, fEnd :: Chan (),+	fLayers :: IORef Layers, fCoordinates :: IORef Coordinates,+	fInput :: Chan InputType, 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, motion] <- replicateM 2 $ newIORef $ \_ _ -> return ()-	keypress <- newIORef $ \_ -> return True+	[click, release] <- replicateM 2 $ newIORef $ const3 $ return True+	drag <- newIORef $ const3 $ return ()+	pressed <- newIORef []+	motion <- newIORef $ const2 $ return ()+	keypress <- newIORef $ const $ return True 	timer <- newIORef $ return True-	pressed <- newIORef False 	input <- newChan 	coord <- newIORef CoordCenter 	[lock, close, end] <- replicateM 3 newChan@@ -103,37 +106,35 @@ 		fDisplay = dpy, fWindow = win, fBufs = bufs, fGCs = gcs, 		fIC = ic, fDel = del, fSize = sizeRef, -		fClick = click, fRelease = release, fDrag = drag,+		fClick = click, fRelease = release,+		fDrag = drag, fPressed = pressed, 		fMotion = motion, fKeypress = keypress, fTimerEvent = timer,-		fPressed = pressed, -		fLayers = ls, fInput = input, fCoordinates = coord,+		fLayers = ls, fCoordinates = coord, fInput = input, 		fLock = lock, fClose = close, fEnd = end, fRunning = running} -data Coordinates = CoordCenter | CoordTopLeft+setPressed :: Field -> Int -> Bool -> IO ()+setPressed f buttonN True = atomicModifyIORef_ (fPressed f) (buttonN :)+setPressed f buttonN False = atomicModifyIORef_ (fPressed f) (delete buttonN) -coordinates :: Field -> IO Coordinates-coordinates = readIORef . fCoordinates+killRunning :: Field -> IO ()+killRunning f = readIORef (fRunning f) >>= mapM_ killThread -topleft, center :: Field -> IO ()-topleft = flip (writeIORef . fCoordinates) CoordTopLeft-center = flip (writeIORef . fCoordinates) CoordCenter+data Coordinates = CoordCenter | CoordTopLeft  --------------------------------------------------------------------------------  openField :: IO Field openField = do 	(dpy, win, bufs, gcs, ic, del, size) <- openWindow+	sizeRef <- newIORef size 	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 -		(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+	lyrs <- newLayers 50 (setForegroundXT dpy gcb (RGB 255 255 255) >>+		readIORef sizeRef >>= uncurry (fillRectangleXT dpy ub gcb 0 0))+		(readIORef sizeRef >>= uncurry (copyAreaXT dpy ub bb gcf))+		(readIORef sizeRef >>= uncurry (copyAreaXT dpy bb tb gcf))+	f <- makeField dpy win bufs gcs ic del sizeRef lyrs 	_ <- forkIOX $ runLoop f 	flush dpy 	return f@@ -144,14 +145,11 @@ waitInput f = do 	empty <- newChan 	tid <- forkIOX $ forever $ do-		waitEvent $ fDisplay f-		writeChan (fInput f) XInput+		waitEvent (fDisplay f) >> writeChan (fInput f) XInput 		readChan empty 	atomicModifyIORef_ (fRunning f) (tid :)-	_ <- forkIO $ do-		readChan $ fClose f-		killThread tid-		writeChan (fInput f) End+	_ <- forkIO $+		readChan (fClose f) >> killRunning f >> writeChan (fInput f) End 	return empty  runLoop :: Field -> IO ()@@ -159,28 +157,32 @@ 	empty <- waitInput f 	doWhile_ $ do 		iType <- readChan $ fInput f-		cont <- case iType of+		case iType of 			End -> return False 			Timer -> do-				c <- join $ readIORef $ fTimerEvent f-				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)-		if cont then writeChan empty () >> return True else return False-	readIORef (fRunning f) >>= mapM_ killThread+				cont <- join $ readIORef $ fTimerEvent f+				unless cont $ killRunning f+				return cont+			XInput -> do+				cont <- processXInput f e+				when cont $ writeChan empty ()+				return cont 	destroyWindow (fDisplay f) (fWindow f) 	closeDisplay $ fDisplay f 	writeChan (fEnd f) () +processXInput :: Field -> XEventPtr -> IO Bool+processXInput f e = 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 (undefined, True) else do+			ev <- getEvent e+			c <- processEvent f e ev+			unless c $ killRunning f+			return (c && undefined, c)+ processEvent :: Field -> XEventPtr -> Event -> IO Bool processEvent f e ev = case ev of 	ExposeEvent{} -> flushField f True $ do@@ -192,41 +194,51 @@ 			_ks = fromMaybe xK_VoidSymbol mks 		readIORef (fKeypress f) >>= fmap and . ($ str) . mapM 	ButtonEvent{} -> do-		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+		let buttonN = fromIntegral $ ev_button ev+		pos <- getEventXY f ev 		case ev_event_type ev of 			et	| et == buttonPress -> do-					writeIORef (fPressed f) True+					setPressed f buttonN True 					readIORef (fClick f) >>= 						($ pos) . uncurry . ($ buttonN) 				| et == buttonRelease -> do-					writeIORef (fPressed f) False+					setPressed f buttonN False 					readIORef (fRelease f) >>= 						($ pos) . uncurry . ($ buttonN) 			_ -> error "not implement event" 	MotionEvent{} -> do-		pos <- cntr (ev_x ev) (ev_y ev)-		whenM (readIORef $ fPressed f) $-			readIORef (fDrag f) >>= ($ pos) . uncurry+		pos <- getEventXY f ev+		pressed <- readIORef $ fPressed f+		forM_ pressed $ \bn -> readIORef (fDrag f) >>=+			($ pos) . uncurry . ($ bn) 		readIORef (fMotion f) >>= ($ pos) . uncurry 		return True 	ClientMessageEvent{} -> return $ convert (head $ ev_data ev) /= fDel f 	_ -> return True-	where-	cntr x y = do-		(w, h) <- fieldSize f-		return (fromIntegral x - w / 2, fromIntegral (- y) + h / 2) +getEventXY :: Field -> Event -> IO (Double, Double)+getEventXY f ev = do+	let [x, y] = map (fromIntegral . ($ ev)) [ev_x, ev_y]+	coord <- readIORef $ fCoordinates f+	case coord of+		CoordCenter -> do+			(w, h) <- fieldSize f+			return (x - w / 2, h / 2 - y)+		CoordTopLeft -> return (x, y)+ closeField :: Field -> IO () closeField = flip writeChan () . fClose  waitField :: Field -> IO () waitField = readChan . fEnd +topleft, center :: Field -> IO ()+topleft = flip (writeIORef . fCoordinates) CoordTopLeft+center = flip (writeIORef . fCoordinates) CoordCenter++coordinates :: Field -> IO Coordinates+coordinates = readIORef . fCoordinates+ fieldSize :: Field -> IO (Double, Double) fieldSize = fmap (fromIntegral *** fromIntegral) . readIORef . fSize @@ -238,20 +250,19 @@ 	atomicModifyIORef_ (fRunning f) (tid :) >> return tid  flushField :: Field -> Bool -> IO a -> IO a-flushField f real act = do+flushField f@Field{fDisplay = dpy, fWindow = win} real act = do 	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+		let (tb, gc) = (topBuf $ fBufs f, gcForeground $ fGCs f)+		uncurry (copyAreaXT dpy tb win gc) =<< readIORef (fSize f) 		flush $ fDisplay f 	writeChan (fLock f) () >> return ret  fieldColor :: Field -> Layer -> Color -> IO ()-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)+fieldColor f@Field{fDisplay = dpy} l clr = background l $ do+	let (ub, gc) = (undoBuf $ fBufs f, gcBackground $ fGCs f)+	setForegroundXT dpy gc clr+	uncurry (fillRectangleXT dpy ub gc 0 0) =<< readIORef (fSize f)  -------------------------------------------------------------------------------- @@ -259,13 +270,17 @@ addLayer = makeLayer . fLayers  drawLayer :: Field -> Layer -> (Pixmap -> IO ()) -> IO ()-drawLayer Field{fBufs = bufs} l draw =-	addDraw l (draw $ undoBuf bufs, draw $ bgBuf bufs)+drawLayer Field{fBufs = bs} l drw = addDraw l (drw $ undoBuf bs, drw $ bgBuf bs)  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+drawLine f l w c p q = drawLayer f l $ \buf -> drawLineBuf f buf (round w) c p q +drawLineBuf :: Field -> Pixmap -> Int -> Color -> Position -> Position -> IO ()+drawLineBuf f@Field{fDisplay = dpy} buf lw clr p q = do+	(x1, y1) <- getPosition f p+	(x2, y2) <- getPosition f q+	drawLineXT dpy (gcForeground $ fGCs f) buf lw clr x1 y1 x2 y2+ writeString :: Field -> Layer -> String -> Double -> Color -> Position -> 	String -> IO () writeString f@Field{fDisplay = dpy} l fname size clr pos str =@@ -277,24 +292,21 @@ 	(x, y) <- getPosition f pos 	drawImageXT dpy buf (gcForeground $ fGCs f) fp x y (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- 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) -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+fillPolygon :: Field -> Layer -> [Position] -> Color -> IO ()+fillPolygon f l ps clr = drawLayer f l $ \buf -> fillPolygonBuf f buf clr ps +fillPolygonBuf :: Field -> Pixmap -> Color -> [Position] -> IO ()+fillPolygonBuf f@Field{fDisplay = dpy} buf clr positions = do+	ps <- mapM (fmap (uncurry Point) . getPosition f) positions+	setForegroundXT dpy (gcForeground $ fGCs f) clr+	fillPolygonXT dpy buf (gcForeground $ fGCs f) ps+ getPosition :: Field -> Position -> IO (PositionXT, PositionXT) getPosition f (Center x y) = do 	(w, h) <- fieldSize f@@ -307,36 +319,33 @@ addCharacter = makeCharacter . fLayers  drawCharacter :: Field -> Character -> Color -> [Position] -> IO ()-drawCharacter f c clr sh = character c $ drawShape f clr sh+drawCharacter f ch c = character ch . fillPolygonBuf f (topBuf $ fBufs f) c  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 -> [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+drawCharacterAndLine f ch clr sh lw p q = character ch $ do+	fillPolygonBuf f (topBuf $ fBufs f) clr sh+	drawLineBuf f (topBuf $ fBufs f) (round lw) clr p q  clearCharacter :: Character -> IO ()-clearCharacter c = character c $ return ()+clearCharacter ch = character ch $ return ()  --------------------------------------------------------------------------------  onclick, onrelease :: Field -> (Int -> Double -> Double -> IO Bool) -> IO ()-(onclick, onrelease) = (writeIORef . fClick, writeIORef . fRelease)+[onclick, onrelease] = map (writeIORef .) [fClick, fRelease] -ondrag, onmotion :: Field -> (Double -> Double -> IO ()) -> IO ()-(ondrag, onmotion) = (writeIORef . fDrag, writeIORef . fMotion)+ondrag :: Field -> (Int -> Double -> Double -> IO ()) -> IO ()+ondrag = writeIORef . fDrag +onmotion :: Field -> (Double -> Double -> IO ()) -> IO ()+onmotion = writeIORef . fMotion+ onkeypress :: Field -> (Char -> IO Bool) -> IO () onkeypress = writeIORef . fKeypress  ontimer :: Field -> Int -> IO Bool -> IO () ontimer f t fun = do 	writeIORef (fTimerEvent f) fun-	threadDelay $ t * 1000-	writeChan (fInput f) Timer+	_ <- forkIO $ threadDelay (t * 1000) >> writeChan (fInput f) Timer+	return ()
src/Graphics/X11/Turtle/Input.hs view
@@ -1,31 +1,14 @@-module Graphics.X11.Turtle.Input(-	-- * types-	TurtleState,-	TurtleInput(..),--	-- * get TurtlsStates in timeline-	turtleSeries,--	-- * read TurtleState members-	position,-	direction,-	degrees,-	pendown,-	visible,-	undonum,-	drawed,-	polyPoints-) where+module Graphics.X11.Turtle.Input(TurtleInput(..), turtleSeries) where -import Graphics.X11.Turtle.State(TurtleState(..), initialTurtleState, makeShape)+import Graphics.X11.Turtle.State(TurtleState(..), initTurtleState, makeShape) import Text.XML.YJSVG(SVG(..), Color(..), Position(..))-import Control.Concurrent.Chan(Chan, newChan, getChanContents)  --------------------------------------------------------------------------------  data TurtleInput 	= Goto Position 	| Forward Double+	| RotateRad Double 	| Rotate Double 	| TurnLeft Double 	| Dot Double@@ -52,31 +35,29 @@ 	| Degrees Double 	deriving (Show, Read) -turtleSeries :: IO (Chan TurtleInput, [TurtleInput], [TurtleState])-turtleSeries = do-	let	ts0 = initialTurtleState-	c <- newChan-	tis <- getChanContents c-	return (c, tis, ts0 : ts0 : inputToTurtle [] ts0 tis)+turtleSeries :: [TurtleInput] -> [TurtleState]+turtleSeries tis = let ts0 = initTurtleState in ts0 : ts0 : turtles [] ts0 tis -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) = case position ts0 of+turtles :: [TurtleState] -> TurtleState -> [TurtleInput] -> [TurtleState]+turtles [] ts0 (Undo : tis) = ts0 : turtles [] ts0 tis+turtles (tsb : tsbs) _ (Undo : tis) =+	let ts1 = tsb{undo = True} in ts1 : turtles tsbs ts1 tis+turtles 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+		turtles 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"+		turtles tsbs ts0 $ Goto (TopLeft x y) : tis+turtles tsbs ts0 (Rotate dir : tis) = turtles tsbs ts0 $+	RotateRad (dir * 2 * pi / degrees ts0) : tis+turtles tsbs ts0 (TurnLeft dd : tis) = turtles tsbs ts0 $+	RotateRad (direction ts0 + dd * 2 * pi / degrees ts0) : tis+turtles tsbs ts0 (ti : tis) =+	let ts1 = nextTurtle ts0 ti in ts1 : turtles (ts0 : tsbs) ts1 tis+turtles _ _ [] = error "no more input"  reset :: TurtleState -> TurtleState reset t = t{draw = Nothing, clear = False, undo = False, undonum = 1,@@ -91,13 +72,13 @@ 	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 (RotateRad dir) = (reset t){direction = dir}+nextTurtle t@TurtleState{pencolor = clr} (Dot sz) = reset t `set`+	Just (Rect (position t) sz sz 0 clr clr) 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@TurtleState{pencolor = clr} (Write fnt sz str) = reset t `set`+	Just (Text (position t) sz clr 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]}@@ -112,8 +93,8 @@ 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)+	`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}
src/Graphics/X11/Turtle/Layers.hs view
@@ -26,63 +26,48 @@ --------------------------------------------------------------------------------  data Layers = Layers{-	backgrounds :: [IO ()],-	buffers :: [IO ()],-	layers :: [[(IO (), IO ())]],-	characters :: [IO ()],-	buffSize :: Int,-	clearBuffers :: IO (),-	clearLayers :: IO (),-	clearCharacters :: IO ()}--data Layer = Layer{-	layerId :: Int,-	layerLayers :: IORef Layers- }+	bgs :: [IO ()], buffs :: [IO ()], layers :: [[(IO (), IO ())]],+	chars :: [IO ()], buffSize :: Int,+	clearBuffers :: IO (), clearLayers :: IO (), clearCharacters :: IO ()} -data Character = Character{-	characterId :: Int,-	characterLayers :: IORef Layers- }+data Layer = Layer{layerId :: Int, layerLayers :: IORef Layers}+data Character = Character{charId :: Int, charLayers :: IORef Layers}  --------------------------------------------------------------------------------  newLayers :: Int -> IO () -> IO () -> IO () -> IO (IORef Layers) newLayers bsize cbuf clyr cchr = newIORef Layers{-	backgrounds = [],-	buffers = [],-	layers = [],-	characters = [],-	buffSize = bsize,-	clearBuffers = cbuf,-	clearLayers = clyr,-	clearCharacters = cchr}+	bgs = [], buffs = [], layers = [], chars = [], buffSize = bsize,+	clearBuffers = cbuf, clearLayers = clyr, clearCharacters = cchr}  makeLayer :: IORef Layers -> IO Layer makeLayer rls = atomicModifyIORef rls $ \ls -> (ls{-		backgrounds = backgrounds ls ++[return ()],-		buffers = buffers ls ++ [return ()],+		bgs = bgs ls ++[return ()], buffs = buffs ls ++ [return ()], 		layers = layers ls ++ [[]]}, 	Layer{layerId = length $ layers ls, layerLayers = rls})  makeCharacter :: IORef Layers -> IO Character-makeCharacter rls = atomicModifyIORef rls $ \ls ->-	(ls{characters = characters ls ++ [return ()]}, Character{-		characterId = length $ characters ls,-		characterLayers = rls})+makeCharacter rls = atomicModifyIORef rls $ \ls -> (ls{+		chars = chars ls ++ [return ()]},+	Character{charId = length $ chars ls, charLayers = rls})  --------------------------------------------------------------------------------  redrawLayers :: IORef Layers -> IO () redrawLayers rls = readIORef rls >>= \ls -> do-	clearBuffers ls >> sequence_ (backgrounds ls) >> sequence_ (buffers ls)+	clearBuffers ls >> sequence_ (bgs ls) >> sequence_ (buffs ls) 	clearLayers ls >> mapM_ snd (concat $ layers ls)-	clearCharacters ls >> sequence_ (characters ls)+	clearCharacters ls >> sequence_ (chars ls) +background :: Layer -> IO () -> IO ()+background Layer{layerId = lid, layerLayers = rls} act =+	atomicModifyIORef_ rls (\ls -> ls{bgs = setAt (bgs ls) lid act})+		>> redrawLayers rls+ addDraw :: Layer -> (IO (), IO ()) -> IO () addDraw Layer{layerId = lid, layerLayers = rls} acts@(_, act) = do 	readIORef rls >>= \ls -> do-		act >> clearCharacters ls >> sequence_ (characters ls)+		act >> clearCharacters ls >> sequence_ (chars ls) 		unless (length (layers ls !! lid) < buffSize ls) $ 			fst $ head $ layers ls !! lid 	atomicModifyIORef_ rls $ \ls ->@@ -90,13 +75,7 @@ 			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)}--background :: Layer -> IO () -> IO ()-background Layer{layerId = lid, layerLayers = rls} act = do-	atomicModifyIORef_ rls $ \ls ->-		ls{backgrounds = setAt (backgrounds ls) lid act}-	redrawLayers rls+				buffs = modifyAt (buffs ls) lid (>> a)}  undoLayer :: Layer -> IO Bool undoLayer Layer{layerId = lid, layerLayers = rls} = do@@ -105,20 +84,17 @@ 		else (ls{layers = modifyAt (layers ls) lid init}, True) 	when done $ readIORef rls >>= \ls -> do 		clearLayers ls >> mapM_ snd (concat $ layers ls)-		clearCharacters ls >> sequence_ (characters ls)+		clearCharacters ls >> sequence_ (chars ls) 	return done  clearLayer :: Layer -> IO ()-clearLayer Layer{layerId = lid, layerLayers = rls} = do-	atomicModifyIORef_ rls $ \ls -> ls{-		backgrounds = setAt (backgrounds ls) lid $ return (),-		buffers = setAt (buffers ls) lid $ return (),-		layers = setAt (layers ls) lid []}-	redrawLayers rls+clearLayer Layer{layerId = lid, layerLayers = rls} =+	atomicModifyIORef_ rls (\ls -> ls{+		bgs = setAt (bgs ls) lid $ return (),+		buffs = setAt (buffs ls) lid $ return (),+		layers = setAt (layers ls) lid []}) >> redrawLayers rls  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 ->-		clearCharacters ls >> sequence_ (characters ls)+character Character{charId = cid, charLayers = rls} act = do+	atomicModifyIORef_ rls $ \ls -> ls{chars = setAt (chars ls) cid act}+	readIORef rls >>= \ls -> clearCharacters ls >> sequence_ (chars ls)
src/Graphics/X11/Turtle/Move.hs view
@@ -6,11 +6,11 @@ 	-- * process Field 	openField, 	closeField,-	fieldSize,-	coordinates,+	waitField, 	topleft, 	center,-	waitField,+	coordinates,+	fieldSize,  	-- * draws 	forkField,@@ -33,9 +33,9 @@ import Graphics.X11.Turtle.State(TurtleState(..), makeShape) import Graphics.X11.Turtle.Field( 	Field, Layer, Character, Coordinates(..),-	openField, closeField, fieldSize, coordinates, topleft, center,-	waitField, forkField, flushField,-	addLayer, clearLayer, addCharacter, clearCharacter,+	openField, closeField, waitField, coordinates, topleft, center,+	fieldSize, forkField, flushField, addLayer, clearLayer,+	addCharacter, clearCharacter, 	onclick, onrelease, ondrag, onmotion, onkeypress, ontimer, 	fieldColor, drawLine, fillRectangle, fillPolygon, writeString, 	drawImage, undoLayer, drawCharacter, drawCharacterAndLine)
src/Graphics/X11/Turtle/State.hs view
@@ -1,9 +1,9 @@ module Graphics.X11.Turtle.State(-	TurtleState(..), initialTurtleState, makeShape) where+	TurtleState(..), initTurtleState, makeShape) where  import Text.XML.YJSVG(Position(..), SVG(Fill), Color(RGB))-import Control.Arrow((***)) import Data.Tuple.Tools(rotate)+import Control.Arrow((***))  data TurtleState = TurtleState { 	position :: Position,@@ -33,8 +33,8 @@ 	directionStep :: Maybe Double, 	interval :: Int} -initialTurtleState :: TurtleState-initialTurtleState = TurtleState {+initTurtleState :: TurtleState+initTurtleState = TurtleState { 	position = Center 0 0, 	direction = 0, 	degrees = 360,
src/Graphics/X11/Turtle/XTools.hs view
@@ -30,7 +30,7 @@ 	-- * draw functions 	flush, 	setForegroundXT,-	copyArea,+	copyAreaXT, 	fillRectangleXT, 	fillPolygonXT, 	drawLineXT,@@ -50,8 +50,6 @@ 	xK_VoidSymbol, ) where -import Text.XML.YJSVG(Color(..))- import Graphics.X11( 	Display, Drawable, Window, Pixmap, GC, Atom, Point(..), Position, 	Dimension, XEventPtr,@@ -79,7 +77,7 @@ import Graphics.Imlib( 	ImlibLoadError(..), loadImageWithErrorReturn, contextSetImage, 	imageGetWidth, imageGetHeight, imageGetData, createCroppedScaledImage)-+import Text.XML.YJSVG(Color(..)) import Numeric(showFFloat) import Control.Monad(forM_, replicateM) import Control.Monad.Tools(unlessM)@@ -88,8 +86,7 @@ import System.Posix.Types(Fd(..)) import Data.Word(Word32) import Data.Bits((.|.), shift)-import Data.IORef(newIORef, readIORef)-import Data.IORef.Tools(atomicModifyIORef_)+import Data.IORef(newIORef, readIORef, modifyIORef) import Foreign.Ptr(Ptr) import Foreign.Storable(peek) import Foreign.Marshal.Array(advancePtr)@@ -103,7 +100,7 @@ --------------------------------------------------------------------------------  forkIOX :: IO () -> IO ThreadId-forkIOX = (initThreads >>) . forkIO+forkIOX = forkIO . (initThreads >>)  openWindow :: IO (Display, Window, Bufs, GCs, XIC, Atom, (Dimension, Dimension)) openWindow = do@@ -113,7 +110,7 @@ 	_ <- setLocaleModifiers "" 	dpy <- openDisplay "" 	del <- internAtom dpy "WM_DELETE_WINDOW" True-	let	scr = defaultScreen dpy+	let scr = defaultScreen dpy 	root <- rootWindow dpy scr 	(rWidth, rHeight) <- windowSize dpy root 	bufs@[ub, bb, tb] <- replicateM 3 $@@ -140,16 +137,20 @@ --------------------------------------------------------------------------------  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")+setForegroundXT dpy gc (RGB r_ g_ b_) = let+	[r, g, b] = map fromIntegral [r_, g_, b_] in+	setForeground dpy gc $ shift r 16 .|. shift g 8 .|. b+setForegroundXT dpy gc (ColorName cn) = let+	cm = defaultColormap dpy $ defaultScreen dpy in+	(allocNamedColor dpy cm cn >>= setForeground dpy gc . color_pixel . fst)+		`catch` const (putStrLn "no such color") -fillRectangleXT :: Display -> Drawable -> GC ->-	Position -> Position -> Dimension -> Dimension -> IO ()+copyAreaXT :: Display -> Drawable -> Drawable -> GC ->+	Dimension -> Dimension -> IO ()+copyAreaXT dpy src dst gc w h = copyArea dpy src dst gc 0 0 w h 0 0++fillRectangleXT :: Display -> Drawable -> GC -> Position -> Position ->+	Dimension -> Dimension -> IO () fillRectangleXT = fillRectangle  fillPolygonXT :: Display -> Drawable -> GC -> [Point] -> IO ()@@ -165,22 +166,19 @@ writeStringXT :: Display -> Drawable -> String -> Double -> Color -> 	Position -> Position -> String -> IO () writeStringXT dpy buf fname size clr x y str = do-	let	visual = defaultVisual dpy $ defaultScreen dpy-		colormap = defaultColormap dpy $ defaultScreen dpy-		font = fname ++ "-" ++ showFFloat (Just 0) size ""-	xftDraw <- xftDrawCreate dpy buf visual colormap-	xftFont <- xftFontOpen dpy (defaultScreenOfDisplay dpy) font-	case clr of-		RGB r g b -> withXftColorValue dpy visual colormap color $ \c ->-			xftDrawString xftDraw c xftFont x y str-			where-			color = XRenderColor {+	let	vsl = defaultVisual dpy $ defaultScreen dpy+		cm = defaultColormap dpy $ defaultScreen dpy+		withColor = case clr of+			RGB r g b -> withXftColorValue dpy vsl cm XRenderColor{ 				xrendercolor_red = fromIntegral r * 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+			ColorName cn -> withXftColorName dpy vsl cm cn+	draw <- xftDrawCreate dpy buf vsl cm+	font <- xftFontOpen dpy (defaultScreenOfDisplay dpy) $+		fname ++ "-" ++ showFFloat (Just 0) size ""+	withColor $ \c -> xftDrawString draw c font x y str 			 drawImageXT :: Display -> Drawable -> GC -> FilePath -> Position -> Position -> 	Dimension -> Dimension -> IO ()@@ -193,22 +191,21 @@ 	case err of 		ImlibLoadErrorNone -> do 			contextSetImage img-			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 		_ -> print err >> return Nothing+	where zero = 0 :: Position -drawBitmap :: Display -> Drawable -> GC -> Position -> Position -> Dimension ->-	Dimension -> Ptr Word32 -> IO ()-drawBitmap dpy win gc x0 y0 w_ h_ dat = do-	ptr <- newIORef dat+drawBitmap :: Display -> Drawable -> GC -> Position -> Position ->+	Dimension -> Dimension -> Ptr Word32 -> IO ()+drawBitmap dpy win gc x y w_ h_ dat = newIORef dat >>= \ptr -> 	forM_ [0 .. w * h - 1]  $ \i -> do 		readIORef ptr >>= peek >>= setForeground dpy gc-		drawPoint dpy win gc (x0 + i `mod` w) (y0 + i `div` w)-		atomicModifyIORef_ ptr $ flip advancePtr 1+		drawPoint dpy win gc (x + i `mod` w) (y + i `div` w)+		modifyIORef 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.9+version:	0.1.11 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -30,7 +30,7 @@ library   Hs-source-dirs:	src   Exposed-modules:	Graphics.X11.Turtle-  Build-depends:	base > 3 && < 5, yjtools >= 0.9.15, convertible >= 1.0.8, X11,+  Build-depends:	base > 3 && < 5, yjtools >= 0.9.16, 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,