packages feed

xturtle 0.0.4 → 0.0.5

raw patch · 7 files changed

+435/−429 lines, 7 files

Files

− src/Graphics/X11/CharAndBG.hs 
@@ -1,340 +0,0 @@-module Graphics.X11.CharAndBG (-	Field,-	Turtle,-	openField,-	newTurtle,-	goto,-	rotate,-	direction,-	position,-	shape,-	shapesize,-	undo,-	clear,-	setUndoN,-	windowWidth,-	windowHeight,-	penup,-	pendown,-	isdown,--	testModuleCharAndBG-) where--import Graphics.X11.WindowLayers-import Control.Concurrent-import Data.IORef-import Control.Arrow-import Control.Monad--type Field = Win-type Turtle = Square--openField :: IO Field-openField = do-	w <- openWin-	flushWin w-	return w--newTurtle :: Field -> IO Turtle-newTurtle f = do-	s <- newSquare f-	showSquare s-	return s--goto :: Turtle -> Double -> Double -> IO ()-goto t x y = do-	(width, height) <- winSize (sWin t)-	moveSquare (sWin t) t (x + width / 2) (- y + height / 2)--rotate :: Turtle -> Double -> IO ()-rotate t = rotateSquare t . negate--direction :: Turtle -> IO Double-direction = fmap negate . readIORef . sDir--position :: Turtle -> IO (Double, Double)-position t = do-	(x_, y_) <- readIORef $ sPos t-	(width, height) <- winSize (sWin t)-	return (x_ - width / 2, - y_ + height / 2)--undo, undoGen :: Turtle -> IO ()-undoGen t = do-	rot : rots <- readIORef $ sRotHist t-	writeIORef (sRotHist t) rots-	d <- readIORef $ sDir t-	case rot of-		Just r -> rotateGen t (d - r) >> return ()-		Nothing -> undoSquare (sWin t) t--undo t = do-	n <- readIORef $ sUndoN t-	ns <- readIORef $ sUndoNs t-	case ns of-		n' : ns' -> do-			writeIORef (sUndoN t) n'-			writeIORef (sUndoNs t) ns'-		_ -> writeIORef (sUndoN t) 1-	print n-	replicateM_ n $ undoGen t--setUndoN :: Turtle -> Int -> IO ()-setUndoN t n = do-	n0 <- readIORef $ sUndoN t-	writeIORef (sUndoN t) n-	modifyIORef (sUndoNs t) (n0 :)--clear :: Turtle -> IO ()-clear Square{sWin = w, sLayer = l} = clearLayer w l--windowWidth, windowHeight :: Turtle -> IO Double-windowWidth = fmap fst . winSize . sWin-windowHeight = fmap snd . winSize . sWin--penup, pendown :: Turtle -> IO ()-penup = flip writeIORef False . sPenDown-pendown = flip writeIORef True . sPenDown--isdown :: Turtle -> IO Bool-isdown = readIORef . sPenDown--data Square = Square{-	sLayer :: Layer,-	sChar :: Character,-	sPos :: IORef (Double, Double),-	sHistory :: IORef [(Double, Double)],-	sSize :: IORef Double,-	sDir :: IORef Double,-	sShape :: IORef [(Double, Double)],-	sUndoN :: IORef Int,-	sUndoNs :: IORef [Int],-	sIsRotated :: IORef Bool,-	sRotHist :: IORef [Maybe Double],-	sPenDown :: IORef Bool,-	sWin :: Win- }--testModuleCharAndBG :: IO ()-testModuleCharAndBG = main--main :: IO ()-main = do-	w <- openWin-	s <- newSquare w-	s1 <- newSquare w-	shape s1 "turtle"-	shapesize s1 1-	moveSquare w s 100 105-	moveSquare w s1 200 30-	moveSquare w s 50 300-	moveSquare w s1 20 30-	moveSquare w s 300 300-	shapesize s1 2-	undoSquare w s-	moveSquare w s 300 400-	rotateSquare s1 0-	undoSquare w s-	moveSquare w s 300 200-	undoSquare w s-	undoSquare w s1-	undoSquare w s-	getLine >> return ()--newSquare :: Win -> IO Square-newSquare w = do-	l <- addLayer w-	c <- addCharacter w-	(width, height) <- winSize w-	p <- newIORef (width / 2, height / 2)-	h <- newIORef []-	sr <- newIORef 1-	dr <- newIORef 0-	rsh <- newIORef classic-	run <- newIORef 1-	runs <- newIORef []-	isr <- newIORef False-	srh <- newIORef []-	rpd <- newIORef True-	return Square{-		sLayer = l,-		sChar = c,-		sPos = p,-		sHistory = h,-		sSize = sr,-		sWin = w,-		sShape = rsh,-		sDir = dr,-		sUndoN = run,-		sUndoNs = runs,-		sIsRotated = isr,-		sRotHist = srh,-		sPenDown = rpd-	 }--shape :: Square -> String -> IO ()-shape s@Square{sShape = rsh} name =-	case name of-		"turtle" -> do-			writeIORef rsh turtle-			showSquare s-		"clasic" -> do-			writeIORef rsh classic-			showSquare s-		_ -> return ()--shapesize :: Square -> Double -> IO ()-shapesize s size = do-	writeIORef (sSize s) size-	p <- readIORef $ sPos s-	uncurry (moveSquare (sWin s) s) p--step :: Double-step = 10-stepTime :: Int-stepTime = 10000--stepDir :: Double-stepDir = 5-stepDirTime :: Int-stepDirTime = 10000--getPoints :: Double -> Double -> Double -> Double -> [(Double, Double)]-getPoints x1 y1 x2 y2 = let-	len = ((x2 - x1) ** 2 + (y2 - y1) ** 2) ** (1/2)-	dx = (x2 - x1) * step / len-	dy = (y2 - y1) * step / len in-	zip (takeWhile (before dx x2) [x1, x1 + dx ..])-		(takeWhile (before dy y2) [y1, y1 + dy ..]) ++-			[(x2, y2)]--before :: (Num a, Ord a) => a -> a -> a -> Bool-before d t x = signum d * t >= signum d * x--showAnimation :: Bool -> Win -> Square -> Double -> Double -> Double -> Double -> IO ()-showAnimation pd w s x1 y1 x2 y2 = do-	(size, d, sh) <- getSizeDirShape s-	if pd then setPolygonCharacterAndLine w (sChar s)-				(getShape sh size d x2 y2) (x1, y1) (x2, y2)-		else setPolygonCharacter w (sChar s) (getShape sh size d x2 y2)-	bufToWin w-	flushWin w--getSizeDirShape :: Square -> IO (Double, Double, [(Double, Double)])-getSizeDirShape s = do-	size <- readIORef (sSize s)-	d <- readIORef (sDir s)-	sh <- readIORef (sShape s)-	return (size, d, sh)--showSquare :: Square -> IO ()-showSquare s@Square{sWin = w} = do-	(x, y) <- readIORef $ sPos s-	(size, d, sh) <- getSizeDirShape s-	setPolygonCharacter w (sChar s) (getShape sh size d x y)-	bufToWin w-	flushWin w--moveSquare :: Win -> Square -> Double -> Double -> IO ()-moveSquare w s@Square{sPos = p} x2 y2 = do-	modifyIORef (sRotHist s) (Nothing :)-	writeIORef (sIsRotated s) False-	(x1, y1) <- readIORef p-	modifyIORef (sHistory s) ((x1, y1) :)-	pd <- readIORef $ sPenDown s-	mapM_ (\(x, y) -> showAnimation pd w s x1 y1 x y >> threadDelay stepTime) $-		getPoints x1 y1 x2 y2-	writeIORef p (x2, y2)-	when pd $ line w (sLayer s) x1 y1 x2 y2-{--	setPolygonCharacter w (sChar s)-		[(x2, y2), (x2 + 10, y2), (x2 + 10, y2 + 10), (x2, y2 + 10)]--}--getDirections :: Double -> Double -> [Double]-getDirections ds de = takeWhile beforeDir [ds, ds + dd ..] ++ [de]-	where-	sig = signum (de - ds)-	dd = sig * stepDir-	beforeDir x = sig * x < sig * de--setDirSquare :: Square -> Double -> IO ()-setDirSquare s@Square{sDir = dr} d = do-	writeIORef dr d-	showSquare s--rotateSquare :: Square -> Double -> IO ()-rotateSquare s d = do-	d0 <- rotateGen s d-	modifyIORef (sRotHist s) (Just (d - d0) :)-rotateGen :: Square -> Double -> IO Double-rotateGen s@Square{sDir = dr} d = do-	d0 <- readIORef dr-	mapM_ ((>> threadDelay stepDirTime) . setDirSquare s) $ getDirections d0 d-	writeIORef dr (d `modd` 360)-	return d0--modd :: (Num a, Ord a) => a -> a -> a-modd x y-	| x < 0 = modd (x + y) y-	| x < y = x-	| otherwise = modd (x - y) y--undoSquare :: Win -> Square -> IO ()-undoSquare w s@Square{sLayer = l} = do-	undoLayer w l-	(x1, y1) <- readIORef $ sPos s-	p@(x2, y2) : ps <- readIORef $ sHistory s---	moveSquare w s x y---	showAnimation w s x1 y1 x y-	mapM_ (\(x, y) -> showAnimation True w s x2 y2 x y >> threadDelay 50000) $-		getPoints x1 y1 x2 y2-	writeIORef (sPos s) p-	writeIORef (sHistory s) ps--getShape ::-	[(Double, Double)] -> Double -> Double -> Double -> Double -> [(Double, Double)]-getShape sh s d x y =-	map (uncurry (addDoubles (x, y)) . rotatePointD d . mulPoint s) sh--classic :: [(Double, Double)]-classic = clssc ++ reverse (map (second negate) clssc)-	where-	clssc = [-		(- 10, 0),-		(- 16, 6),-		(0, 0)-	 ]--turtle :: [(Double, Double)]-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)-	 ]--addDoubles :: (Double, Double) -> Double -> Double -> (Double, Double)-addDoubles (x, y) dx dy = (x + dx, y + dy)--rotatePointD :: Double -> (Double, Double) -> (Double, Double)-rotatePointD = rotatePointR . (* pi) . (/ 180)--rotatePointR :: Double -> (Double, Double) -> (Double, Double)-rotatePointR rad (x, y) =-	(x * cos rad - y * sin rad, x * sin rad + y * cos rad)--mulPoint :: Double -> (Double, Double) -> (Double, Double)-mulPoint s (x, y) = (x * s, y * s)-
src/Graphics/X11/Turtle.hs view
@@ -1,63 +1,187 @@ module Graphics.X11.Turtle ( 	Turtle,+ 	openField, 	newTurtle, 	shape, 	shapesize, 	forward, 	backward,-	circle,-	undo, 	left, 	right,-	clear, 	home,-	pendown,+	clear,+	circle,+	undo,+	position,+	distance,+	windowWidth,+	windowHeight,+	goto, 	penup,-	isdown,-	distance+	pendown,+	isdown ) where -import Graphics.X11.CharAndBG+import Graphics.X11.TurtleDraw+import Graphics.X11.TurtleInput+import Control.Concurrent import Control.Monad+import Prelude hiding(Left)+import Data.IORef+import Control.Arrow(second) -forward, backward, forwardNotSetUndo :: Turtle -> Double -> IO ()-forward t dist = do-	setUndoN t 1-	forwardNotSetUndo t dist+data Turtle = Turtle {+	inputChan :: Chan TurtleInput,+	field :: Field,+	layer :: Layer,+	character :: Character,+	states :: [TurtleState],+	stateNow :: IORef Int+ } -forwardNotSetUndo t dist = do-	dir <- direction t-	(x0, y0) <- position t-	let	xd = dist * cos (dir * pi / 180)-		yd = dist * sin (dir * pi / 180)-	goto t (x0 + xd) (y0 + yd)+newTurtle :: Field -> IO Turtle+newTurtle f = do+	ch <- addCharacter f+	l <- addLayer f+	(c, ret) <- makeInput+	sn <- newIORef 1+	let	sts = drop 4 $ inputToTurtle [] initialTurtleState ret+		t = Turtle {+			inputChan = c,+			field = f,+			layer = l,+			character = ch,+			states = sts,+			stateNow = sn+		 }+	writeChan c $ Shape classic+	writeChan c $ ShapeSize 1+	writeChan c PenDown+	writeChan c $ Goto 0 0+	writeChan c $ RotateTo 0+	writeChan c $ Goto 0 0+	_ <- forkIO $+--		initialThread+		for2M_ sts $ turtleDraw f ch l+	return t +shape :: Turtle -> String -> IO ()+shape Turtle{inputChan = c, stateNow = sn} "turtle" = do+	modifyIORef sn (+ 1)+	writeChan c $ Shape turtle+shape Turtle{inputChan = c, stateNow = sn} "classic" = do+	modifyIORef sn (+ 1)+	writeChan c $ Shape classic+shape _ name = error $ "There is no shape named " ++ name +shapesize :: Turtle -> Double -> IO ()+shapesize Turtle{inputChan = c, stateNow = sn} size = do+	modifyIORef sn (+ 1)+	writeChan c $ ShapeSize size++forward, backward :: Turtle -> Double -> IO ()+forward Turtle{inputChan = c, stateNow = sn} len = do+	modifyIORef sn (+1)+	writeChan c $ Forward len+	threadDelay 10000 backward t = forward t . negate  left, right :: Turtle -> Double -> IO ()-left t dd = do-	dir <- direction t-	rotate t (dir + dd)-+left Turtle{inputChan = c, stateNow = sn} dd = do+	modifyIORef sn (+ 1)+	writeChan c $ Left dd+	threadDelay 10000 right t = left t . negate  circle :: Turtle -> Double -> IO ()-circle t r = do-	setUndoN t 73-	forwardNotSetUndo t (r * pi / 36)+circle t@Turtle{inputChan = c, stateNow = sn} r = do+	forward t (r * pi / 36) 	left t 10-	replicateM_ 35 $ forwardNotSetUndo t (2 * r * pi / 36) >>-		left t 10-	forwardNotSetUndo t (r * pi / 36)+	replicateM_ 35 $ forward t (2 * r * pi / 36) >> left t 10+	forward t (r * pi / 36)+	writeChan c $ SetUndoNum 74+	modifyIORef sn (+ 1)  home :: Turtle -> IO ()-home t = do-	goto t 0 0-	rotate t 0+home t = modifyIORef (stateNow t) (+ 1) >> goto t 0 0 >> rotateTo t 0 +clear :: Turtle -> IO ()+clear t@Turtle{field = f, layer = l} = do+	forward t 0+	clearLayer f l++position :: Turtle -> IO (Double, Double)+position Turtle{stateNow = sn, states = s} =+	fmap (turtlePos . (s !!)) $ readIORef sn+ distance :: Turtle -> Double -> Double -> IO Double distance t x0 y0 = do 	(x, y) <- position t 	return $ ((x - x0) ** 2 + (y - y0) ** 2) ** (1 / 2)++windowWidth, windowHeight :: Turtle -> IO Double+windowWidth = fmap fst . winSize . field+windowHeight = fmap snd . winSize . field++pendown, penup :: Turtle -> IO ()+pendown Turtle{inputChan = c, stateNow = sn} = do+	modifyIORef sn (+ 1)+	writeChan c PenDown+penup Turtle{inputChan = c, stateNow = sn} = do+	modifyIORef sn (+ 1)+	writeChan c PenUp++isdown :: Turtle -> IO Bool+isdown Turtle{states = s, stateNow = sn} =+	fmap (turtlePenDown . (s !!)) $ readIORef sn++goto :: Turtle -> Double -> Double -> IO ()+goto Turtle{inputChan = c, stateNow = sn} x y = do+	modifyIORef sn (+ 1)+	writeChan c $ Goto x y++rotateTo :: Turtle -> Double -> IO ()+rotateTo Turtle{inputChan = c} d = writeChan c $ RotateTo d++undo :: Turtle -> IO ()+undo t@Turtle{inputChan = c, stateNow = sn} = do+	un <- getUndoNum t+	replicateM_ un $ do+		modifyIORef sn (+1)+		writeChan c Undo++getUndoNum :: Turtle -> IO Int+getUndoNum Turtle{states = s, stateNow = sn} =+	fmap (turtleUndoNum . (s!!)) $ readIORef sn++for2M_ :: [a] -> (a -> a -> IO b) -> IO ()+for2M_ xs f = zipWithM_ f xs $ tail xs++classic :: [(Double, Double)]+classic = clssc ++ reverse (map (second negate) clssc)+	where+	clssc = [+		(- 10, 0),+		(- 16, 6),+		(0, 0)+	 ]++turtle :: [(Double, Double)]+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/TurtleDraw.hs view
@@ -0,0 +1,115 @@+module Graphics.X11.TurtleDraw (+	Field,+	Layer,+	Character,++	openField,+	addLayer,+	addCharacter,+	clearLayer,+	turtleDraw,++	winSize+) where++import Graphics.X11.TurtleState+import Control.Concurrent+import Control.Monad++import Graphics.X11.WindowLayers++turtleDraw, turtleDrawNotUndo, turtleDrawUndo ::+	Field -> Character -> Layer -> TurtleState -> TurtleState -> IO ()+turtleDraw f c l t0 t1 = do+	let	isUndo = turtleUndo t1+	if isUndo then turtleDrawUndo f c l t0 t1+		else turtleDrawNotUndo f c l t0 t1+turtleDrawUndo f c l t0 t1 = do+	let	shape = turtleShape t1+		size = turtleSize t1+		prePos@(px, py) = turtlePos t0+		preDir = turtleDir t0+		pen = turtlePenDown t1+		pos@(nx, ny) = turtlePos t1+		dir = turtleDir t1+--		doneLine = turtleLineDone t0+--	when doneLine $ undoLayer f l+	when pen $ undoLayer f l+	forM_ (getDirections preDir dir) $ \d -> do+		drawTurtle f c shape size d prePos Nothing+		threadDelay 10000+	if pen then forM_ (getPoints px py nx ny) $ \p -> do+			drawTurtle f c shape size dir p $ Just pos+			threadDelay 50000+		else forM_ (getPoints px py nx ny) $ \p -> do+			drawTurtle f c shape size dir p Nothing+			threadDelay 50000+turtleDrawNotUndo f c l t0 t1 = do+	let	shape = turtleShape t1+		size = turtleSize t1+		prePos@(px, py) = turtlePos t0+		prePen = turtlePenDown t0+		preDir = turtleDir t0+		(nx, ny) = turtlePos t1+		dir = turtleDir t1+	forM_ (getDirections preDir dir) $ \d ->+		drawTurtle f c shape size d prePos Nothing+	if prePen then do+			forM_ (getPoints px py nx ny) $ \p -> do+				drawTurtle f c shape size dir p $ Just prePos+				threadDelay 50000+			line f l px py nx ny+		else forM_ (getPoints px py nx ny) $ \p -> do+			drawTurtle f c shape size dir p Nothing+			threadDelay 50000++step :: Double+step = 10+stepDir :: Double+stepDir = 5++getPoints :: Double -> Double -> Double -> Double -> [(Double, Double)]+getPoints x1 y1 x2 y2 = let+        len = ((x2 - x1) ** 2 + (y2 - y1) ** 2) ** (1/2)+        dx = (x2 - x1) * step / len+        dy = (y2 - y1) * step / len in+        zip (takeWhile (before dx x2) [x1, x1 + dx ..])+                (takeWhile (before dy y2) [y1, y1 + dy ..]) +++                        [(x2, y2)]++before :: (Num a, Ord a) => a -> a -> a -> Bool+before d t x = signum d * t >= signum d * x++getDirections :: Double -> Double -> [Double]+getDirections ds de = takeWhile beforeDir [ds, ds + dd ..] ++ [de]+        where+        sig = signum (de - ds)+        dd = sig * stepDir+        beforeDir x = sig * x < sig * de++drawTurtle :: Field -> Character -> [(Double, Double)] -> Double -> Double ->+	(Double, Double) -> Maybe (Double, Double) -> IO ()+drawTurtle w c sh s d (x, y) org = do+	let sp = mkShape sh s d x y+	maybe (setPolygonCharacter w c sp)+		(flip (setPolygonCharacterAndLine w c sp) (x, y)) org+	bufToWin w+	flushWin w++mkShape ::+	[(Double, Double)] -> Double -> Double -> Double -> Double -> [(Double, Double)]+mkShape sh s d x y =+	map (uncurry (addDoubles (x, y)) . rotatePointD d . mulPoint s) sh++addDoubles :: (Double, Double) -> Double -> Double -> (Double, Double)+addDoubles (x, y) dx dy = (x + dx, y + dy)++rotatePointD :: Double -> (Double, Double) -> (Double, Double)+rotatePointD = rotatePointR . (* pi) . (/ 180)++rotatePointR :: Double -> (Double, Double) -> (Double, Double)+rotatePointR rad (x, y) =+	(x * cos rad - y * sin rad, x * sin rad + y * cos rad)++mulPoint :: Double -> (Double, Double) -> (Double, Double)+mulPoint s (x, y) = (x * s, y * s)
+ src/Graphics/X11/TurtleInput.hs view
@@ -0,0 +1,79 @@+module Graphics.X11.TurtleInput (+	TurtleState(turtlePos, turtleUndoNum, turtlePenDown),++	makeInput,+	inputToTurtle,+	TurtleInput(..),+	initialTurtleState+) where++import Control.Concurrent+import System.IO.Unsafe+import Graphics.X11.TurtleState+import Prelude hiding (Left)++data TurtleInput+	= Shape [(Double, Double)]+	| ShapeSize Double+	| Goto Double Double+	| RotateTo Double+	| PenUp+	| PenDown+	| Undo+	| Forward Double+	| Left Double+	| SetUndoNum Int+	deriving Show++makeInput :: IO (Chan TurtleInput, [TurtleInput])+makeInput = do+	c <- newChan+	ret <- getInput c+	return (c, ret)++getInput :: Chan TurtleInput -> IO [TurtleInput]+getInput c = unsafeInterleaveIO $ do+	ti <- readChan c+	tis <- getInput c+	return $ ti : tis++nextTurtle :: TurtleState -> TurtleState+nextTurtle t = TurtleState{+	turtleShape = turtleShape t,+	turtleSize = turtleSize t,+	turtlePos = turtlePos t,+	turtleDir = turtleDir t,+	turtlePenDown = turtlePenDown t,+	turtleUndo = False,+	turtleUndoNum = 1+ }++inputToTurtleNext :: [TurtleState] -> TurtleState -> [TurtleInput] -> [TurtleState]+inputToTurtleNext tsbs nts ti = nts : inputToTurtle tsbs nts ti++inputToTurtle :: [TurtleState] -> TurtleState -> [TurtleInput] -> [TurtleState]+inputToTurtle (tsb : tsbs) _ (Undo : ti) =+	tsb{turtleUndo = True } : inputToTurtle tsbs tsb{turtleUndo = True} ti+inputToTurtle tsbs ts0 (Shape sh : ti) =+	inputToTurtleNext (ts0 : tsbs) (nextTurtle ts0){turtleShape = sh} ti+inputToTurtle tsbs ts0 (ShapeSize ss : ti) =+	inputToTurtleNext (ts0 : tsbs) (nextTurtle ts0){turtleSize = ss} ti+inputToTurtle tsbs ts0 (Goto x y : ti) =+	inputToTurtleNext (ts0 : tsbs) (nextTurtle ts0){turtlePos = (x, y)} ti+inputToTurtle tsbs ts0 (RotateTo d : ti) =+	inputToTurtleNext (ts0 : tsbs) (nextTurtle ts0){turtleDir = d} ti+inputToTurtle tsbs ts0 (PenDown : ti) =+	inputToTurtleNext (ts0 : tsbs) (nextTurtle ts0){turtlePenDown = True} ti+inputToTurtle tsbs ts0 (PenUp : ti) =+	inputToTurtleNext (ts0 : tsbs) (nextTurtle ts0){turtlePenDown = False} ti+inputToTurtle tsbs ts0 (SetUndoNum un : ti) =+	inputToTurtleNext (ts0 : tsbs) (nextTurtle ts0){turtleUndoNum = un} ti+inputToTurtle tsbs ts0 (Forward len : ti) = let+	(x0, y0) = turtlePos ts0+	dir = turtleDir ts0+	x = x0 + len * cos (dir * pi / 180)+	y = y0 + len * sin (dir * pi / 180) in+	inputToTurtle tsbs ts0 (Goto x y : ti)+inputToTurtle tsbs ts0 (Left dd : ti) =+	inputToTurtle tsbs ts0 $ RotateTo (turtleDir ts0 + dd) : ti+inputToTurtle _ _ _ = error "bad condition in inputToTurtle"
+ src/Graphics/X11/TurtleState.hs view
@@ -0,0 +1,28 @@+module Graphics.X11.TurtleState (+	TurtleState(..),+	initialTurtleState,+) where++data TurtleState = TurtleState {+	turtleShape :: [(Double, Double)],+	turtleSize :: Double,+	turtlePos :: (Double, Double),+	turtleDir :: Double,+	turtlePenDown :: Bool,+	turtleUndo :: Bool,+	turtleUndoNum :: Int+ } deriving Show++initialTurtleState :: TurtleState+initialTurtleState = TurtleState {+	turtleShape = isUndefined "turtleShape",+	turtleSize = isUndefined "turtleSize",+	turtlePos = isUndefined "turtlePos",+	turtleDir = isUndefined "turtleDir",+	turtlePenDown = isUndefined "turtlePenDown",+	turtleUndo = False,+	turtleUndoNum = 1+ }++isUndefined :: String -> a+isUndefined name = error $ name ++ " is undefined"
src/Graphics/X11/WindowLayers.hs view
@@ -1,38 +1,23 @@ module Graphics.X11.WindowLayers (-	Win,-	openWin,+	Field,+	Layer,+	Character,++	openField,+	closeField,+	bufToWin, 	flushWin, 	winSize, -	clearUndoBuf,---	lineUndoBuf,-	clearBG,-	fillPolygonBuf,+	addLayer,+	addCharacter, ---	lineWin,-	changeColor,-	putSome, 	line,--	undoBufToBG,-	bgToBuf,-	bufToWin,--	addExposeAction,-	setExposeAction,-	setCharacterAction,-	setCharacter, 	setPolygonCharacter, 	setPolygonCharacterAndLine,---	undoAction,-	addLayer,-	addCharacter,  	undoLayer, 	clearLayer,--	Layer,-	Character, ) where  import Graphics.X11(@@ -78,6 +63,14 @@ data Layer = Layer Int data Character = Character Int +type Field = Win++openField :: IO Field+openField = openWin++closeField :: Field -> IO ()+closeField = closeDisplay . wDisplay+ openWin :: IO Win openWin = do 	_ <- initThreads@@ -116,6 +109,10 @@ 					getGeometry (wDisplay w) (wWindow w) 				writeIORef (wWidth w) width 				writeIORef (wHeight w) height+--				clearBG w+				clearUndoBuf w+				readIORef buffedAction >>= sequence_+				undoBufToBG w 				readIORef exposeAction >>= mapM_ ($ False) . concat 				readIORef charActions >>= sequence_ 				bufToWin w@@ -125,6 +122,7 @@ 			ClientMessageEvent{} -> 				return $ not $ isDeleteEvent w ev 			_ -> return True+	flushWin w 	return w 	where 	withEvent w act = doWhile_ $ allocaXEvent $ \e -> do@@ -135,7 +133,7 @@ 	isDeleteEvent _ _ = False  undoN :: Int-undoN = 300+undoN = 100  clearLayer :: Win -> Layer -> IO () clearLayer w l@(Layer lid) = do@@ -209,15 +207,6 @@ 	modifyIORef wc (++ [return ()]) 	return $ Character $ length cs -{--undoAction :: Win -> Layer -> IO ()-undoAction w@Win{wExpose = we} (Layer lid) = do-	clearWin w-	modifyIORef we init-	readIORef we >>= sequence_-	flushWin w--}- winSize :: Win -> IO (Double, Double) winSize w = fmap (fromIntegral *** fromIntegral) $ winSizeRaw w @@ -243,10 +232,10 @@ 	copyArea (wDisplay w) (wBuf w) (wWindow w) (wGC w) 0 0 width height 0 0  fillPolygonBuf :: Win -> [(Double, Double)] -> IO ()-fillPolygonBuf w ps = fillPolygon (wDisplay w) (wBuf w) (wGC w) (map dtp ps)-						nonconvex coordModeOrigin-	where-	dtp (x, y) = Point (round x) (round y)+fillPolygonBuf w ps = do+	(width, height) <- winSize w+	let	dtp (x, y) = Point (round $ x + width / 2) (round $ - y + height / 2)+	fillPolygon (wDisplay w) (wBuf w) (wGC w) (map dtp ps) nonconvex coordModeOrigin  setPolygonCharacter :: Win -> Character -> [(Double, Double)] -> IO () setPolygonCharacter w c ps = setCharacter w c (fillPolygonBuf w ps)@@ -254,23 +243,28 @@ setPolygonCharacterAndLine :: 	Win -> Character -> [(Double, Double)] -> (Double, Double) -> 		(Double, Double) -> IO ()-setPolygonCharacterAndLine w c ps (x1, y1) (x2, y2) =-	setCharacter w c (fillPolygonBuf w ps >> lineBuf w x1 y1 x2 y2)--putSome :: Win -> (Double, Double) -> IO ()-putSome w (x, y) = do-	bgToBuf w-	fillPolygonBuf w [(x, y), (x + 10, y), (x + 10, y + 10), (x, y + 10)]-	bufToWin w-	flushWin w+setPolygonCharacterAndLine w c ps (x1_, y1_) (x2_, y2_) =+	setCharacter w c (fillPolygonBuf w ps >> lineBuf w x1_ y1_ x2_ y2_)  line :: Win -> Layer -> Double -> Double -> Double -> Double -> IO ()-line w l x1 y1 x2 y2 = do+line w l x1_ y1_ x2_ y2_ = do+	(width, height) <- winSize w+	let	x1 = x1_ + (width / 2)+		x2 = x2_ + (width / 2)+		y1 = - y1_ + (height / 2)+		y2 = - y2_ + (height / 2) 	lineWin w x1 y1 x2 y2-	addExposeAction w l $ \w' buf -> if buf-		then lineUndoBuf w' x1 y1 x2 y2-		else lineWin w' x1 y1 x2 y2+	addExposeAction w l $ \w' buf -> do+		(x1', y1') <- convertPos w' x1_ y1_+		(x2', y2') <- convertPos w' x2_ y2_+		if buf	then lineUndoBuf w' x1' y1' x2' y2'+			else lineWin w' x1' y1' x2' y2' +convertPos :: Win -> Double -> Double -> IO (Double, Double)+convertPos w x y = do+	(width, height) <- winSize w+	return (x + width / 2, - y + height / 2)+ lineWin :: Win -> Double -> Double -> Double -> Double -> IO () lineWin w x1_ y1_ x2_ y2_ = do 	drawLine (wDisplay w) (wBG w) (wGC w) x1 y1 x2 y2@@ -285,14 +279,12 @@ 	where	[x1, y1, x2, y2] = map round [x1_, y1_, x2_, y2_]  lineBuf :: Win -> Double -> Double -> Double -> Double -> IO ()-lineBuf w x1_ y1_ x2_ y2_ =+lineBuf w x1__ y1__ x2__ y2__ = do+	(x1_, y1_) <- convertPos w x1__ y1__+	(x2_, y2_) <- convertPos w x2__ y2__+	let	[x1, y1, x2, y2] = map round [x1_, y1_, x2_, y2_] 	drawLine (wDisplay w) (wBuf w) (wGC w) x1 y1 x2 y2-	where	[x1, y1, x2, y2] = map round [x1_, y1_, x2_, y2_] -clearBG :: Win -> IO ()-clearBG w = winSizeRaw w >>=-	uncurry (fillRectangle (wDisplay w) (wBG w) (wGCWhite w) 0 0)- clearUndoBuf :: Win -> IO () clearUndoBuf w = winSizeRaw w >>= 	uncurry (fillRectangle (wDisplay w) (wUndoBuf w) (wGCWhite w) 0 0)@@ -300,5 +292,11 @@ flushWin :: Win -> IO () flushWin = flush . wDisplay +{- changeColor :: Win -> Pixel -> IO () changeColor w = setForeground (wDisplay w) (wGC w)++clearBG :: Win -> IO ()+clearBG w = winSizeRaw w >>=+	uncurry (fillRectangle (wDisplay w) (wBG w) (wGCWhite w) 0 0)+-}
xturtle.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.6  name:		xturtle-version:	0.0.4+version:	0.0.5 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -32,4 +32,6 @@   Exposed-modules:	Graphics.X11.Turtle   Build-depends:	base > 3 && < 5, yjtools, convertible, X11   Ghc-options:		-Wall-  Other-modules:	Graphics.X11.WindowLayers, Graphics.X11.CharAndBG+  Other-modules:	Graphics.X11.WindowLayers,+    Graphics.X11.TurtleInput,+    Graphics.X11.TurtleDraw, Graphics.X11.TurtleState