packages feed

xturtle 0.0.14 → 0.0.15

raw patch · 6 files changed

+95/−109 lines, 6 filesdep ~convertibledep ~yjsvg

Dependency ranges changed: convertible, yjsvg

Files

src/Graphics/X11/Turtle.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+ module Graphics.X11.Turtle ( 	Field, 	Turtle,@@ -31,7 +34,9 @@ 	isdown,  	bgcolor,+	rgbToColor, 	pencolor,+	Color(..), 	pensize,  	clear,@@ -59,7 +64,8 @@  	getInputs, 	sendInputs,-	getSVG+	getSVG,+	ColorClass ) where  import Graphics.X11.TurtleMove(@@ -67,13 +73,12 @@ 	forkIOX, openField, closeField, 	addCharacter, addLayer, fieldSize, clearLayer, clearCharacter, 	addThread, fieldColor, onclick, onrelease, ondrag, onkeypress, waitField,-	Color'(..), 	moveTurtle  ) import Graphics.X11.TurtleInput( 	TurtleInput(..), TurtleState, 	getTurtleStates, getPosition, getPendown, undonum, visible, direction,-	SVG, drawed+	SVG, drawed, Color(..)  ) import qualified Graphics.X11.TurtleInput as S(degrees) import Graphics.X11.TurtleShape(lookupShape)@@ -81,11 +86,10 @@ import Control.Monad(replicateM_, zipWithM_) import Prelude hiding(Left) import Data.IORef(IORef, newIORef, readIORef, modifyIORef)-import Data.Bits(shift, (.|.)) import Data.Fixed(mod')  xturtleVersion :: (Int, String)-xturtleVersion = (25, "0.0.14")+xturtleVersion = (29, "0.0.15")  data Turtle = Turtle { 	field :: Field,@@ -183,15 +187,24 @@ penup = flip sendCommand Penup pendown = flip sendCommand Pendown -pencolor :: Turtle -> Double -> Double -> Double -> IO ()-pencolor t r_ g_ b_ = sendCommand t $ Pencolor r_ g_ b_ -- c+rgbToColor :: Double -> Double -> Double -> Color+rgbToColor r g b = RGB (round $ r * 0xff) (round $ g * 0xff) (round $ b * 0xff) -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 (round . (* 255)) [r_, g_, b_]+pencolor :: ColorClass c => Turtle -> c -> IO ()+pencolor t c = sendCommand t $ Pencolor $ getColor c +class ColorClass a where+	getColor :: a -> Color++instance ColorClass String where+	getColor = ColorName++instance (Integral r, Integral g, Integral b) => ColorClass (r, g, b) where+	getColor (r, g, b) = RGB (fromIntegral r) (fromIntegral g) (fromIntegral b)++bgcolor :: ColorClass c => Field -> c -> IO ()+bgcolor f = fieldColor f . getColor+ pensize :: Turtle -> Double -> IO () pensize t = sendCommand t . Pensize @@ -253,5 +266,4 @@ sendInputs t = mapM_ (sendCommand t)  getSVG :: Turtle -> IO [SVG]-getSVG t = do-	fmap (reverse . drawed . (states t !!)) $ readIORef $ stateIndex t+getSVG t = fmap (reverse . drawed . (states t !!)) $ readIORef $ stateIndex t
src/Graphics/X11/TurtleField.hs view
@@ -29,9 +29,7 @@ 	onkeypress,  	forkIOX,-	addThread,--	Color'(..)+	addThread ) where  import Graphics.X11(@@ -55,16 +53,17 @@ 	defaultVisual, defaultColormap, defaultScreenOfDisplay,  	supportsLocale, setLocaleModifiers,-	xK_VoidSymbol, buttonPress, buttonRelease+	xK_VoidSymbol, buttonPress, buttonRelease,+	allocNamedColor  )-import qualified Graphics.X11 as X (drawLine)+import qualified Graphics.X11 as X (drawLine, Color(..)) import Graphics.X11.Xlib.Extras(Event(..), getEvent) import Graphics.X11.Xft import Graphics.X11.Xrender import Graphics.X11.Xim  import Data.IORef(IORef, newIORef, readIORef, writeIORef, modifyIORef)-import Data.Bits((.|.))+import Data.Bits((.|.), shift) import Data.Convertible(convert) import Data.List.Tools(modifyAt, setAt) import Data.Bool.Tools(whether)@@ -81,10 +80,7 @@ import System.Locale.SetLocale import Foreign.C.Types -data Color' = Color {pixel :: Pixel}--colorToPixel :: Color' -> Pixel-colorToPixel = pixel+import Text.XML.YJSVG(Color(..))  data Field = Field{ 	fDisplay :: Display,@@ -125,7 +121,7 @@  openField :: IO Field openField = do-	setLocale LC_CTYPE Nothing >>= maybe (error "Can't set locale.") return+	_ <- setLocale LC_CTYPE Nothing >>= maybe (error "Can't set locale.") return 	_ <- initThreads 	unlessM supportsLocale $ error "Current locale is notSupported." 	_ <- setLocaleModifiers ""@@ -247,7 +243,8 @@ 			Nothing -> killThread th1 >> return False 			_ -> return True --- onclick, onrelease :: Field -> (Double -> Double -> IO Bool) -> IO ()+onclick :: Field -> (Int -> Double -> Double -> IO Bool) -> IO ()+onrelease :: Field -> (Double -> Double -> IO Bool) -> IO () onclick f = writeIORef $ fOnclick f onrelease f = writeIORef $ fOnrelease f @@ -257,15 +254,24 @@ 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+fieldColor :: Field -> Color -> IO ()+fieldColor f@Field{fDisplay = dpy} c = do+	clr <- getColorPixel dpy c+	setForeground (fDisplay f) (fGCBG f) clr 	let bufs = [fUndoBuf f, fBG f, fBuf f] 	width <- readIORef $ fWidth f 	height <- readIORef $ fHeight f 	forM_ bufs $ \bf -> fillRectangle (fDisplay f) bf (fGCBG f) 0 0 width height 	redrawAll f +getColorPixel :: Display -> Color -> IO Pixel+getColorPixel _ (RGB r g b) = return $ shift (fromIntegral r) 16 .|.+	shift (fromIntegral g) 8 .|. fromIntegral b+getColorPixel dpy (ColorName cn) = do+	let	scr = defaultScreen dpy+		colormap = defaultColormap dpy scr+	fmap (X.color_pixel . fst) $ allocNamedColor dpy colormap cn+ getConnection :: Field -> Fd getConnection = Fd . connectionNumber . fDisplay @@ -311,7 +317,7 @@ 	unless cl $ act >> return ()  drawLineNotFlush ::-	Layer -> Double -> Color' -> Double -> Double -> Double -> Double -> IO ()+	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@@ -320,7 +326,7 @@ 	where 	lw = round lw_ -drawLine :: Layer -> Double -> Color' -> Double -> Double -> Double -> Double -> IO ()+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@@ -363,18 +369,20 @@ clearCharacter c = runIfOpened (characterField c) $ 	setCharacter c $ return () -drawCharacter :: Character -> Color' -> [(Double, Double)] -> IO ()-drawCharacter c@Character{characterField = f} clr sh =+drawCharacter :: Character -> Color -> [(Double, Double)] -> IO ()+drawCharacter c@Character{characterField = f} cl sh = 	runIfOpened (characterField c) $ setCharacter c $ do-		setForeground (fDisplay f) (fGC f) $ colorToPixel clr+		clr <- getColorPixel (fDisplay f) cl+		setForeground (fDisplay f) (fGC f) clr 		fillPolygonBuf (characterField c) sh -drawCharacterAndLine ::	Character -> Color' -> [(Double, Double)] -> Double ->+drawCharacterAndLine ::	Character -> Color -> [(Double, Double)] -> Double -> 	Double -> Double -> Double -> Double -> IO ()-drawCharacterAndLine c@Character{characterField = f} clr ps lw_ x1 y1 x2 y2 =+drawCharacterAndLine c@Character{characterField = f} cl 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+		clr <- getColorPixel (fDisplay f) cl+		setForeground (fDisplay f) (fGC f) clr+		fillPolygonBuf f ps >> drawLineBuf f lw cl fBuf x1 y1 x2 y2 	where 	lw = round lw_ @@ -428,10 +436,11 @@ 	fillPolygon (fDisplay f) (fBuf f) (fGC f) (map (uncurry Point) ps) 		nonconvex coordModeOrigin -drawLineBuf :: Field -> Int -> Color' -> (Field -> Pixmap) ->+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+drawLineBuf f@Field{fDisplay = dpy, fGC = gc} lw c bf x1_ y1_ x2_ y2_ = do+	clr <- getColorPixel dpy c+	setForeground (fDisplay f) (fGC f) clr 	setLineAttributes (fDisplay f) (fGC f) (fromIntegral lw) lineSolid capRound joinRound 	[(x1, y1), (x2, y2)] <- convertPos f [(x1_, y1_), (x2_, y2_)] 	X.drawLine dpy (bf f) gc x1 y1 x2 y2
src/Graphics/X11/TurtleInput.hs view
@@ -11,12 +11,12 @@ 	degrees, 	drawed, -	SVG+	SVG,+	Color(..) ) where  import Graphics.X11.TurtleState(TurtleState(..), initialTurtleState,-	pencolor',-	SVG(..), Position(..))+	SVG(..), Position(..), Color(..)) import Control.Concurrent.Chan(Chan, newChan, getChanContents) import Prelude hiding(Left) @@ -39,7 +39,7 @@ 	| Forward Double 	| Left Double 	| Undonum Int-	| Pencolor Double Double Double+	| Pencolor Color 	| Pensize Double 	| Degrees Double 	| Write String Double String@@ -57,9 +57,8 @@ 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 ln : drawed t else drawed t}---		then Line (pencolor t) (pensize t) (position t) (x, y) : drawed t else drawed t}  	where-	ln = Line (uncurry Center $ position t) (Center x y) (pencolor' t)+	ln = Line (uncurry Center $ position t) (Center x y) (pencolor t) 		(pensize t) nextTurtle t (Rotate d) = (clearState t){direction = d} nextTurtle t Pendown = (clearState t){pendown = True}@@ -67,7 +66,7 @@ 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 r g b) = (clearState t){red = r, green = g, blue = b}-- setPencolor (clearState t) c+nextTurtle t (Pencolor c) = (clearState t){pencolor = c} nextTurtle t (Pensize ps) = (clearState t){pensize = ps} nextTurtle t (Degrees ds) = (clearState t){ 	degrees = ds,@@ -78,8 +77,7 @@  } 	where 	(x, y) = position t-	d = Text (Center x y) sz (pencolor' t) fnt str---	d = Str (red t, green t, blue t) fnt sz (position t) str+	d = Text (Center x y) sz (pencolor t) fnt str nextTurtle _ _ = error "not defined"  clearState :: TurtleState -> TurtleState
src/Graphics/X11/TurtleMove.hs view
@@ -19,13 +19,13 @@ 	onkeypress, 	waitField, 	writeString,-	Color'(..),+--	Color'(..),  	moveTurtle ) where -import Graphics.X11.TurtleState(TurtleState(..), pencolor, SVG(..), Position(..),-	colorToWord32, Color(..))+import Graphics.X11.TurtleState(TurtleState(..), SVG(..), Position(..),+	Color(..)) import Graphics.X11.TurtleField( 	Field, Layer, Character, 	forkIOX, openField, closeField, flushLayer,@@ -33,8 +33,7 @@ 	drawLine, drawCharacter, drawCharacterAndLine, undoLayer, 	drawLineNotFlush, 	clearCharacter, addThread,-	fieldColor, onkeypress, onclick, onrelease, ondrag, waitField, writeString,-	Color'(..)+	fieldColor, onkeypress, onclick, onrelease, ondrag, waitField, writeString  )  import Control.Concurrent(threadDelay)@@ -67,18 +66,18 @@ 	when (undo t1 && clear t0) $ drawLines l $ drawed t1 	when (visible t1) $ do 		forM_ (getDirections (dir t0) (dir t1)) $ \d -> do-			drawTurtle c (Color $ pencolor t1) (shape t1) (shapesize t1) d+			drawTurtle c (pencolor t1) (shape t1) (shapesize t1) d 				(pensize t1) p0 Nothing 			threadDelay rotateSpeed 		forM_ (getPositions x0 y0 x1 y1) $ \p -> do-			drawTurtle c (Color $ pencolor t1) (shape t1) (shapesize t1)+			drawTurtle c (pencolor t1) (shape t1) (shapesize t1) 				(dir t1) (pensize t1) p lineOrigin 			threadDelay moveSpeed-		drawTurtle c (Color $ pencolor t1) (shape t1) (shapesize t1) (dir t1)+		drawTurtle c (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) (Color $ pencolor t1) x0 y0 x1 y1 >> flushLayer l+		drawLine l (pensize t1) (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@@ -93,8 +92,8 @@ drawDraw :: Layer -> Maybe SVG -> IO () drawDraw _ Nothing = return () drawDraw l (Just (Line (Center x0 y0) (Center x1 y1) clr lw)) =-	drawLineNotFlush l lw (Color $ colorToWord32 clr) x0 y0 x1 y1--- drawDraw l (Line clr lw (x0, y0) (x1, y1)) = drawLineNotFlush l lw (Color clr) x0 y0 x1 y1+	drawLineNotFlush l lw clr x0 y0 x1 y1+-- drawDraw l (Line clr lw (x0, y0) (x1, y1)) = drawLineNotFlush l lw (clr) x0 y0 x1 y1 drawDraw l (Just (Text (Center x y) sz (RGB r_ g_ b_) fnt str)) = -- drawDraw l (Just (Text (r, g, b) fnt sz (x, y) str)) = 	writeString l fnt sz r g b x y str@@ -115,7 +114,7 @@ 	where 	dd = if de > ds then stepDir else - stepDir -drawTurtle :: Character -> Color' -> [Pos] -> Double -> Double -> Double ->+drawTurtle :: Character -> Color -> [Pos] -> Double -> Double -> Double -> 	Pos -> Maybe Pos -> IO () drawTurtle c clr sh s d lw (px, py) org = do 	let sp = map (((+ px) *** (+ py)) . rotatePoint . ((* s) *** (* s))) sh
src/Graphics/X11/TurtleState.hs view
@@ -1,12 +1,9 @@ module Graphics.X11.TurtleState ( 	TurtleState(..), 	initialTurtleState,---	Color,-	pencolor',-	pencolor,+	pencolor_, 	setPencolor, 	SVG(..),---	Draw(..), 	Position(..), 	Color(..), 	colorToWord32@@ -16,36 +13,11 @@ import Data.Bits import Text.XML.YJSVG -{--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 -> Color-pencolor' t =-	RGB (round $ red t * 0xff) (round $ green t * 0xff) (round $ blue t *  0xff)--pencolor :: TurtleState -> Word32-pencolor t = c+pencolor_ :: TurtleState -> Word32+pencolor_ TurtleState{pencolor = RGB r g b} = c' 	where-	c = shift (round $ red t * 0xff) 16 .|.-		shift (round $ green t * 0xff) 8 .|. round (blue t * 0xff)+	c' = shift (fromIntegral r) 16 .|. shift (fromIntegral g) 8 .|. fromIntegral b+pencolor_ TurtleState{pencolor = ColorName _} = error "not implemented"  colorToWord32 :: Color -> Word32 colorToWord32 (RGB r g b) =@@ -53,12 +25,12 @@ colorToWord32 _ = error "colorToWord32 (ColorName _) is not implemented"  setPencolor :: TurtleState -> Word32 -> TurtleState-setPencolor t c = t{red = r, green = g, blue = b}+setPencolor t c = t{+	pencolor = RGB r_ g_ b_} 	where-	r_ = shiftR c 16 .&. 0xff-	g_ = shiftR c 8 .&. 0xff-	b_ = c .&. 0xff-	[r, g, b] = map ((/ 0xff) . fromIntegral) [r_, g_, b_]+	r_ = fromIntegral $ shiftR c 16 .&. 0xff+	g_ = fromIntegral $ shiftR c 8 .&. 0xff+	b_ = fromIntegral $ c .&. 0xff  data TurtleState = TurtleState { 	position :: (Double, Double),@@ -66,9 +38,7 @@ 	degrees :: Double, 	pendown :: Bool, 	pensize :: Double,-	red :: Double,-	green :: Double,-	blue :: Double,+	pencolor :: Color, 	shape :: [(Double, Double)], 	shapesize :: Double, 	visible :: Bool,@@ -87,9 +57,7 @@ 	degrees = 360, 	pendown = True, 	pensize = 0,-	red = 0,-	green = 0,-	blue = 0,+	pencolor = RGB 0 0 0, 	shape = sh, 	shapesize = 1, 	visible = True,
xturtle.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.6  name:		xturtle-version:	0.0.14+version:	0.0.15 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -30,8 +30,8 @@ library   Hs-source-dirs:	src   Exposed-modules:	Graphics.X11.Turtle-  Build-depends:	base > 3 && < 5, yjtools >= 0.9.13, convertible, X11,-    X11-xft <= 3.1, x11-xim, setlocale, yjsvg >= 0.1.9+  Build-depends:	base > 3 && < 5, yjtools >= 0.9.13, convertible >= 1.0.8, X11,+    X11-xft <= 3.1, x11-xim, setlocale, yjsvg >= 0.1.11   Ghc-options:		-Wall   Other-modules:	Graphics.X11.TurtleField, Graphics.X11.TurtleInput,     Graphics.X11.TurtleMove, Graphics.X11.TurtleState, Graphics.X11.TurtleShape