packages feed

xturtle (empty) → 0.0.1

raw patch · 5 files changed

+555/−0 lines, 5 filesdep +X11dep +basedep +convertiblesetup-changed

Dependencies added: X11, base, convertible, yjtools

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2011, Yoshikuni Jujo+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++  * Redistributions of source code must retain the above copyright notice,+    this list of conditions and the following disclaimer.++  * Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in the+    documentation and/or other materials provided with the distribution.++  * Neither the name of the Yoshikuni Jujo nor the names of its+    contributors may be used to endorse or promote products derived from+    this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVEN SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Graphics/X11/Turtle.hs view
@@ -0,0 +1,332 @@+module Graphics.X11.Turtle (+	initTurtle,+	closeTurtle,+	shapesize,+	goto,+	forward,+	backward,+	left,+	right,+	penup,+	pendown,+	isdown,+	home,+	circle,+	clear,+	undoAll,+	undo,+	distance,++	Position,+	testModuleTurtle+) where++import Graphics.X11.World+import Data.IORef+import Data.List+import System.IO.Unsafe+import Control.Arrow (second)+import Control.Monad.Tools+import Control.Monad+import Control.Concurrent+import Data.Maybe++world :: IORef World+world = unsafePerformIO $ newIORef undefined++windowWidth :: IO Double+windowWidth = readIORef world >>= fmap fst . getWindowSize++windowHeight :: IO Double+windowHeight = readIORef world >>= fmap snd . getWindowSize++position :: IO (Double, Double)+position = do+	w <- readIORef world+	(x, y) <- getCursorPos w+	width <- windowWidth+	height <- windowHeight+	return (x - width / 2, height / 2 - y)++distance :: Double -> Double -> IO Double+distance x0 y0 = do+	(x, y) <- position+	return $ ((x - x0) ** 2 + (y - y0) ** 2) ** (1 / 2)++pastDrawLines :: IORef [Maybe (((Double, Double), Double), IO ())]+pastDrawLines = unsafePerformIO $ newIORef []++data PenState = PenUp | PenDown++doesPenDown :: PenState -> Bool+doesPenDown PenUp = False+doesPenDown PenDown = True++penState :: IORef PenState+penState = unsafePerformIO $ newIORef PenDown++testModuleTurtle :: IO ()+testModuleTurtle = main++main :: IO ()+main = do+	putStrLn "module Turtle"+	initTurtle+	w <- readIORef world+	redrawLines+	withEvent w () $ \() ev ->+		case ev of+			ExposeEvent{} -> do+				drawWorld w+				return ((), True)+			KeyEvent{} -> do+				ch <- eventToChar w ev+				return ((), (ch /= 'q'))+			ClientMessageEvent{} ->+				return ((), not $ isDeleteEvent w ev)+			AnyEvent{ev_event_type = 14} ->+				return ((), True)+			_ -> error $ "not implemented for event " ++ show ev+	closeTurtle++initTurtle :: IO ()+initTurtle = do+	w <- openWorld+	setCursorPos w 100 200+	setCursorDir w 0+	setCursorSize w 2+	setCursorShape w displayTurtle+	drawWorld w+	flushWorld w+	writeIORef world w+	width <- windowWidth+	height <- windowHeight+	setCursorPos w (width / 2) (height / 2)+	drawWorld w+	flushWorld w++shapesize :: Double -> IO ()+shapesize s = do+	w <- readIORef world+	setCursorSize w s+	drawWorld w+	flushWorld w++goto, rawGoto :: Double -> Double -> IO ()+goto x y = do+	width <- windowWidth+	height <- windowHeight+	rawGoto (x + width / 2) (- y + height / 2)+		>> modifyIORef pastDrawLines (++ [Nothing])+rawGoto xTo yTo = do+	w <- readIORef world+	(x0, y0) <- getCursorPos w+	let	step = 10+		distX = xTo - x0+		distY = yTo - y0+		dist = (distX ** 2 + distY ** 2) ** (1 / 2)+		dx = step * distX / dist+		dy = step * distY / dist+	(x', y') <- if (dist <= step) then return (x0, y0) else doWhile (x0, y0) $ \(x, y) -> do+		let	nx = x + dx+			ny = y + dy+		setCursorPos w nx ny+		drawLine w x y nx ny+		drawWorld w+		flushWorld w+		threadDelay 20000+		return ((nx, ny),+			(nx + dx - x0) ** 2 + (ny + dy - y0) ** 2 < dist ** 2)+	setCursorPos w xTo yTo+	drawLine w x' y' xTo yTo+	drawWorld w+	flushWorld w++forward, rawForward :: Double -> IO ()+forward len = rawForward len >> modifyIORef pastDrawLines (++ [Nothing])+rawForward len = do+	w <- readIORef world+	(x0, y0) <- getCursorPos w+	d <- getCursorDir w+	let	rad = d * pi / 180+		nx' = x0 + len * cos rad+		ny' = y0 + len * sin rad+	rawGoto nx' ny'++backward :: Double -> IO ()+backward = forward . negate++penup :: IO ()+penup = writeIORef penState PenUp++pendown :: IO ()+pendown = writeIORef penState PenDown++isdown :: IO Bool+isdown = do+	ps <- readIORef penState+	return $ case ps of+		PenUp -> False+		PenDown -> True++drawLine :: World -> Double -> Double -> Double -> Double -> IO ()+drawLine w x1 y1 x2 y2 = do+	let act = do+		ps <- readIORef penState+		when (doesPenDown ps) $+			lineToBG w (round x1) (round y1) (round x2) (round y2)+	act+	dir <- readIORef world >>= getCursorDir +	modifyIORef pastDrawLines (++ [Just (((x2, y2), dir), act)])++redrawLines :: IO ()+redrawLines = do+	w <- readIORef world+	dls <- fmap (map fromJust . filter isJust) $ readIORef pastDrawLines+	clear+	flip mapM_ dls $ \dl -> do+		snd dl+		drawWorld w+		flushWorld w+		threadDelay 20000++undoAll :: IO ()+undoAll = do+	w <- readIORef world+	dls <- fmap (map fromJust . filter isJust) $ readIORef pastDrawLines+	flip mapM_ (zip (reverse $ map fst dls) $ map sequence_ $ reverse $ inits $ map snd dls)+		$ \((pos, dir), dl) -> do+		cleanBG w+		dl+		uncurry (setCursorPos w) pos+		setCursorDir w dir+		drawWorld w+		flushWorld w+		threadDelay 20000++undo :: IO ()+undo = do+	w <- readIORef world+	dls <- fmap init $ readIORef pastDrawLines+	let	draw = map (map fromJust . filter isJust)+			$ takeWhile (isJust . last) $ reverse $ inits dls+		draw1 = map fromJust $ filter isJust $ head+			$ dropWhile (isJust . last) $ reverse $ inits dls+		draw' = draw ++ [draw1]+	flip mapM_ (zip (reverse $ map (fst . fromJust) $ filter isJust dls ) $ map sequence_+		$ map (map snd) draw') $ \((pos, dir), dl) -> do+		cleanBG w+		dl+		uncurry (setCursorPos w) pos+		setCursorDir w dir+		drawWorld w+		flushWorld w+		threadDelay 20000+	modifyIORef pastDrawLines $ reverse . dropWhile isJust . tail . reverse++rotateBy :: Double -> IO ()+rotateBy dd = do+	w <- readIORef world+	d0 <- getCursorDir w+	let	nd = (d0 + dd) `gMod` 360+	setCursorDir w nd+	drawWorld w+	flushWorld w+	pos <- getCursorPos w+	modifyIORef pastDrawLines (++ [Just ((pos, nd), return ())])++rotateTo :: Double -> IO ()+rotateTo d = do+	w <- readIORef world+	d0 <- getCursorDir w+	let	step = 5+		dd = d - d0+	replicateM_ (abs dd `gDiv` step) $+		rotateBy (signum dd * step) >> threadDelay 10000+	setCursorDir w d+	drawWorld w+	flushWorld w++rotate, rawRotate :: Double -> IO ()+rotate d = rawRotate d >> modifyIORef pastDrawLines (++ [Nothing])+rawRotate d = do+	w <- readIORef world+	d0 <- getCursorDir w+	rotateTo $ d0 + d++gDiv :: (Num a, Ord a, Integral b) => a -> a -> b+x `gDiv` y+	| x >= y = 1 + (x - y) `gDiv` y+	| otherwise = 0++gMod :: (Num a, Ord a) => a -> a -> a+x `gMod` y+	| x >= y = (x - y) `gMod` y+	| otherwise = x++right :: Double -> IO ()+right = rotate++left :: Double -> IO ()+left = rotate . negate++circle :: Position -> IO ()+circle r = replicateM_ 36 $ do+	rawForward $ (2 * fromIntegral r * pi / 36 :: Double)+	rawRotate (- 10)++home :: IO ()+home = goto 0 0 >> rotateTo 0++clear :: IO ()+clear = do+	w <- readIORef world+	cleanBG w+	drawWorld w >> flushWorld w+	pos <- getCursorPos w+	dir <- getCursorDir w+	modifyIORef pastDrawLines (++ [Just ((pos, dir), cleanBG w)])++closeTurtle :: IO ()+closeTurtle = readIORef world >>= closeWorld++displayTurtle :: World -> Double -> Double -> Double -> Double -> IO ()+displayTurtle w s d x y =+	makeFilledPolygonCursor w $ map (uncurry $ addPoint $ Point (round x) (round y))+		$ map (rotatePointD d)+		$ map (mulPoint s) turtle++addPoint :: Point -> Position -> Position -> Point+addPoint (Point x y) dx dy = Point (x + dx) (y + dy)++rotatePointD :: Double -> (Position, Position) -> (Position, Position)+rotatePointD = rotatePointR . (* pi) . (/ 180)++rotatePointR :: Double -> (Position, Position) -> (Position, Position)+rotatePointR rad (x, y) =+	(x `mul` cos rad - y `mul` sin rad, x `mul` sin rad + y `mul` cos rad)++mulPoint :: Double -> (Position, Position) -> (Position, Position)+mulPoint s (x, y) = (x `mul` s, y `mul` s)++mul :: (Integral a, RealFrac b) => a -> b -> a+x `mul` y = round $ fromIntegral x * y++turtle :: [(Position, Position)]+turtle = ttl ++ reverse (map (second negate) ttl)+	where+	ttl = [+		(- 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)+	 ]
+ src/Graphics/X11/World.hs view
@@ -0,0 +1,160 @@+module Graphics.X11.World (+	World,+	openWorld,+	setCursorPos,+	getCursorPos,+	setCursorDir,+	getCursorDir,+	setCursorSize,+	setCursorShape,+	drawWorld,+	closeWorld,+	withEvent,+	flushWorld,+	eventToChar,+	isDeleteEvent,+	makeFilledPolygonCursor,+	lineToBG,+	cleanBG,+	getWindowSize,++	Event(..),+	Position,+	Dimension,+	Point(..),+	testModuleWorld+) where++import Graphics.X11+import Graphics.X11.Xlib.Extras+import Data.IORef+import Data.Bits+import Data.Char+import Data.Convertible+import Control.Monad.Tools++data World = World{+	wDisplay :: Display,+	wWindow :: Window,+	wGC :: GC,+	wDel :: Atom,+	wBG :: Pixmap,+	wBuf :: Pixmap,+	wPos :: IORef (Double, Double),+	wDir :: IORef Double,+	wSize :: IORef Double,+	wShape :: IORef (World -> Double -> Double -> Double -> Double -> IO ())+ }++getWindowSize :: World -> IO (Double, Double)+getWindowSize w = do+	(_, _, _, width, height, _, _) <- getGeometry (wDisplay w) (wWindow w)+	return (fromIntegral width, fromIntegral height)++setCursorPos :: World -> Double -> Double -> IO ()+setCursorPos w x y = writeIORef (wPos w) (x, y)++getCursorPos :: World -> IO (Double, Double)+getCursorPos w = readIORef (wPos w)++setCursorDir :: World -> Double -> IO ()+setCursorDir w d = writeIORef (wDir w) d++getCursorDir :: World -> IO Double+getCursorDir w = readIORef (wDir w)++setCursorSize :: World -> Double -> IO ()+setCursorSize w s = writeIORef (wSize w) s++setCursorShape ::+	World -> (World -> Double -> Double -> Double -> Double -> IO ()) -> IO ()+setCursorShape w s = writeIORef (wShape w) s++testModuleWorld :: IO ()+testModuleWorld = main++main :: IO ()+main = do+	putStrLn "module World"+	w <- openWorld+	withEvent w () $ \() ev ->+		case ev of+			ExposeEvent{} -> return ((), True)+			KeyEvent{} -> do+				ch <- eventToChar w ev+				return ((), ch /= 'q')+			ClientMessageEvent{} ->+				return ((), not $ isDeleteEvent w ev)+			_ -> error $ "not implemented for event " ++ show ev+	closeWorld w++openWorld :: IO World+openWorld = do+	dpy <- openDisplay ""+	del <- internAtom dpy "WM_DELETE_WINDOW" True+	let	scr = defaultScreen dpy+	root <- rootWindow dpy scr+	(_, _, _, width, height, _, _) <- getGeometry dpy root+	let	black = blackPixel dpy scr+		white = whitePixel dpy scr+	win <- createSimpleWindow dpy root 0 0 width height 1 black white+	bg <- createPixmap dpy root width height $ defaultDepth dpy scr+	buf <- createPixmap dpy root width height $ defaultDepth dpy scr+	gc <- createGC dpy win+	gc' <- createGC dpy win+	setForeground dpy gc' 0xffffff+	fillRectangle dpy bg gc' 0 0 width height+	fillRectangle dpy buf gc' 0 0 width height+	setWMProtocols dpy win [del]+	selectInput dpy win $ exposureMask .|. keyPressMask+	mapWindow dpy win+	flush dpy+	initPos <- newIORef undefined+	initDir <- newIORef undefined+	initSize <- newIORef undefined+	initShape <- newIORef undefined+	return $ World dpy win gc del bg buf initPos initDir initSize initShape++closeWorld :: World -> IO ()+closeWorld = closeDisplay . wDisplay++drawWorld :: World -> IO ()+drawWorld w = do+	(_, _, _, width, height, _, _) <- getGeometry (wDisplay w) (wWindow w)+	copyArea (wDisplay w) (wBG w) (wBuf w) (wGC w) 0 0 width height 0 0+	(x, y) <- readIORef $ wPos w+	d <- readIORef $ wDir w+	s <- readIORef $ wSize w+	displayCursor <- readIORef $ wShape w+	displayCursor w s d x y+	copyArea (wDisplay w) (wBuf w) (wWindow w) (wGC w) 0 0 width height 0 0++withEvent :: World -> s -> (s -> Event -> IO (s, Bool)) -> IO s+withEvent w stat0 act = doWhile stat0 $ \stat -> allocaXEvent $ \e -> do+	nextEvent (wDisplay w) e+	getEvent e >>= act stat++eventToChar :: World -> Event -> IO Char+eventToChar w ev =+	fmap (chr . fromEnum) $ keycodeToKeysym (wDisplay w) (ev_keycode ev) 0++isDeleteEvent :: World -> Event -> Bool+isDeleteEvent w ev@ClientMessageEvent{} = convert (head $ ev_data ev) == wDel w+isDeleteEvent _ _ = False++makeFilledPolygonCursor :: World -> [Point] -> IO ()+makeFilledPolygonCursor w ps =+	fillPolygon (wDisplay w) (wBuf w) (wGC w) ps nonconvex coordModeOrigin++lineToBG :: World -> Position -> Position -> Position -> Position -> IO ()+lineToBG w x1 y1 x2 y2 = drawLine (wDisplay w) (wBG w) (wGC w) x1 y1 x2 y2++cleanBG :: World -> IO ()+cleanBG w = do+	(_, _, _, width, height, _, _) <- getGeometry (wDisplay w) (wWindow w)+	gc <- createGC (wDisplay w) (wWindow w)+	setForeground (wDisplay w) gc 0xffffff+	fillRectangle (wDisplay w) (wBG w) gc 0 0 width height++flushWorld :: World -> IO ()+flushWorld = flush . wDisplay
+ xturtle.cabal view
@@ -0,0 +1,34 @@+build-type:	Simple+cabal-version:	>= 1.6++name:		xturtle+version:	0.0.1+stability:	experimental+author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp>+maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>++license:	BSD3+license-file:	LICENSE++category:	Teaching+synopsis:	turtle like LOGO+description:+  In ghci+  .+  > :m Graphics.X11.Turtle+  > initTurtle+  > forward 100+  > left 50+  .+  etc++source-repository	head+  type:		git+  location:	git://github.com/YoshikuniJujo/xturtle.git++library+  Hs-source-dirs:	src+  Exposed-modules:	Graphics.X11.Turtle+  Build-depends:	base > 3 && < 5, yjtools, convertible, X11+  Ghc-options:		-Wall+  Other-modules:	Graphics.X11.World