packages feed

xturtle 0.1.5 → 0.1.6

raw patch · 7 files changed

+189/−138 lines, 7 files

Files

src/Graphics/X11/Turtle.hs view
@@ -28,6 +28,8 @@ 	setheading, 	circle, 	write,+	stamp,+	dot, 	image, 	bgcolor, 	home,@@ -75,6 +77,7 @@ 	ondrag, 	onmotion, 	onkeypress,+	ontimer,  	-- * save and load 	getInputs,@@ -82,7 +85,7 @@ 	getSVG ) where -import Graphics.X11.Turtle.Data(nameToShape, nameToSpeed)+import Graphics.X11.Turtle.Data(shapeTable, speedTable) import Graphics.X11.Turtle.Input( 	TurtleState, TurtleInput(..), 	turtleSeries, direction, visible, undonum, drawed, polyPoints)@@ -91,7 +94,7 @@ 	Field, Layer, Character, 	openField, closeField, forkField, waitField, fieldSize, flushField, 	moveTurtle, addLayer, clearLayer, addCharacter, clearCharacter,-	onclick, onrelease, ondrag, onmotion, onkeypress)+	onclick, onrelease, ondrag, onmotion, onkeypress, ontimer) import Text.XML.YJSVG(SVG(..), Color(..))  import Control.Concurrent(Chan, writeChan, ThreadId, killThread)@@ -104,7 +107,7 @@ --------------------------------------------------------------------------------  xturtleVersion :: (Int, String)-xturtleVersion = (53, "0.1.5")+xturtleVersion = (56, "0.1.6")  -------------------------------------------------------------------------------- @@ -137,7 +140,7 @@ 	(ic, tis, sts) <- turtleSeries 	si <- newIORef 1 	tid <- forkField f $ zipWithM_ (moveTurtle f ch l) sts $ tail sts-	shps <- newIORef $ map (\n -> (n, nameToShape n)) ["classic", "turtle"]+	shps <- newIORef shapeTable 	let	t = Turtle { 			field = f, 			layer = l,@@ -195,6 +198,12 @@ write :: Turtle -> String -> Double -> String -> IO () write t fnt sz = input t . Write fnt sz +stamp :: Turtle -> IO ()+stamp = (`input` Stamp)++dot :: Turtle -> Double -> IO ()+dot t = input t . Dot+ image :: Turtle -> FilePath -> Double -> Double -> IO () image t fp w h = input t $ PutImage fp w h @@ -236,7 +245,7 @@ shapesize t sx sy = input t $ Shapesize sx sy  speed :: Turtle -> String -> IO ()-speed t str = case nameToSpeed str of+speed t str = case lookup str speedTable of 	Just (ps, ds) -> input t (PositionStep ps) >> input t (DirectionStep ds) 	Nothing -> putStrLn "no such speed"
src/Graphics/X11/Turtle/Data.hs view
@@ -1,19 +1,17 @@-module Graphics.X11.Turtle.Data(nameToShape, nameToSpeed) where+module Graphics.X11.Turtle.Data(+	-- * tables+	shapeTable, speedTable+) where  import Control.Arrow(second, (&&&)) -nameToShape :: String -> [(Double, Double)]-nameToShape "classic" = unfold [(- 10, 0), (- 16, 6), (0, 0)]-nameToShape "turtle" = unfold [-	(- 10, 0), (- 8, 3), (- 10, 5), (- 7, 9), (- 5, 6), (0, 8), (4, 7),-	(6, 10), (8, 7), (7, 5), (10, 2), (13, 3), (16, 0)]-nameToShape name = error $ "There is no shape named " ++ name--unfold :: [(Double, Double)] -> [(Double, Double)]-unfold = uncurry (++) . (id &&& (reverse . map (second negate)))--nameToSpeed :: String -> Maybe (Maybe Double, Maybe Double)-nameToSpeed str = lookup str speedTable+shapeTable :: [(String, [(Double, Double)])]+shapeTable = [+	("classic", unfold [(- 10, 0), (- 16, 6), (0, 0)]),+	("turtle", unfold [+		(- 10, 0), (- 8, 3), (- 10, 5), (- 7, 9), (- 5, 6), (0, 8),+		(4, 7), (6, 10), (8, 7), (7, 5), (10, 2), (13, 3), (16, 0)])]+	where unfold = uncurry (++) . (id &&& (reverse . map (second negate)))  speedTable :: [(String, (Maybe Double, Maybe Double))] speedTable = [@@ -21,5 +19,4 @@ 	("fast", (Just 60, Just $ pi / 3)), 	("normal", (Just 20, Just $ pi / 9)), 	("slow", (Just 10, Just $ pi / 18)),-	("slowest", (Just 3, Just $ pi / 60))- ]+	("slowest", (Just 3, Just $ pi / 60))]
src/Graphics/X11/Turtle/Field.hs view
@@ -19,6 +19,7 @@ 	addLayer, 	drawLine, 	fillPolygon,+	fillRectangle, 	writeString, 	drawImage, 	undoLayer,@@ -35,7 +36,8 @@ 	onrelease, 	ondrag, 	onmotion,-	onkeypress+	onkeypress,+	ontimer ) where  import Graphics.X11.Turtle.XTools(@@ -43,22 +45,23 @@ 	XEventPtr, XIC, Bufs, undoBuf, bgBuf, topBuf, 	GCs, gcForeground, gcBackground, Event(..), 	forkIOX, openWindow, destroyWindow, closeDisplay, windowSize,-	flush, getColorPixel, setForeground, copyArea, fillRectangle,+	flush, colorPixel, setForeground, copyArea, 	drawLineXT, writeStringXT, 	allocaXEvent, waitEvent, pending, nextEvent, getEvent, filterEvent, 	utf8LookupString, buttonPress, buttonRelease, xK_VoidSymbol)-import qualified Graphics.X11.Turtle.XTools as X(fillPolygon, drawImage)+import qualified Graphics.X11.Turtle.XTools as X(fillPolygonXT, drawImageXT,+	fillRectangle) import Graphics.X11.Turtle.Layers( 	Layers, Layer, Character, newLayers, redrawLayers, 	makeLayer, addDraw, setBackground, undoLayer, clearLayer, 	makeCharacter, setCharacter) import Text.XML.YJSVG(Color(..)) -import Control.Monad(forever, replicateM, when)+import Control.Monad(forever, replicateM, when, join, unless) import Control.Monad.Tools(doWhile_, doWhile, whenM) import Control.Arrow((***)) import Control.Concurrent(-	forkIO, ThreadId, killThread, Chan, newChan, readChan, writeChan)+	forkIO, ThreadId, killThread, Chan, newChan, readChan, writeChan, threadDelay)  import Data.IORef(IORef, newIORef, readIORef, writeIORef, modifyIORef) import Data.Maybe(fromMaybe)@@ -74,9 +77,11 @@ 	fDrag :: IORef (Double -> Double -> IO ()), 	fMotion :: IORef (Double -> Double -> IO ()), 	fKeypress :: IORef (Char -> IO Bool), fPressed :: IORef Bool,+	fTimerEvent :: IORef (IO Bool),  	fLayers :: IORef Layers, fRunning :: IORef [ThreadId],-	fLock, fClose, fEnd :: Chan ()+	fLock, fClose, fEnd :: Chan (),+	fInputChan :: Chan InputType  }  makeField :: Display -> Window -> Bufs -> GCs -> XIC -> Atom ->@@ -87,19 +92,21 @@ 	motion <- newIORef $ \_ _ -> return () 	keypress <- newIORef $ \_ -> return True 	pressed <- newIORef False+	timer <- newIORef $ return True 	running <- newIORef [] 	[lock, close, end] <- replicateM 3 newChan+	inputChan <- 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, fMotion = motion,-		fKeypress = keypress, fPressed = pressed,+		fKeypress = keypress, fPressed = pressed, fTimerEvent = timer,  		fLayers = ls, 		fRunning = running,-		fLock = lock, fClose = close, fEnd = end+		fLock = lock, fClose = close, fEnd = end, fInputChan = inputChan 	 }  --------------------------------------------------------------------------------@@ -112,7 +119,7 @@ 	sizeRef <- newIORef size 	let getSize = readIORef sizeRef 	ls <- newLayers 50 -		(getSize >>= uncurry (fillRectangle dpy ub gcb 0 0))+		(getSize >>= uncurry (X.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@@ -120,25 +127,38 @@ 	flush dpy 	return f -waitInput :: Field -> IO (Chan Bool, Chan ())+data InputType = XInput | End | Timer++waitInput :: Field -> IO (Chan InputType, Chan ()) waitInput f = do-	go <- newChan+--	go <- newChan+	let	go = fInputChan f 	empty <- newChan 	tid <- forkIOX $ forever $ do 		waitEvent $ fDisplay f-		writeChan go True+		writeChan go XInput 		readChan empty+	modifyIORef (fRunning f) (tid :) 	_ <- forkIO $ do 		readChan $ fClose f 		killThread tid-		writeChan go False+		writeChan go End 	return (go, empty)  runLoop :: Field -> IO () runLoop f = allocaXEvent $ \e -> do 	(go, empty) <- waitInput f 	doWhile_ $ do-		notEnd <- readChan go+		iType <- readChan go+		cont' <- case iType of+			Timer -> do+				c <- join $ readIORef $ fTimerEvent f+				unless c $ readIORef (fRunning f) >>= mapM_ killThread+				return c -- readIORef (fTimerEvent f) >>= k+			_ -> return True+		let	notEnd = case iType of+				End -> False+				_ -> True 		cont <- doWhile True $ const $ do 			evN <- pending $ fDisplay f 			if evN > 0 then do@@ -149,7 +169,7 @@ 							c <- processEvent f e ev 							return (c, c) 				else return (True, False)-		if notEnd && cont then writeChan empty () >> return True+		if notEnd && cont && cont' then writeChan empty () >> return True 			else return False 	readIORef (fRunning f) >>= mapM_ killThread 	destroyWindow (fDisplay f) (fWindow f)@@ -224,10 +244,10 @@  fieldColor :: Field -> Layer -> Color -> IO () fieldColor f l c = setBackground l $ do-	getColorPixel (fDisplay f) c >>=+	colorPixel (fDisplay f) c >>= 		maybe (return ()) 			(setForeground (fDisplay f) (gcBackground $ fGCs f))-	readIORef (fSize f) >>= uncurry (fillRectangle+	readIORef (fSize f) >>= uncurry (X.fillRectangle 		(fDisplay f) (undoBuf $ fBufs f) (gcBackground $ fGCs f) 0 0)  --------------------------------------------------------------------------------@@ -252,17 +272,27 @@ drawImage f l fp xc yc w h = addDraw l (di undoBuf, di bgBuf) 	where di bf = do 		(x, y) <- topLeft f xc yc-		X.drawImage (fDisplay f) (bf $ fBufs f) (gcForeground $ fGCs f)+		X.drawImageXT (fDisplay f) (bf $ fBufs f) (gcForeground $ fGCs f) 			fp x y (round w) (round h)  fillPolygon :: Field -> Layer -> [(Double, Double)] -> Color -> IO () fillPolygon f l psc clr = addDraw l (fp undoBuf, fp bgBuf) 	where fp bf = do 		ps <- mapM (fmap (uncurry Point) . uncurry (topLeft f)) psc-		getColorPixel (fDisplay f) clr >>= maybe (return ())+		colorPixel (fDisplay f) clr >>= maybe (return ()) 			(setForeground (fDisplay f) (gcForeground $ fGCs f))-		X.fillPolygon (fDisplay f) (bf $ fBufs f) (gcForeground $ fGCs f) ps+		X.fillPolygonXT (fDisplay f) (bf $ fBufs f) (gcForeground $ fGCs f) ps +fillRectangle ::+	Field -> Layer -> Double -> Double -> Double -> Double -> Color -> IO ()+fillRectangle f l xc0 yc0 w h clr = addDraw l (fr undoBuf, fr bgBuf)+	where fr bf = do+		(x0, y0) <- topLeft f xc0 yc0+		colorPixel (fDisplay f) clr >>= maybe (return ())+			(setForeground (fDisplay f) (gcForeground $ fGCs f))+		X.fillRectangle (fDisplay f) (bf $ fBufs f) (gcForeground $ fGCs f)+			x0 y0 (round w) (round h)+ drawLineBuf :: Field -> (Bufs -> Pixmap) -> Int -> Color -> 	Double -> Double -> Double -> Double -> IO () drawLineBuf f bf lw c x1_ y1_ x2_ y2_ = do@@ -292,9 +322,9 @@ drawShape :: Field -> Color -> [(Double, Double)] -> IO () drawShape f clr psc = do 	ps <- mapM (fmap (uncurry Point) . uncurry (topLeft f)) psc-	getColorPixel (fDisplay f) clr >>= maybe (return ())+	colorPixel (fDisplay f) clr >>= maybe (return ()) 		(setForeground (fDisplay f) (gcForeground $ fGCs f))-	X.fillPolygon (fDisplay f) (topBuf $ fBufs f) (gcForeground $ fGCs f) ps+	X.fillPolygonXT (fDisplay f) (topBuf $ fBufs f) (gcForeground $ fGCs f) ps  clearCharacter :: Character -> IO () clearCharacter c = setCharacter c $ return ()@@ -310,3 +340,9 @@  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 (fInputChan f) Timer
src/Graphics/X11/Turtle/Input.hs view
@@ -21,6 +21,7 @@ import Text.XML.YJSVG(SVG(..), Color(..), Position(..))  import Control.Concurrent.Chan(Chan, newChan, getChanContents)+import Control.Arrow  -------------------------------------------------------------------------------- @@ -41,6 +42,8 @@ 	| Rotate Double 	| Write String Double String 	| PutImage FilePath Double Double+	| Stamp+	| Dot Double 	| Bgcolor Color 	| Undo 	| Clear@@ -112,6 +115,20 @@ nextTurtle t (PutImage fp w h) = (clearState t){ 	draw = Just img, drawed = img : drawed t} 	where img = Image (uncurry Center $ position t) w h fp+nextTurtle t Stamp = (clearState t){+	draw = Just stamp, drawed = stamp : drawed t}+	where+	(x0, y0) = position t+	sp = let (sx, sy) = shapesize t in+		map (((+ x0) *** (+ y0)) . rotate . ((* sx) *** (* sy))) $ shape t+	rotate (x, y) = let rad = direction t in+		(x * cos rad - y * sin rad, x * sin rad + y * cos rad)+	points = map (uncurry Center) sp+	stamp = Polyline points (pencolor t) (pencolor t) 0+nextTurtle t (Dot sz) = (clearState t){+	draw = Just dot, drawed = dot : drawed t}+	where+	dot = Rect (uncurry Center $ position t) sz sz 0 (pencolor t) (pencolor t) nextTurtle t (Bgcolor c) = (clearState t){ 	bgcolor = c, drawed = init (drawed t) ++ [Fill c]} nextTurtle t Clear = (clearState t){clear = True, drawed = [last $ drawed t]}
src/Graphics/X11/Turtle/Move.hs view
@@ -24,7 +24,8 @@ 	onrelease, 	ondrag, 	onmotion,-	onkeypress+	onkeypress,+	ontimer ) where  import Graphics.X11.Turtle.State(TurtleState(..))@@ -33,8 +34,9 @@ 	openField, closeField, waitField, fieldSize, 	forkField, flushField, fieldColor, 	addLayer, drawLine, writeString, undoLayer, clearLayer, fillPolygon,+	fillRectangle, 	addCharacter, drawCharacter, drawCharacterAndLine, clearCharacter,-	onclick, onrelease, ondrag, onmotion, onkeypress, drawImage)+	onclick, onrelease, ondrag, onmotion, onkeypress, drawImage, ontimer) import Text.XML.YJSVG(SVG(..), Position(..))  import Control.Concurrent(threadDelay)@@ -83,6 +85,7 @@ 	where 	posToTup (Center x y) = (x, y) 	posToTup _ = error "not implemented"+drawSVG f l (Rect (Center x y) w h 0 fc _) = fillRectangle f l x y w h fc drawSVG f l (Image (Center x0 y0) w h fp) = drawImage f l fp x0 y0 w h drawSVG _ _ (Fill _) = return () drawSVG _ _ _ = error "not implemented"
src/Graphics/X11/Turtle/XTools.hs view
@@ -3,12 +3,11 @@ 	Display, 	Window, 	Pixmap,+	XIC, 	Atom, 	Point(..), 	Position, 	Dimension,-	XEventPtr,-	XIC, 	Bufs, 	undoBuf, 	bgBuf,@@ -16,27 +15,30 @@ 	GCs, 	gcForeground, 	gcBackground,++	-- ** event types+	XEventPtr, 	Event(..), -	-- * open window+	-- * basic functions 	forkIOX, 	openWindow, 	destroyWindow, 	closeDisplay, 	windowSize, -	-- * draws+	-- * draw functions 	flush,-	getColorPixel,+	colorPixel, 	setForeground, 	copyArea, 	fillRectangle,-	fillPolygon,+	fillPolygonXT, 	drawLineXT, 	writeStringXT,-	drawImage,+	drawImageXT, -	-- * event+	-- * event functions 	allocaXEvent, 	waitEvent, 	pending,@@ -52,57 +54,51 @@ import Text.XML.YJSVG(Color(..))  import Graphics.X11(-	Display, Drawable, Window, Pixmap, Visual, Colormap, GC, Pixel, Atom,-	Point(..), Position, Dimension, XEventPtr,+	Display, Drawable, Window, Pixmap, 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,+	createSimpleWindow, destroyWindow, mapWindow, getGeometry,+	createGC, createPixmap, rootWindow, defaultScreen,+	defaultScreenOfDisplay, defaultVisual, defaultColormap, defaultDepth,+	whitePixel, blackPixel,+	copyArea, fillRectangle, fillPolygon, drawLine, drawPoint,+	nonconvex, coordModeOrigin, 	setLineAttributes, lineSolid, capRound, joinRound, setForeground, 	allocNamedColor, color_pixel,-	allocaXEvent, pending, nextEvent,-	setWMProtocols, selectInput, button1MotionMask, buttonReleaseMask,-	buttonPressMask, keyPressMask, exposureMask,-	pointerMotionMask,-	buttonPress, buttonRelease, xK_VoidSymbol, getGeometry, drawPoint)-import qualified Graphics.X11 as X(fillPolygon)+	setWMProtocols, selectInput, allocaXEvent, pending, nextEvent,+	exposureMask, keyPressMask, buttonPressMask, buttonReleaseMask,+	pointerMotionMask, buttonPress, buttonRelease, xK_VoidSymbol) import Graphics.X11.Xlib.Extras(Event(..), getEvent) import Graphics.X11.Xft(-	XftColor, xftDrawCreate, xftFontOpen, withXftColorValue,-	withXftColorName, xftDrawString)+	xftDrawCreate, xftFontOpen, withXftColorValue, withXftColorName,+	xftDrawString) import Graphics.X11.Xrender(XRenderColor(..)) import Graphics.X11.Xim( 	XIC, XNInputStyle(..), openIM, createIC, getICValue, filterEvent, 	utf8LookupString)+import Graphics.Imlib(+	ImlibLoadError(..), loadImageWithErrorReturn, contextSetImage,+	imageGetWidth, imageGetHeight, imageGetData, createCroppedScaledImage) +import Numeric(showFFloat) 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.Locale.SetLocale(Category(..), setLocale) import System.Posix.Types(Fd(..))-import Numeric(showFFloat)--import Data.IORef+import Data.Word(Word32)+import Data.Bits((.|.), shift)+import Data.IORef(newIORef, readIORef) import Data.IORef.Tools(atomicModifyIORef_)-import Foreign.Ptr-import Foreign.Storable-import Foreign.Marshal.Array-import Data.Word-import Graphics.Imlib+import Foreign.Ptr(Ptr)+import Foreign.Storable(peek)+import Foreign.Marshal.Array(advancePtr)  -------------------------------------------------------------------------------- -data Bufs = Bufs{-	undoBuf :: Pixmap,-	bgBuf :: Pixmap,-	topBuf :: Pixmap}--data GCs = GCs{-	gcForeground :: GC,-	gcBackground :: GC}+data Bufs = Bufs{undoBuf :: Pixmap, bgBuf :: Pixmap, topBuf :: Pixmap}+data GCs = GCs{gcForeground :: GC, gcBackground :: GC}  -------------------------------------------------------------------------------- @@ -129,11 +125,10 @@ 	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+	forM_ bufs $ \buf -> fillRectangle dpy buf gcBG 0 0 rWidth rHeight 	setWMProtocols dpy win [del] 	selectInput dpy win $ fevent .|. exposureMask .|. keyPressMask .|.-		buttonPressMask .|. buttonReleaseMask .|. button1MotionMask .|.-		pointerMotionMask+		buttonPressMask .|. buttonReleaseMask .|. pointerMotionMask 	size <- mapWindow dpy win >> windowSize dpy win 	return (dpy, win, Bufs ub bb tb, GCs gc gcBG, ic, del, size) @@ -144,76 +139,65 @@  -------------------------------------------------------------------------------- -getColorPixel :: Display -> Color -> IO (Maybe Pixel)-getColorPixel _ (RGB r g b) = return $ Just $ shift (fromIntegral r) 16 .|.+colorPixel :: Display -> Color -> IO (Maybe Pixel)+colorPixel _ (RGB r g b) = return $ Just $ shift (fromIntegral r) 16 .|. 	shift (fromIntegral g) 8 .|. fromIntegral b-getColorPixel dpy (ColorName cn) = fmap (Just . color_pixel . fst)-	(allocNamedColor dpy (defaultColormap dpy $ defaultScreen dpy) cn) `catch`-		const (putStrLn "no such color" >> return Nothing)+colorPixel dpy (ColorName cn) = fmap (Just . color_pixel . fst)+	(allocNamedColor dpy (defaultColormap dpy $ defaultScreen dpy) cn)+		`catch` const (putStrLn "no such color" >> return Nothing) -fillPolygon :: Display -> Drawable -> GC -> [Point] -> IO ()-fillPolygon d w gc ps = X.fillPolygon d w gc ps nonconvex coordModeOrigin+fillPolygonXT :: Display -> Drawable -> GC -> [Point] -> IO ()+fillPolygonXT d w gc ps = fillPolygon d w gc ps nonconvex coordModeOrigin  drawLineXT :: Display -> GC -> Drawable -> Int -> Color -> 	Position -> Position -> Position -> Position -> IO ()-drawLineXT dpy gc bf lw c x1 y1 x2 y2 = do-	getColorPixel dpy c >>= maybe (return ()) (setForeground dpy gc)+drawLineXT dpy gc buf lw c x1 y1 x2 y2 = do+	colorPixel dpy c >>= maybe (return ()) (setForeground dpy gc) 	setLineAttributes dpy gc (fromIntegral lw) lineSolid capRound joinRound-	drawLine dpy bf gc x1 y1 x2 y2+	drawLine dpy buf 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+	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 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--drawImage :: Display -> Drawable -> GC -> FilePath -> Position -> Position ->+	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 {+				xrendercolor_red = fromIntegral r * 0x100,+				xrendercolor_green = fromIntegral b * 0x100,+				xrendercolor_blue = fromIntegral g * 0x100,+				xrendercolor_alpha = 0xffff}+		ColorName cn -> withXftColorName dpy visual colormap cn $ \c ->+			xftDrawString xftDraw c xftFont x y str+			+drawImageXT :: Display -> Drawable -> GC -> FilePath -> Position -> Position -> 	Dimension -> Dimension -> IO ()-drawImage dpy win gc fp x y w h = getPicture fp w h >>=-	maybe (return ()) (drawPicture dpy win gc x y)+drawImageXT dpy win gc fp x y w h =+	getImage fp w h >>= maybe (return ()) (drawBitmap dpy win gc x y w h) -getPicture :: FilePath -> Dimension -> Dimension ->-	IO (Maybe (Dimension, Dimension, Ptr Word32))-getPicture fp nw nh = do+getImage :: FilePath -> Dimension -> Dimension -> IO (Maybe (Ptr Word32))+getImage fp nw nh = do 	(img, err) <- loadImageWithErrorReturn fp 	case err of 		ImlibLoadErrorNone -> do 			contextSetImage img-			w <- fmap fromIntegral imageGetWidth-			h <- fmap fromIntegral imageGetHeight-			nimg <- createCroppedScaledImage (0 :: Int) (0 :: Int) (w :: Int) (h :: Int) nw nh-			contextSetImage nimg-			dat <- imageGetData-			return $ Just (nw, nh, dat)+			let	zero = 0 :: Int+			w <- fmap fromIntegral imageGetWidth :: IO Int+			h <- fmap fromIntegral imageGetHeight :: IO Int+			img' <- createCroppedScaledImage zero zero w h nw nh+			contextSetImage img'+			fmap Just imageGetData 		_ -> print err >> return Nothing -drawPicture :: Display -> Drawable -> GC -> Position -> Position ->-	(Dimension, Dimension, Ptr Word32) -> IO ()-drawPicture dpy win gc x0 y0 (w, h, dat) = do+drawBitmap :: Display -> Drawable -> GC -> Position -> Position -> Dimension ->+	Dimension -> Ptr Word32 -> IO ()+drawBitmap dpy win gc x0 y0 w h dat = do 	ptr <- newIORef dat 	forM_ [0 .. w * h - 1] $ \i -> do 		readIORef ptr >>= peek >>= setForeground dpy gc@@ -221,3 +205,8 @@ 			y = fromIntegral i `div` w 		drawPoint dpy win gc (x0 + fromIntegral x) (y0 + fromIntegral y) 		atomicModifyIORef_ ptr $ flip advancePtr 1++--------------------------------------------------------------------------------++waitEvent :: Display -> IO ()+waitEvent = threadWaitRead . Fd . connectionNumber
xturtle.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.6  name:		xturtle-version:	0.1.5+version:	0.1.6 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>