packages feed

xturtle 0.0.12 → 0.0.13

raw patch · 7 files changed

+563/−437 lines, 7 filesdep +X11-xftdep +setlocaledep +x11-xim

Dependencies added: X11-xft, setlocale, x11-xim

Files

src/Graphics/X11/Turtle.hs view
@@ -49,16 +49,18 @@ 	windowWidth, 	windowHeight, 	onclick,+	onkeypress, 	waitField, -	xturtleVersion+	xturtleVersion,+	write ) where  import Graphics.X11.TurtleMove( 	Field, Layer, Character, 	forkIOX, openField, closeField, 	addCharacter, addLayer, fieldSize, clearLayer, clearCharacter,-	addThread, fieldColor, onclick, waitField,+	addThread, fieldColor, onclick, onkeypress, waitField, Color(..), 	moveTurtle  ) import Graphics.X11.TurtleInput(@@ -72,11 +74,10 @@ import Prelude hiding(Left) import Data.IORef(IORef, newIORef, readIORef, modifyIORef) import Data.Bits(shift, (.|.))-import Data.Word(Word8) import Data.Fixed(mod')  xturtleVersion :: (Int, String)-xturtleVersion = (21, "0.0.12")+xturtleVersion = (24, "0.0.13")  data Turtle = Turtle { 	field :: Field,@@ -172,17 +173,14 @@ penup = flip sendCommand Penup pendown = flip sendCommand Pendown -pencolor :: Turtle -> Word8 -> Word8 -> Word8 -> IO ()-pencolor t r_ g_ b_ = sendCommand t $ Pencolor c-	where-	c = shift r 16 .|. shift g 8 .|. b-	[r, g, b] = map fromIntegral [r_, g_, b_]+pencolor :: Turtle -> Double -> Double -> Double -> IO ()+pencolor t r_ g_ b_ = sendCommand t $ Pencolor r_ g_ b_ -- c -bgcolor :: Field -> Word8 -> Word8 -> Word8 -> IO ()-bgcolor f r_ g_ b_ = fieldColor f c+bgcolor :: Field -> Double -> Double -> Double -> IO ()+bgcolor f r_ g_ b_ = fieldColor f $ Color c 	where 	c = shift r 16 .|. shift g 8 .|. b-	[r, g, b] = map fromIntegral [r_, g_, b_]+	[r, g, b] = map (round . (* 255)) [r_, g_, b_]  pensize :: Turtle -> Double -> IO () pensize t = sendCommand t . Pensize@@ -192,6 +190,9 @@  radians :: Turtle -> IO () radians = flip degrees $ 2 * pi++write :: Turtle -> String -> Double -> String -> IO ()+write t fnt sz = sendCommand t . Write fnt sz  undo :: Turtle -> IO () undo t = readIORef (stateIndex t)
+ src/Graphics/X11/TurtleField.hs view
@@ -0,0 +1,470 @@+module Graphics.X11.TurtleField(+	Field,+	Layer,+	Character,++	openField,+	closeField,+	waitField,+	fieldColor,+	fieldSize,++	addLayer,+	addCharacter,++	drawLine,+	drawLineNotFlush,+	writeString,+	drawCharacter,+	drawCharacterAndLine,+	clearCharacter,++	undoLayer,+	clearLayer,+	flushLayer,++	onclick,+	onkeypress,++	forkIOX,+	addThread,++	Color(..)+) 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,++	getGeometry, initThreads, connectionNumber, pending, destroyWindow,++	defaultVisual, defaultColormap, defaultScreenOfDisplay,++	supportsLocale, setLocaleModifiers,+	xK_VoidSymbol+ )+import qualified Graphics.X11 as X (drawLine)+import Graphics.X11.Xlib.Extras(Event(..), getEvent)+import Graphics.X11.Xft+import Graphics.X11.Xrender+import Graphics.X11.Xim++import Data.IORef(IORef, newIORef, readIORef, writeIORef, modifyIORef)+import Data.Bits((.|.))+import Data.Convertible(convert)+import Data.List.Tools(modifyAt, setAt)+import Data.Bool.Tools(whether)+import Data.Maybe++import Control.Monad(replicateM, forM_, forever, replicateM_, when, unless)+import Control.Monad.Tools(doWhile_, whenM, unlessM)+import Control.Arrow((***))+import Control.Concurrent(+	forkIO, ThreadId, Chan, newChan, writeChan, readChan, threadWaitRead,+	killThread)++import System.Posix.Types+import System.Locale.SetLocale+import Foreign.C.Types++data Color = Color {pixel :: Pixel}++colorToPixel :: Color -> Pixel+colorToPixel = pixel++data Field = Field{+	fDisplay :: Display,+	fWindow :: Window,+	fGC :: GC,+	fGCBG :: GC,+	fDel :: Atom,+	fUndoBuf :: Pixmap,+	fBG :: Pixmap,+	fBuf :: Pixmap,+	fWidth :: IORef Dimension,+	fHeight :: IORef Dimension,+	fBuffed :: IORef [IO ()],+	fLayers :: IORef [[Bool -> IO ()]],+	fCharacters :: IORef [IO ()],+	fWait :: Chan (),+	fEvent :: Chan (Maybe Event),+	fClose :: Chan (),+	fClosed :: IORef Bool,+	fRunning :: IORef [ThreadId],+	fOnclick :: IORef (Double -> Double -> IO Bool),+	fKeypress :: IORef (Char -> IO Bool),+	fEnd :: Chan ()+ }++data Layer = Layer{+	layerField :: Field,+	layerId :: Int+ }++data Character = Character{+	characterField :: Field,+	characterId :: Int+ }++openField :: IO Field+openField = do+	setLocale LC_CTYPE Nothing >>= maybe (error "Can't set locale.") print+	_ <- 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 .|. fevent+	mapWindow dpy win+	[widthRef, heightRef] <- mapM newIORef [rWidth, rHeight]+	buffActions <- newIORef []+	layerActions <- newIORef []+	characterActions <- newIORef []+	wait <- newChan+	event <- newChan+	close <- newChan+	closed <- newIORef False+	running <- newIORef []+	onclickRef <- newIORef $ const $ const $ return True+	keypressRef <- newIORef $ const $ return True+	endRef <- newChan+	writeChan wait ()+	let f = Field{+		fDisplay = dpy,+		fWindow = win,+		fGC = gc,+		fGCBG = gcBG,+		fDel = del,+		fUndoBuf = head bufs,+		fBG = bufs !! 1,+		fBuf = bufs !! 2,+		fWidth = widthRef,+		fHeight = heightRef,+		fBuffed = buffActions,+		fLayers = layerActions,+		fCharacters = characterActions,+		fWait = wait,+		fEvent = event,+		fClose = close,+		fClosed = closed,+		fRunning = running,+		fOnclick = onclickRef,+		fKeypress = keypressRef,+		fEnd = endRef+	 }+	_ <- forkIOX $ runLoop ic f+	flushWindow f+	return f++runLoop :: XIC -> Field -> IO ()+runLoop ic f = allocaXEvent $ \e -> do+	endc <- waitInput f+	th1 <- forkIOX $ forever $ do+		evN <- pending $ fDisplay f+		replicateM_ (fromIntegral evN) $ do+			nextNotFilteredEvent (fDisplay f) e+			ev <- getEvent e+			writeChan (fEvent f) $ Just ev+		end <- readChan endc+		when end $ writeChan (fEvent f) Nothing+	(>> (closeDisplay (fDisplay f) >> writeChan (fEnd f) ())) $+		(>> destroyWindow (fDisplay f) (fWindow f)) $ doWhile_ $ do+		mev <- readChan $ fEvent f+		case mev of+			Just (ExposeEvent{}) -> do+				(_, _, _, width, height, _, _) <-+					getGeometry (fDisplay f) (fWindow f)+				writeIORef (fWidth f) width+				writeIORef (fHeight f) height+				redrawAll f+				return True+			Just (KeyEvent{}) -> do+				(mstr, mks) <- utf8LookupString ic e+				let	str = fromMaybe " " mstr+					_ks = fromMaybe xK_VoidSymbol mks+				readIORef (fKeypress f) >>= fmap and . ($ str) . mapM+			Just ev@ButtonEvent{} -> do+				pos <- convertPosRev f (ev_x ev) (ev_y ev)+				readIORef (fOnclick f) >>= ($ pos) . uncurry+			Just ev@ClientMessageEvent{} ->+				return $ convert (head $ ev_data ev) /= fDel f+			Nothing -> killThread th1 >> return False+			_ -> return True++onclick :: Field -> (Double -> Double -> IO Bool) -> IO ()+onclick f = writeIORef $ fOnclick f++onkeypress :: Field -> (Char -> IO Bool) -> IO ()+onkeypress f = writeIORef $ fKeypress f++fieldColor :: Field -> Color -> IO ()+fieldColor f clr = do+	setForeground (fDisplay f) (fGCBG f) $ colorToPixel clr+	let bufs = [fUndoBuf f, fBG f, fBuf f]+	width <- readIORef $ fWidth f+	height <- readIORef $ fHeight f+	forM_ bufs $ \bf -> fillRectangle (fDisplay f) bf (fGCBG f) 0 0 width height+	redrawAll f++getConnection :: Field -> Fd+getConnection = Fd . connectionNumber . fDisplay++waitInput :: Field -> IO (Chan Bool)+waitInput f = do+	c <- newChan+	_ <- forkIOX $ forever $ do+		threadWaitRead $ getConnection f+		writeChan c False+	_ <- forkIO $ do+		readChan $ fClose f+		writeChan c True+	return c++closeField :: Field -> IO ()+closeField f = do+	readIORef (fRunning f) >>= mapM_ killThread+	writeChan (fClose f) ()+	writeIORef (fClosed f) True++addThread :: Field -> ThreadId -> IO ()+addThread f tid = modifyIORef (fRunning f) (tid :)++flushLayer :: Layer -> IO ()+flushLayer = flushWindow . layerField++addLayer :: Field -> IO Layer+addLayer f = do+	ls <- readIORef $ fLayers f+	writeIORef (fLayers f) (ls ++ [[]])+	modifyIORef (fBuffed f) (++ [return ()])+	return Layer{layerField = f, layerId = length ls}++addCharacter :: Field -> IO Character+addCharacter f = do+	cs <- readIORef $ fCharacters f+	writeIORef (fCharacters f) (cs ++ [return ()])+	return Character{characterField = f, characterId = length cs}++runIfOpened :: Field -> IO a -> IO ()+runIfOpened f act = do+	cl <- readIORef $ fClosed f+	unless cl $ act >> return ()++drawLineNotFlush ::+	Layer -> Double -> Color -> Double -> Double -> Double -> Double -> IO ()+drawLineNotFlush l@Layer{layerField = f} lw_ clr x1 y1 x2 y2 = runIfOpened f $ do+	drawLineBuf f lw clr fBG x1 y1 x2 y2+	addLayerAction l $ whether+		(drawLineBuf f lw clr fUndoBuf x1 y1 x2 y2)+		(drawLineBuf f lw clr fBG x1 y1 x2 y2)+	where+	lw = round lw_++drawLine :: Layer -> Double -> Color -> Double -> Double -> Double -> Double -> IO ()+drawLine l@Layer{layerField = f} lw_ clr x1 y1 x2 y2 = runIfOpened f $ do+	drawLineBuf f lw clr fBG x1 y1 x2 y2 >> redrawCharacters f+	addLayerAction l $ whether+		(drawLineBuf f lw clr fUndoBuf x1 y1 x2 y2)+		(drawLineBuf f lw clr fBG x1 y1 x2 y2)+	where+	lw = round lw_++writeString :: Layer -> String -> Double -> Double -> Double -> Double ->+	Double -> Double -> String -> IO ()+writeString l@Layer{layerField = f} fname size r g b x y str = do+	writeStringBuf f fBG fname size r g b x y str+	redrawCharacters f+	addLayerAction l $ whether+		(writeStringBuf f fUndoBuf fname size r g b x y str)+		(writeStringBuf f fBG fname size r g b x y str)++writeStringBuf :: Field -> (Field -> Pixmap) -> String -> Double -> Double -> Double -> Double ->+	Double -> Double -> String -> IO ()+writeStringBuf f buf fname size r g b x_ y_ str = do+	let	dpy = fDisplay f+		scr = defaultScreen dpy+		scrN = defaultScreenOfDisplay dpy+		visual = defaultVisual dpy scr+		colormap = defaultColormap dpy scr+	xftDraw <- xftDrawCreate dpy (buf f) visual colormap+	xftFont <- xftFontOpen dpy scrN $ fname ++ "-" ++ show (round size :: Int) -- "KochiGothic-20"+	[(x, y)] <- convertPos f [(x_, y_)]+	withXftColorValue dpy visual colormap color $ \c ->+		xftDrawString xftDraw c xftFont x y str+	where+	color = XRenderColor {+		xrendercolor_red = round $ r * 0xffff,+		xrendercolor_green = round $ b * 0xffff,+		xrendercolor_blue = round $ g * 0xffff,+		xrendercolor_alpha = 0xffff+	 }++clearCharacter :: Character -> IO ()+clearCharacter c = runIfOpened (characterField c) $+	setCharacter c $ return ()++drawCharacter :: Character -> Color -> [(Double, Double)] -> IO ()+drawCharacter c@Character{characterField = f} clr sh =+	runIfOpened (characterField c) $ setCharacter c $ do+		setForeground (fDisplay f) (fGC f) $ colorToPixel clr+		fillPolygonBuf (characterField c) sh++drawCharacterAndLine ::	Character -> Color -> [(Double, Double)] -> Double ->+	Double -> Double -> Double -> Double -> IO ()+drawCharacterAndLine c@Character{characterField = f} clr ps lw_ x1 y1 x2 y2 =+	runIfOpened f $ setCharacter c $ do+		setForeground (fDisplay f) (fGC f) $ colorToPixel clr+		fillPolygonBuf f ps >> drawLineBuf f lw clr fBuf x1 y1 x2 y2+	where+	lw = round lw_++undoLayer :: Layer -> IO Bool+undoLayer Layer{layerField = f, layerId = lid} = do+	ls <- readIORef $ fLayers f+	if null $ ls !! lid then return False else do+		writeIORef (fLayers f) $ modifyAt ls lid init+		redraw f+		return True++clearLayer :: Layer -> IO ()+clearLayer Layer{layerField = f, layerId = lid} = do+	ls <- readIORef $ fLayers f+	writeIORef (fLayers f) $ setAt ls lid []+	buffed <- readIORef $ fBuffed f+	writeIORef (fBuffed f) $ setAt buffed lid $ return ()+	redrawBuf f+	redraw f++forkIOX :: IO () -> IO ThreadId+forkIOX = (initThreads >>) . forkIO++--------------------------------------------------------------------------------++undoN :: Int+undoN = 100++addLayerAction :: Layer -> (Bool -> IO ()) -> IO ()+addLayerAction Layer{layerField = f, layerId = lid} act = do+	ls <- readIORef $ fLayers f+	if length (ls !! lid) > undoN+		then do	head (ls !! lid) True+			buffed <- readIORef $ fBuffed f+			writeIORef (fBuffed f) $ +				modifyAt buffed lid (>> head (ls !! lid) True)+			writeIORef (fLayers f) $+				modifyAt ls lid $ (++ [act]) . tail+		else writeIORef (fLayers f) $ modifyAt ls lid (++ [act])++setCharacter :: Character -> IO () -> IO ()+setCharacter Character{characterField = f, characterId = cid} act = do+	cs <- readIORef $ fCharacters f+	writeIORef (fCharacters f) $ setAt cs cid act+	redrawCharacters f+	flushWindow f++fillPolygonBuf :: Field -> [(Double, Double)] -> IO ()+fillPolygonBuf f ps_ = do+	ps <- convertPos f ps_+	fillPolygon (fDisplay f) (fBuf f) (fGC f) (map (uncurry Point) ps)+		nonconvex coordModeOrigin++drawLineBuf :: Field -> Int -> Color -> (Field -> Pixmap) ->+	Double -> Double -> Double -> Double -> IO ()+drawLineBuf f@Field{fDisplay = dpy, fGC = gc} lw clr bf x1_ y1_ x2_ y2_ = do+	setForeground (fDisplay f) (fGC f) $ colorToPixel clr+	setLineAttributes (fDisplay f) (fGC f) (fromIntegral lw) lineSolid capRound joinRound+	[(x1, y1), (x2, y2)] <- convertPos f [(x1_, y1_), (x2_, y2_)]+	X.drawLine dpy (bf f) gc x1 y1 x2 y2++convertPos :: Field -> [(Double, Double)] -> IO [(Position, Position)]+convertPos f ps = do+	(width, height) <- fieldSize f+	return $ (round . (+ width / 2) *** round . (+ height / 2) . negate)+		`map` ps++convertPosRev :: Field -> CInt -> CInt -> IO (Double, Double)+convertPosRev f x y = do+	(width, height) <- fieldSize f+	return (fromIntegral x - width / 2, fromIntegral (- y) + height / 2)++fieldSize :: Field -> IO (Double, Double)+fieldSize w = fmap (fromIntegral *** fromIntegral) $ winSize w++winSize :: Field -> IO (Dimension, Dimension)+winSize f = do+	width <- readIORef $ fWidth f+	height <- readIORef $ fHeight f+	return (width, height)++redrawAll :: Field -> IO ()+redrawAll f = do+	redrawBuf f+	redraw f+	flushWindow f++redrawBuf :: Field -> IO ()+redrawBuf f = do+	winSize f >>=+		uncurry (fillRectangle (fDisplay f) (fUndoBuf f) (fGCBG f) 0 0)+	readIORef (fBuffed f) >>= sequence_++redraw :: Field -> IO ()+redraw = withLock $ \f -> do+	(width, height) <- winSize f+	copyArea (fDisplay f) (fUndoBuf f) (fBG f) (fGC f) 0 0 width height 0 0+	readIORef (fLayers f) >>= mapM_ ($ False) . concat+	copyArea (fDisplay f) (fBG f) (fBuf f) (fGC f) 0 0 width height 0 0+	readIORef (fCharacters f) >>= sequence_++redrawCharacters :: Field -> IO ()+redrawCharacters = withLock $ \f -> do+	(width, height) <- winSize f+	copyArea (fDisplay f) (fBG f) (fBuf f) (fGC f) 0 0 width height 0 0+	readIORef (fCharacters f) >>= sequence_++flushWindow :: Field -> IO ()+flushWindow = withLock $ \f -> do+	(width, height) <- winSize f+	copyArea (fDisplay f) (fBuf f) (fWindow f) (fGC f) 0 0 width height 0 0+	flush $ fDisplay f++withLock :: (Field -> IO a) -> Field -> IO a+withLock act f = do+	readChan $ fWait f+	ret <- act f+	writeChan (fWait f) ()+	return ret++waitField :: Field -> IO ()+waitField = readChan . fEnd++nextNotFilteredEvent :: Display -> XEventPtr -> IO ()+nextNotFilteredEvent dpy e = do+	nextEvent dpy e+	whenM (filterEvent e 0) $ nextNotFilteredEvent dpy e
src/Graphics/X11/TurtleInput.hs view
@@ -11,7 +11,8 @@ 	degrees ) where -import Graphics.X11.TurtleState(TurtleState(..), initialTurtleState, Color)+import Graphics.X11.TurtleState(TurtleState(..), initialTurtleState, pencolor,+	Draw(..)) import Control.Concurrent.Chan(Chan, newChan, getChanContents) import Prelude hiding(Left) @@ -34,9 +35,10 @@ 	| Forward Double 	| Left Double 	| Undonum Int-	| Pencolor Color+	| Pencolor Double Double Double 	| Pensize Double 	| Degrees Double+	| Write String Double String 	deriving Show  getTurtleStates :: [(Double, Double)] -> IO (Chan TurtleInput, [TurtleState])@@ -50,24 +52,28 @@ nextTurtle t (Shape sh) = (clearState t){shape = sh} nextTurtle t (ShapeSize ss) = (clearState t){shapesize = ss} nextTurtle t (Goto x y) = (clearState t){position = (x, y), line = pendown t,-	drawed = if pendown t then (pencolor t, pensize t, position t, (x, y))-		: drawed t else drawed t} +	drawed = if pendown t+		then Line (pencolor t) (pensize t) (position t) (x, y) : drawed t else drawed 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 (Pencolor r g b) = (clearState t){red = r, green = g, blue = b}-- setPencolor (clearState t) 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 = Str (red t, green t, blue t) fnt sz (position t) str,+	drawed = Str (red t, green t, blue t) fnt sz (position t) str : drawed t+ } nextTurtle _ _ = error "not defined"  clearState :: TurtleState -> TurtleState-clearState t = t{line = False, undo = False, undonum = 1, clear = False}+clearState t = t{line = False, undo = False, undonum = 1, clear = False, draw = NoDraw}  inputToTurtle :: [TurtleState] -> TurtleState -> [TurtleInput] -> [TurtleState] inputToTurtle [] ts0 (Undo : tis) = ts0 : inputToTurtle [] ts0 tis
src/Graphics/X11/TurtleMove.hs view
@@ -14,20 +14,23 @@ 	addThread, 	fieldColor, 	onclick,+	onkeypress, 	waitField,+	writeString,+	Color(..),  	moveTurtle ) where -import Graphics.X11.TurtleState(TurtleState(..), Color)-import Graphics.X11.WindowLayers(+import Graphics.X11.TurtleState(TurtleState(..), pencolor, Draw(..))+import Graphics.X11.TurtleField( 	Field, Layer, Character, 	forkIOX, openField, closeField, flushLayer, 	addLayer, addCharacter, fieldSize, clearLayer, 	drawLine, drawCharacter, drawCharacterAndLine, undoLayer, 	drawLineNotFlush, 	clearCharacter, addThread,-	fieldColor, onclick, waitField+	fieldColor, onkeypress, onclick, waitField, writeString, Color(..)  )  import Control.Concurrent(threadDelay)@@ -53,34 +56,39 @@  moveTurtle :: Character -> Layer -> TurtleState -> TurtleState -> IO () moveTurtle c l t0 t1 = do-	when (undo t1 && line t0) $ do+	when (undo t1 && (line t0 || draw t0 /= NoDraw)) $ do 		done <- undoLayer l 		unless done $ clearLayer l >> drawLines l (drawed t1) 	when (undo t1 && clear t0) $ drawLines l $ drawed t1 	when (visible t1) $ do 		forM_ (getDirections (dir t0) (dir t1)) $ \d -> do-			drawTurtle c (pencolor t1) (shape t1) (shapesize t1) d+			drawTurtle c (Color $ pencolor t1) (shape t1) (shapesize t1) d 				(pensize t1) p0 Nothing 			threadDelay rotateSpeed 		forM_ (getPositions x0 y0 x1 y1) $ \p -> do-			drawTurtle c (pencolor t1) (shape t1) (shapesize t1)+			drawTurtle c (Color $ pencolor t1) (shape t1) (shapesize t1) 				(dir t1) (pensize t1) p lineOrigin 			threadDelay moveSpeed-		drawTurtle c (pencolor t1) (shape t1) (shapesize t1) (dir t1)+		drawTurtle c (Color $ pencolor t1) (shape t1) (shapesize t1) (dir t1) 			(pensize t1) p1 lineOrigin 	unless (visible t1) $ clearCharacter c 	when (not (undo t1) && line t1) $-		drawLine l (pensize t1) (pencolor t1) x0 y0 x1 y1 >> flushLayer l+		drawLine l (pensize t1) (Color $ pencolor t1) x0 y0 x1 y1 >> flushLayer l 	when (clear t1) $ clearLayer l >> flushLayer l+	unless (undo t1) $ drawDraw l (draw t1) >> flushLayer l 	where 	(tl, to) = if undo t1 then (t0, t1) else (t1, t0) 	lineOrigin = if line tl then Just $ position to else Nothing 	p0@(x0, y0) = position t0 	p1@(x1, y1) = position t1 -drawLines :: Layer -> [(Color, Double, (Double, Double), (Double, Double))] -> IO ()-drawLines l ls =-	mapM_ (\(clr, lw, (x0, y0), (x1, y1)) -> drawLineNotFlush l lw clr x0 y0 x1 y1) $ reverse ls+drawLines :: Layer -> [Draw] -> IO ()+drawLines l = mapM_ (drawDraw l) . reverse++drawDraw :: Layer -> Draw -> IO ()+drawDraw _ NoDraw = return ()+drawDraw l (Line clr lw (x0, y0) (x1, y1)) = drawLineNotFlush l lw (Color clr) x0 y0 x1 y1+drawDraw l (Str (r, g, b) fnt sz (x, y) str) = writeString l fnt sz r g b x y str  getPositions :: Double -> Double -> Double -> Double -> [Pos] getPositions x0 y0 x1 y1 = take num $ zip [x0, x0 + dx .. ] [y0, y0 + dy .. ]
src/Graphics/X11/TurtleState.hs view
@@ -1,20 +1,57 @@ module Graphics.X11.TurtleState ( 	TurtleState(..), 	initialTurtleState,-	Color+	Color,+	pencolor,+	setPencolor,+	Draw(..) ) where  import Data.Word(Word32)+import Data.Bits  type Color = Word32 +data Draw+	= NoDraw+	| Line{+		color :: Color,+		width :: Double,+		begin :: (Double, Double),+		end :: (Double, Double)+	 }+	| Str{+		scolor :: (Double, Double, Double),+		font :: String,+		size :: Double,+		pos :: (Double, Double),+		contents :: String+	 }+	deriving (Show, Eq)++pencolor :: TurtleState -> Word32+pencolor t = c+	where+	c = shift (round $ red t * 0xff) 16 .|.+		shift (round $ green t * 0xff) 8 .|. round (blue t * 0xff)++setPencolor :: TurtleState -> Word32 -> TurtleState+setPencolor t c = t{red = r, green = g, blue = b}+	where+	r_ = shiftR c 16 .&. 0xff+	g_ = shiftR c 8 .&. 0xff+	b_ = c .&. 0xff+	[r, g, b] = map ((/ 0xff) . fromIntegral) [r_, g_, b_]+ data TurtleState = TurtleState { 	position :: (Double, Double), 	direction :: Double, 	degrees :: Double, 	pendown :: Bool, 	pensize :: Double,-	pencolor :: Color,+	red :: Double,+	green :: Double,+	blue :: Double, 	shape :: [(Double, Double)], 	shapesize :: Double, 	visible :: Bool,@@ -22,7 +59,8 @@ 	undo :: Bool, 	line :: Bool, 	undonum :: Int,-	drawed :: [(Color, Double, (Double, Double), (Double, Double))]+	draw :: Draw,+	drawed :: [Draw]  } deriving Show  initialTurtleState :: [(Double, Double)] -> TurtleState@@ -32,7 +70,9 @@ 	degrees = 360, 	pendown = True, 	pensize = 0,-	pencolor = 0x000000,+	red = 0,+	green = 0,+	blue = 0, 	shape = sh, 	shapesize = 1, 	visible = True,@@ -40,5 +80,6 @@ 	undo = False, 	line = False, 	undonum = 1,+	draw = NoDraw, 	drawed = []  }
− src/Graphics/X11/WindowLayers.hs 
@@ -1,401 +0,0 @@-module Graphics.X11.WindowLayers(-	Field,-	Layer,-	Character,--	openField,-	closeField,-	waitField,-	fieldColor,-	fieldSize,--	addLayer,-	addCharacter,--	drawLine,-	drawLineNotFlush,-	drawCharacter,-	drawCharacterAndLine,-	clearCharacter,--	undoLayer,-	clearLayer,-	flushLayer,--	onclick,--	forkIOX,-	addThread-) where--import Graphics.X11(-	Display, Window, Pixmap, Atom, GC, Point(..), Dimension, Position, Pixel,--	setLineAttributes, lineSolid, capRound, joinRound,--	openDisplay, closeDisplay, flush, defaultScreen, rootWindow,-	whitePixel, blackPixel,	defaultDepth,-	createSimpleWindow, mapWindow, createPixmap, internAtom, createGC,--	setForeground, copyArea,-	fillRectangle, fillPolygon, nonconvex, coordModeOrigin,--	setWMProtocols, selectInput, allocaXEvent, nextEvent,-	keyPressMask, exposureMask, buttonPressMask,--	getGeometry, initThreads, connectionNumber, pending, destroyWindow- )-import qualified Graphics.X11 as X (drawLine)-import Graphics.X11.Xlib.Extras(Event(..), getEvent)--import Data.IORef(IORef, newIORef, readIORef, writeIORef, modifyIORef)-import Data.Bits((.|.))-import Data.Convertible(convert)-import Data.List.Tools(modifyAt, setAt)-import Data.Bool.Tools(whether)--import Control.Monad(replicateM, forM_, forever, replicateM_, when)-import Control.Monad.Tools(doWhile_)-import Control.Arrow((***))-import Control.Concurrent(-	forkIO, ThreadId, Chan, newChan, writeChan, readChan, threadWaitRead,-	killThread, threadDelay)--import System.Posix.Types-import Foreign.C.Types--data Field = Field{-	fDisplay :: Display,-	fWindow :: Window,-	fGC :: GC,-	fGCBG :: GC,-	fDel :: Atom,-	fUndoBuf :: Pixmap,-	fBG :: Pixmap,-	fBuf :: Pixmap,-	fWidth :: IORef Dimension,-	fHeight :: IORef Dimension,-	fBuffed :: IORef [IO ()],-	fLayers :: IORef [[Bool -> IO ()]],-	fCharacters :: IORef [IO ()],-	fWait :: Chan (),-	fEvent :: Chan (Maybe Event),-	fClose :: Chan (),-	fClosed :: IORef Bool,-	fRunning :: IORef [ThreadId],-	fOnclick :: IORef (Double -> Double -> IO Bool),-	fEnd :: Chan ()- }--data Layer = Layer{-	layerField :: Field,-	layerId :: Int- }--data Character = Character{-	characterField :: Field,-	characterId :: Int- }--openField :: IO Field-openField = do-	_ <- initThreads-	dpy <- openDisplay ""-	del <- internAtom dpy "WM_DELETE_WINDOW" True-	let	scr = defaultScreen dpy-	root <- rootWindow dpy scr-	(_, _, _, rWidth, rHeight, _, _) <- getGeometry dpy root-	let	black = blackPixel dpy scr-		white = whitePixel dpy scr-		depth = defaultDepth dpy scr-	bufs <- replicateM 3 $ createPixmap dpy root rWidth rHeight depth-	win <- createSimpleWindow dpy root 0 0 rWidth rHeight 1 black white-	[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-	mapWindow dpy win-	[widthRef, heightRef] <- mapM newIORef [rWidth, rHeight]-	buffActions <- newIORef []-	layerActions <- newIORef []-	characterActions <- newIORef []-	wait <- newChan-	event <- newChan-	close <- newChan-	closed <- newIORef False-	running <- newIORef []-	onclickRef <- newIORef $ const $ const $ return True-	endRef <- newChan-	writeChan wait ()-	let f = Field{-		fDisplay = dpy,-		fWindow = win,-		fGC = gc,-		fGCBG = gcBG,-		fDel = del,-		fUndoBuf = head bufs,-		fBG = bufs !! 1,-		fBuf = bufs !! 2,-		fWidth = widthRef,-		fHeight = heightRef,-		fBuffed = buffActions,-		fLayers = layerActions,-		fCharacters = characterActions,-		fWait = wait,-		fEvent = event,-		fClose = close,-		fClosed = closed,-		fRunning = running,-		fOnclick = onclickRef,-		fEnd = endRef-	 }-	_ <- forkIOX $ runLoop f-	flushWindow f-	return f--runLoop :: Field -> IO ()-runLoop f = allocaXEvent $ \e -> do-	endc <- waitInput f-	th1 <- forkIOX $ forever $ do-		evN <- pending $ fDisplay f-		replicateM_ (fromIntegral evN) $ do-			nextEvent (fDisplay f) e-			ev <- getEvent e-			writeChan (fEvent f) $ Just ev-		end <- readChan endc-		when end $ writeChan (fEvent f) Nothing-	(>> (closeDisplay (fDisplay f) >> writeChan (fEnd f) ())) $-		(>> destroyWindow (fDisplay f) (fWindow f)) $ doWhile_ $ do-		mev <- readChan $ fEvent f-		case mev of-			Just (ExposeEvent{}) -> do-				(_, _, _, width, height, _, _) <--					getGeometry (fDisplay f) (fWindow f)-				writeIORef (fWidth f) width-				writeIORef (fHeight f) height-				redrawAll f-				return True-			Just (KeyEvent{}) -> return True-			Just ev@ButtonEvent{} -> do-				pos <- convertPosRev f (ev_x ev) (ev_y ev)-				readIORef (fOnclick f) >>= ($ pos) . uncurry-			Just ev@ClientMessageEvent{} ->-				return $ convert (head $ ev_data ev) /= fDel f-			Nothing -> killThread th1 >> return False-			_ -> return True--onclick :: Field -> (Double -> Double -> IO Bool) -> IO ()-onclick f act = writeIORef (fOnclick f) act--fieldColor :: Field -> Pixel -> IO ()-fieldColor f clr = do-	setForeground (fDisplay f) (fGCBG f) clr-	let bufs = [fUndoBuf f, fBG f, fBuf f]-	width <- readIORef $ fWidth f-	height <- readIORef $ fHeight f-	forM_ bufs $ \bf -> fillRectangle (fDisplay f) bf (fGCBG f) 0 0 width height-	redrawAll f--getConnection :: Field -> Fd-getConnection = Fd . connectionNumber . fDisplay--waitInput :: Field -> IO (Chan Bool)-waitInput f = do-	c <- newChan-	_ <- forkIOX $ forever $ do-		threadWaitRead $ getConnection f-		writeChan c False-	_ <- forkIO $ do-		readChan $ fClose f-		writeChan c True-	return c--closeField :: Field -> IO ()-closeField f = do-	readIORef (fRunning f) >>= mapM_ killThread-	threadDelay 100000-	writeChan (fClose f) ()-	writeIORef (fClosed f) True--addThread :: Field -> ThreadId -> IO ()-addThread f tid = modifyIORef (fRunning f) (tid :)--flushLayer :: Layer -> IO ()-flushLayer = flushWindow . layerField--addLayer :: Field -> IO Layer-addLayer f = do-	ls <- readIORef $ fLayers f-	writeIORef (fLayers f) (ls ++ [[]])-	modifyIORef (fBuffed f) (++ [return ()])-	return Layer{layerField = f, layerId = length ls}--addCharacter :: Field -> IO Character-addCharacter f = do-	cs <- readIORef $ fCharacters f-	writeIORef (fCharacters f) (cs ++ [return ()])-	return Character{characterField = f, characterId = length cs}--runIfOpened :: Field -> IO a -> IO ()-runIfOpened f act = do-	cl <- readIORef $ fClosed f-	if cl then return () else act >> return ()--drawLineNotFlush ::-	Layer -> Double -> Pixel -> Double -> Double -> Double -> Double -> IO ()-drawLineNotFlush l@Layer{layerField = f} lw_ clr x1 y1 x2 y2 = runIfOpened f $ do-	drawLineBuf f lw clr fBG x1 y1 x2 y2-	addLayerAction l $ whether-		(drawLineBuf f lw clr fUndoBuf x1 y1 x2 y2)-		(drawLineBuf f lw clr fBG x1 y1 x2 y2)-	where-	lw = round lw_--drawLine :: Layer -> Double -> Pixel -> Double -> Double -> Double -> Double -> IO ()-drawLine l@Layer{layerField = f} lw_ clr x1 y1 x2 y2 = runIfOpened f $ do-	drawLineBuf f lw clr fBG x1 y1 x2 y2 >> redrawCharacters f-	addLayerAction l $ whether-		(drawLineBuf f lw clr fUndoBuf x1 y1 x2 y2)-		(drawLineBuf f lw clr fBG x1 y1 x2 y2)-	where-	lw = round lw_--clearCharacter :: Character -> IO ()-clearCharacter c = runIfOpened (characterField c) $-	setCharacter c $ return ()--drawCharacter :: Character -> Pixel -> [(Double, Double)] -> IO ()-drawCharacter c@Character{characterField = f} clr sh = do-	runIfOpened (characterField c) $ setCharacter c $ do-		setForeground (fDisplay f) (fGC f) clr-		fillPolygonBuf (characterField c) sh--drawCharacterAndLine ::	Character -> Pixel -> [(Double, Double)] -> Double ->-	Double -> Double -> Double -> Double -> IO ()-drawCharacterAndLine c@Character{characterField = f} clr ps lw_ x1 y1 x2 y2 = do-	runIfOpened f $ setCharacter c $ do-		setForeground (fDisplay f) (fGC f) clr-		fillPolygonBuf f ps >> drawLineBuf f lw clr fBuf x1 y1 x2 y2-	where-	lw = round lw_--undoLayer :: Layer -> IO Bool-undoLayer Layer{layerField = f, layerId = lid} = do-	ls <- readIORef $ fLayers f-	if null $ ls !! lid then return False else do-		writeIORef (fLayers f) $ modifyAt ls lid init-		redraw f-		return True--clearLayer :: Layer -> IO ()-clearLayer Layer{layerField = f, layerId = lid} = do-	ls <- readIORef $ fLayers f-	writeIORef (fLayers f) $ setAt ls lid []-	buffed <- readIORef $ fBuffed f-	writeIORef (fBuffed f) $ setAt buffed lid $ return ()-	redrawBuf f-	redraw f--forkIOX :: IO () -> IO ThreadId-forkIOX = (initThreads >>) . forkIO------------------------------------------------------------------------------------undoN :: Int-undoN = 100--addLayerAction :: Layer -> (Bool -> IO ()) -> IO ()-addLayerAction Layer{layerField = f, layerId = lid} act = do-	ls <- readIORef $ fLayers f-	if length (ls !! lid) > undoN-		then do	head (ls !! lid) True-			buffed <- readIORef $ fBuffed f-			writeIORef (fBuffed f) $ -				modifyAt buffed lid (>> head (ls !! lid) True)-			writeIORef (fLayers f) $-				modifyAt ls lid $ (++ [act]) . tail-		else writeIORef (fLayers f) $ modifyAt ls lid (++ [act])--setCharacter :: Character -> IO () -> IO ()-setCharacter Character{characterField = f, characterId = cid} act = do-	cs <- readIORef $ fCharacters f-	writeIORef (fCharacters f) $ setAt cs cid act-	redrawCharacters f-	flushWindow f--fillPolygonBuf :: Field -> [(Double, Double)] -> IO ()-fillPolygonBuf f ps_ = do-	ps <- convertPos f ps_-	fillPolygon (fDisplay f) (fBuf f) (fGC f) (map (uncurry Point) ps)-		nonconvex coordModeOrigin--drawLineBuf :: Field -> Int -> Pixel -> (Field -> Pixmap) ->-	Double -> Double -> Double -> Double -> IO ()-drawLineBuf f@Field{fDisplay = dpy, fGC = gc} lw clr bf x1_ y1_ x2_ y2_ = do-	setForeground (fDisplay f) (fGC f) clr-	setLineAttributes (fDisplay f) (fGC f) (fromIntegral lw) lineSolid capRound joinRound-	[(x1, y1), (x2, y2)] <- convertPos f [(x1_, y1_), (x2_, y2_)]-	X.drawLine dpy (bf f) gc x1 y1 x2 y2--convertPos :: Field -> [(Double, Double)] -> IO [(Position, Position)]-convertPos f ps = do-	(width, height) <- fieldSize f-	return $ (round . (+ width / 2) *** round . (+ height / 2) . negate)-		`map` ps--convertPosRev :: Field -> CInt -> CInt -> IO (Double, Double)-convertPosRev f x y = do-	(width, height) <- fieldSize f-	return $ (fromIntegral x - width / 2, fromIntegral (- y) + height / 2)--fieldSize :: Field -> IO (Double, Double)-fieldSize w = fmap (fromIntegral *** fromIntegral) $ winSize w--winSize :: Field -> IO (Dimension, Dimension)-winSize f = do-	width <- readIORef $ fWidth f-	height <- readIORef $ fHeight f-	return (width, height)--redrawAll :: Field -> IO ()-redrawAll f = do-	redrawBuf f-	redraw f-	flushWindow f--redrawBuf :: Field -> IO ()-redrawBuf f = do-	winSize f >>=-		uncurry (fillRectangle (fDisplay f) (fUndoBuf f) (fGCBG f) 0 0)-	readIORef (fBuffed f) >>= sequence_--redraw :: Field -> IO ()-redraw = withLock $ \f -> do-	(width, height) <- winSize f-	copyArea (fDisplay f) (fUndoBuf f) (fBG f) (fGC f) 0 0 width height 0 0-	readIORef (fLayers f) >>= mapM_ ($ False) . concat-	copyArea (fDisplay f) (fBG f) (fBuf f) (fGC f) 0 0 width height 0 0-	readIORef (fCharacters f) >>= sequence_--redrawCharacters :: Field -> IO ()-redrawCharacters = withLock $ \f -> do-	(width, height) <- winSize f-	copyArea (fDisplay f) (fBG f) (fBuf f) (fGC f) 0 0 width height 0 0-	readIORef (fCharacters f) >>= sequence_--flushWindow :: Field -> IO ()-flushWindow = withLock $ \f -> do-	(width, height) <- winSize f-	copyArea (fDisplay f) (fBuf f) (fWindow f) (fGC f) 0 0 width height 0 0-	flush $ fDisplay f--withLock :: (Field -> IO a) -> Field -> IO a-withLock act f = do-	readChan $ fWait f-	ret <- act f-	writeChan (fWait f) ()-	return ret--waitField :: Field -> IO ()-waitField = readChan . fEnd
xturtle.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.6  name:		xturtle-version:	0.0.12+version:	0.0.13 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -30,7 +30,8 @@ library   Hs-source-dirs:	src   Exposed-modules:	Graphics.X11.Turtle-  Build-depends:	base > 3 && < 5, yjtools >= 0.9.13, convertible, X11+  Build-depends:	base > 3 && < 5, yjtools >= 0.9.13, convertible, X11,+    X11-xft <= 3.1, x11-xim, setlocale   Ghc-options:		-Wall-  Other-modules:	Graphics.X11.WindowLayers, Graphics.X11.TurtleInput,+  Other-modules:	Graphics.X11.TurtleField, Graphics.X11.TurtleInput,     Graphics.X11.TurtleMove, Graphics.X11.TurtleState, Graphics.X11.TurtleShape