packages feed

xturtle 0.0.13 → 0.0.14

raw patch · 6 files changed

+146/−51 lines, 6 filesdep +yjsvg

Dependencies added: yjsvg

Files

src/Graphics/X11/Turtle.hs view
@@ -49,23 +49,31 @@ 	windowWidth, 	windowHeight, 	onclick,+	onrelease,+	ondrag, 	onkeypress, 	waitField,  	xturtleVersion,-	write+	write,++	getInputs,+	sendInputs,+	getSVG ) where  import Graphics.X11.TurtleMove( 	Field, Layer, Character, 	forkIOX, openField, closeField, 	addCharacter, addLayer, fieldSize, clearLayer, clearCharacter,-	addThread, fieldColor, onclick, onkeypress, waitField, Color(..),+	addThread, fieldColor, onclick, onrelease, ondrag, onkeypress, waitField,+	Color'(..), 	moveTurtle  ) import Graphics.X11.TurtleInput( 	TurtleInput(..), TurtleState,-	getTurtleStates, getPosition, getPendown, undonum, visible, direction+	getTurtleStates, getPosition, getPendown, undonum, visible, direction,+	SVG, drawed  ) import qualified Graphics.X11.TurtleInput as S(degrees) import Graphics.X11.TurtleShape(lookupShape)@@ -77,7 +85,7 @@ import Data.Fixed(mod')  xturtleVersion :: (Int, String)-xturtleVersion = (24, "0.0.13")+xturtleVersion = (25, "0.0.14")  data Turtle = Turtle { 	field :: Field,@@ -85,6 +93,7 @@ 	character :: Character, 	inputChan :: Chan TurtleInput, 	states :: [TurtleState],+	inputs :: [TurtleInput], 	stateIndex :: IORef Int, 	thread :: ThreadId  }@@ -93,7 +102,7 @@ newTurtle f = do 	ch <- addCharacter f 	l <- addLayer f-	(ic, sts) <- getTurtleStates $ lookupShape "classic"+	(ic, tis, sts) <- getTurtleStates $ lookupShape "classic" 	si <- newIORef 1 	let	t = Turtle { 			field = f,@@ -101,6 +110,7 @@ 			layer = l, 			character = ch, 			states = sts,+			inputs = tis, 			stateIndex = si, 			thread = undefined 		 }@@ -233,3 +243,15 @@  isvisible :: Turtle -> IO Bool isvisible t = fmap (visible . (states t !!)) $ readIORef $ stateIndex t++getInputs :: Turtle -> IO [TurtleInput]+getInputs t = do+	i <- readIORef $ stateIndex t+	return $ take (i - 1) $ inputs t++sendInputs :: Turtle -> [TurtleInput] -> IO ()+sendInputs t = mapM_ (sendCommand t)++getSVG :: Turtle -> IO [SVG]+getSVG t = do+	fmap (reverse . drawed . (states t !!)) $ readIORef $ stateIndex t
src/Graphics/X11/TurtleField.hs view
@@ -24,12 +24,14 @@ 	flushLayer,  	onclick,+	onrelease,+	ondrag, 	onkeypress,  	forkIOX, 	addThread, -	Color(..)+	Color'(..) ) where  import Graphics.X11(@@ -45,14 +47,15 @@ 	fillRectangle, fillPolygon, nonconvex, coordModeOrigin,  	setWMProtocols, selectInput, allocaXEvent, nextEvent, XEventPtr,-	keyPressMask, exposureMask, buttonPressMask,+	keyPressMask, exposureMask, buttonPressMask, buttonReleaseMask,+	button1MotionMask,  	getGeometry, initThreads, connectionNumber, pending, destroyWindow,  	defaultVisual, defaultColormap, defaultScreenOfDisplay,  	supportsLocale, setLocaleModifiers,-	xK_VoidSymbol+	xK_VoidSymbol, buttonPress, buttonRelease  ) import qualified Graphics.X11 as X (drawLine) import Graphics.X11.Xlib.Extras(Event(..), getEvent)@@ -78,9 +81,9 @@ import System.Locale.SetLocale import Foreign.C.Types -data Color = Color {pixel :: Pixel}+data Color' = Color {pixel :: Pixel} -colorToPixel :: Color -> Pixel+colorToPixel :: Color' -> Pixel colorToPixel = pixel  data Field = Field{@@ -102,7 +105,10 @@ 	fClose :: Chan (), 	fClosed :: IORef Bool, 	fRunning :: IORef [ThreadId],-	fOnclick :: IORef (Double -> Double -> IO Bool),+	fOnclick :: IORef (Int -> Double -> Double -> IO Bool),+	fOnrelease :: IORef (Double -> Double -> IO Bool),+	fOndrag :: IORef (Double -> Double -> IO ()),+	fPress :: IORef Bool, 	fKeypress :: IORef (Char -> IO Bool), 	fEnd :: Chan ()  }@@ -119,7 +125,7 @@  openField :: IO Field openField = do-	setLocale LC_CTYPE Nothing >>= maybe (error "Can't set locale.") print+	setLocale LC_CTYPE Nothing >>= maybe (error "Can't set locale.") return 	_ <- initThreads 	unlessM supportsLocale $ error "Current locale is notSupported." 	_ <- setLocaleModifiers ""@@ -140,7 +146,10 @@ 	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+	selectInput dpy win $+		exposureMask .|. keyPressMask .|.+		buttonPressMask .|. buttonReleaseMask .|. button1MotionMask .|.+		fevent 	mapWindow dpy win 	[widthRef, heightRef] <- mapM newIORef [rWidth, rHeight] 	buffActions <- newIORef []@@ -151,7 +160,10 @@ 	close <- newChan 	closed <- newIORef False 	running <- newIORef []-	onclickRef <- newIORef $ const $ const $ return True+	onclickRef <- newIORef $ const $ const $ const $ return True+	onreleaseRef <- newIORef $ const $ const $ return True+	ondragRef <- newIORef $ const $ const $ return ()+	pressRef <- newIORef False 	keypressRef <- newIORef $ const $ return True 	endRef <- newChan 	writeChan wait ()@@ -175,6 +187,9 @@ 		fClosed = closed, 		fRunning = running, 		fOnclick = onclickRef,+		fOnrelease = onreleaseRef,+		fOndrag = ondragRef,+		fPress = pressRef, 		fKeypress = keypressRef, 		fEnd = endRef 	 }@@ -211,19 +226,38 @@ 				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+				case ev_event_type ev of+					et	| et == buttonPress -> do+							writeIORef (fPress f) True+							fun <- readIORef (fOnclick f)+							uncurry (fun $ fromIntegral $ ev_button ev)+								pos+						| et == buttonRelease -> do+							writeIORef (fPress f) False+							readIORef (fOnrelease f) >>=+								($ pos) . uncurry+					_ -> error "not implement event"+			Just ev@MotionEvent{} -> do+				pos <- convertPosRev f (ev_x ev) (ev_y ev)+				whenM (readIORef $ fPress f) $+					readIORef (fOndrag f) >>= ($ pos) . uncurry+				return True 			Just ev@ClientMessageEvent{} -> 				return $ convert (head $ ev_data ev) /= fDel f 			Nothing -> killThread th1 >> return False 			_ -> return True -onclick :: Field -> (Double -> Double -> IO Bool) -> IO ()+-- onclick, onrelease :: Field -> (Double -> Double -> IO Bool) -> IO () onclick f = writeIORef $ fOnclick f+onrelease f = writeIORef $ fOnrelease f +ondrag :: Field -> (Double -> Double -> IO ()) -> IO ()+ondrag f = writeIORef $ fOndrag f+ onkeypress :: Field -> (Char -> IO Bool) -> IO () onkeypress f = writeIORef $ fKeypress f -fieldColor :: Field -> Color -> IO ()+fieldColor :: Field -> Color' -> IO () fieldColor f clr = do 	setForeground (fDisplay f) (fGCBG f) $ colorToPixel clr 	let bufs = [fUndoBuf f, fBG f, fBuf f]@@ -277,7 +311,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@@ -286,7 +320,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@@ -329,13 +363,13 @@ clearCharacter c = runIfOpened (characterField c) $ 	setCharacter c $ return () -drawCharacter :: Character -> Color -> [(Double, Double)] -> IO ()+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 ->+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@@ -394,7 +428,7 @@ 	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
src/Graphics/X11/TurtleInput.hs view
@@ -8,11 +8,15 @@ 	undonum, 	visible, 	direction,-	degrees+	degrees,+	drawed,++	SVG ) where -import Graphics.X11.TurtleState(TurtleState(..), initialTurtleState, pencolor,-	Draw(..))+import Graphics.X11.TurtleState(TurtleState(..), initialTurtleState,+	pencolor',+	SVG(..), Position(..)) import Control.Concurrent.Chan(Chan, newChan, getChanContents) import Prelude hiding(Left) @@ -39,21 +43,24 @@ 	| Pensize Double 	| Degrees Double 	| Write String Double String-	deriving Show+	deriving (Show, Read) -getTurtleStates :: [(Double, Double)] -> IO (Chan TurtleInput, [TurtleState])+getTurtleStates :: [(Double, Double)] -> IO (Chan TurtleInput, [TurtleInput], [TurtleState]) getTurtleStates sh = do 	let	ts0 = initialTurtleState sh 	c <- newChan 	tis <- getChanContents c-	return (c, ts0 : ts0 : inputToTurtle [] ts0 tis)+	return (c, tis, ts0 : ts0 : inputToTurtle [] ts0 tis)  nextTurtle :: TurtleState -> TurtleInput -> TurtleState nextTurtle t (Shape sh) = (clearState t){shape = sh} nextTurtle t (ShapeSize ss) = (clearState t){shapesize = ss} nextTurtle t (Goto x y) = (clearState t){position = (x, y), line = pendown t,-	drawed = if pendown t-		then Line (pencolor t) (pensize t) (position t) (x, y) : drawed t else drawed 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)+		(pensize t) nextTurtle t (Rotate d) = (clearState t){direction = d} nextTurtle t Pendown = (clearState t){pendown = True} nextTurtle t Penup = (clearState t){pendown = False}@@ -67,13 +74,16 @@ 	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+	draw = Just d, drawed = d : drawed t  }+	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 nextTurtle _ _ = error "not defined"  clearState :: TurtleState -> TurtleState-clearState t = t{line = False, undo = False, undonum = 1, clear = False, draw = NoDraw}+clearState t = t{line = False, undo = False, undonum = 1, clear = False, draw = Nothing}  inputToTurtle :: [TurtleState] -> TurtleState -> [TurtleInput] -> [TurtleState] inputToTurtle [] ts0 (Undo : tis) = ts0 : inputToTurtle [] ts0 tis
src/Graphics/X11/TurtleMove.hs view
@@ -14,15 +14,18 @@ 	addThread, 	fieldColor, 	onclick,+	onrelease,+	ondrag, 	onkeypress, 	waitField, 	writeString,-	Color(..),+	Color'(..),  	moveTurtle ) where -import Graphics.X11.TurtleState(TurtleState(..), pencolor, Draw(..))+import Graphics.X11.TurtleState(TurtleState(..), pencolor, SVG(..), Position(..),+	colorToWord32, Color(..)) import Graphics.X11.TurtleField( 	Field, Layer, Character, 	forkIOX, openField, closeField, flushLayer,@@ -30,12 +33,14 @@ 	drawLine, drawCharacter, drawCharacterAndLine, undoLayer, 	drawLineNotFlush, 	clearCharacter, addThread,-	fieldColor, onkeypress, onclick, waitField, writeString, Color(..)+	fieldColor, onkeypress, onclick, onrelease, ondrag, waitField, writeString,+	Color'(..)  )  import Control.Concurrent(threadDelay) import Control.Monad(when, unless, forM_) import Control.Arrow((***))+import Data.Maybe  type Pos = (Double, Double) @@ -56,7 +61,7 @@  moveTurtle :: Character -> Layer -> TurtleState -> TurtleState -> IO () moveTurtle c l t0 t1 = do-	when (undo t1 && (line t0 || draw t0 /= NoDraw)) $ do+	when (undo t1 && (line t0 || isJust (draw t0))) $ do 		done <- undoLayer l 		unless done $ clearLayer l >> drawLines l (drawed t1) 	when (undo t1 && clear t0) $ drawLines l $ drawed t1@@ -82,13 +87,20 @@ 	p0@(x0, y0) = position t0 	p1@(x1, y1) = position t1 -drawLines :: Layer -> [Draw] -> IO ()-drawLines l = mapM_ (drawDraw l) . reverse+drawLines :: Layer -> [SVG] -> IO ()+drawLines l = mapM_ (drawDraw l . Just) . 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+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+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+	where+	[r, g, b] = map ((/ 0xff) . fromIntegral) [r_, g_, b_]+drawDraw _ _ = error "not implemented"  getPositions :: Double -> Double -> Double -> Double -> [Pos] getPositions x0 y0 x1 y1 = take num $ zip [x0, x0 + dx .. ] [y0, y0 + dy .. ]@@ -103,7 +115,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,15 +1,22 @@ module Graphics.X11.TurtleState ( 	TurtleState(..), 	initialTurtleState,-	Color,+--	Color,+	pencolor', 	pencolor, 	setPencolor,-	Draw(..)+	SVG(..),+--	Draw(..),+	Position(..),+	Color(..),+	colorToWord32 ) where  import Data.Word(Word32) import Data.Bits+import Text.XML.YJSVG +{- type Color = Word32  data Draw@@ -28,13 +35,23 @@ 		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 	where 	c = shift (round $ red t * 0xff) 16 .|. 		shift (round $ green t * 0xff) 8 .|. round (blue t * 0xff) +colorToWord32 :: Color -> Word32+colorToWord32 (RGB r g b) =+	shift (fromIntegral r) 16 .|. shift (fromIntegral g) 8 .|. fromIntegral b+colorToWord32 _ = error "colorToWord32 (ColorName _) is not implemented"+ setPencolor :: TurtleState -> Word32 -> TurtleState setPencolor t c = t{red = r, green = g, blue = b} 	where@@ -59,8 +76,8 @@ 	undo :: Bool, 	line :: Bool, 	undonum :: Int,-	draw :: Draw,-	drawed :: [Draw]+	draw :: Maybe SVG,+	drawed :: [SVG]  } deriving Show  initialTurtleState :: [(Double, Double)] -> TurtleState@@ -80,6 +97,6 @@ 	undo = False, 	line = False, 	undonum = 1,-	draw = NoDraw,+	draw = Nothing, 	drawed = []  }
xturtle.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.6  name:		xturtle-version:	0.0.13+version:	0.0.14 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -31,7 +31,7 @@   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+    X11-xft <= 3.1, x11-xim, setlocale, yjsvg >= 0.1.9   Ghc-options:		-Wall   Other-modules:	Graphics.X11.TurtleField, Graphics.X11.TurtleInput,     Graphics.X11.TurtleMove, Graphics.X11.TurtleState, Graphics.X11.TurtleShape