packages feed

xturtle 0.0.6 → 0.0.7

raw patch · 6 files changed

+259/−339 lines, 6 filesdep ~yjtools

Dependency ranges changed: yjtools

Files

src/Graphics/X11/Turtle.hs view
@@ -36,7 +36,7 @@ import Control.Arrow(second)  xturtleVersion :: (Int, String)-xturtleVersion = (1, "0.0.5b")+xturtleVersion = (1, "0.0.7")  data Turtle = Turtle { 	inputChan :: Chan TurtleInput,@@ -50,73 +50,59 @@ newTurtle f = do 	ch <- addCharacter f 	l <- addLayer f-	(c, ret) <- makeInput+	(c, sts) <- getTurtleStates classic 	sn <- newIORef 1-	let	sts = drop 4 $ inputToTurtle [] initialTurtleState ret-		t = Turtle {+	let	t = Turtle { 			inputChan = c, 			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 	_ <- forkIOX $ for2M_ sts $ turtleDraw 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+sendCommand :: Turtle -> TurtleInput -> IO ()+sendCommand Turtle{inputChan = c, stateNow = sn} ti = do 	modifyIORef sn (+ 1)-	writeChan c $ Shape classic+	writeChan c ti+	threadDelay 10000++shape :: Turtle -> String -> IO ()+shape t "turtle" = sendCommand t $ Shape turtle+shape t "classic" = sendCommand t $ 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+shapesize t = sendCommand t . ShapeSize  forward, backward :: Turtle -> Double -> IO ()-forward Turtle{inputChan = c, stateNow = sn} len = do-	modifyIORef sn (+1)-	writeChan c $ Forward len-	threadDelay 10000+forward t = sendCommand t . Forward backward t = forward t . negate  left, right :: Turtle -> Double -> IO ()-left Turtle{inputChan = c, stateNow = sn} dd = do-	modifyIORef sn (+ 1)-	writeChan c $ Left dd-	threadDelay 10000+left t = sendCommand t . Left right t = left t . negate  circle :: Turtle -> Double -> IO ()-circle t@Turtle{inputChan = c, stateNow = sn} r = do+circle t r = do 	forward t (r * pi / 36) 	left t 10 	replicateM_ 35 $ forward t (2 * r * pi / 36) >> left t 10 	forward t (r * pi / 36)-	writeChan c $ SetUndoNum 74-	modifyIORef sn (+ 1)+	sendCommand t $ Undonum 74  home :: Turtle -> IO ()-home t = modifyIORef (stateNow t) (+ 1) >> goto t 0 0 >> rotateTo t 0+home t = goto t 0 0 >> rotate t 0  clear :: Turtle -> IO () clear t@Turtle{layer = l} = do-	forward t 0+	left t 0 	clearLayer l  position :: Turtle -> IO (Double, Double) position Turtle{stateNow = sn, states = s} =-	fmap (turtlePos . (s !!)) $ readIORef sn+	fmap (getPosition . (s !!)) $ readIORef sn  distance :: Turtle -> Double -> Double -> IO Double distance t x0 y0 = do@@ -128,35 +114,27 @@ windowHeight = fmap snd . layerSize . layer  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+pendown = flip sendCommand Pendown+penup = flip sendCommand Penup  isdown :: Turtle -> IO Bool isdown Turtle{states = s, stateNow = sn} =-	fmap (turtlePenDown . (s !!)) $ readIORef sn+	fmap (getPendown . (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+goto t x y = sendCommand t $ Goto x y -rotateTo :: Turtle -> Double -> IO ()-rotateTo Turtle{inputChan = c} d = writeChan c $ RotateTo d+rotate :: Turtle -> Double -> IO ()+rotate t = sendCommand t . Rotate  undo :: Turtle -> IO ()-undo t@Turtle{inputChan = c, stateNow = sn} = do+undo t = do 	un <- getUndoNum t-	replicateM_ un $ do-		modifyIORef sn (+1)-		writeChan c Undo+	replicateM_ un $ sendCommand t Undo  getUndoNum :: Turtle -> IO Int getUndoNum Turtle{states = s, stateNow = sn} =-	fmap (turtleUndoNum . (s!!)) $ readIORef sn+	fmap (undonum . (s!!)) $ readIORef sn  for2M_ :: [a] -> (a -> a -> IO b) -> IO () for2M_ xs f = zipWithM_ f xs $ tail xs
src/Graphics/X11/TurtleDraw.hs view
@@ -3,112 +3,88 @@ 	Layer, 	Character, +	forkIOX, 	openField, 	addLayer, 	addCharacter,-	clearLayer,+	layerSize,+ 	turtleDraw, -	layerSize,-	forkIOX+	clearLayer ) where -import Graphics.X11.TurtleState-import Control.Concurrent-import Control.Monad--import Graphics.X11.WindowLayers+import Graphics.X11.TurtleState(TurtleState(..))+import Graphics.X11.WindowLayers(+	Field, Layer, Character,+	forkIOX, openField, addLayer, addCharacter, layerSize, clearLayer,+	drawLine, drawCharacter, drawCharacterAndLine, undoLayer+ ) -turtleDraw, turtleDrawNotUndo, turtleDrawUndo ::-	Character -> Layer -> TurtleState -> TurtleState -> IO ()-turtleDraw c l t0 t1 = do-	let	isUndo = turtleUndo t1-	if isUndo then turtleDrawUndo c l t0 t1-		else turtleDrawNotUndo c l t0 t1-turtleDrawUndo 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 l-	forM_ (getDirections preDir dir) $ \d -> do-		drawTurtle c shape size d prePos Nothing-		threadDelay 10000-	if pen then forM_ (getPoints px py nx ny) $ \p -> do-			drawTurtle c shape size dir p $ Just pos-			threadDelay 50000-		else forM_ (getPoints px py nx ny) $ \p -> do-			drawTurtle c shape size dir p Nothing-			threadDelay 50000-turtleDrawNotUndo 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 c shape size d prePos Nothing-	if prePen then do-			forM_ (getPoints px py nx ny) $ \p -> do-				drawTurtle c shape size dir p $ Just prePos-				threadDelay 50000-			drawLine l px py nx ny-		else forM_ (getPoints px py nx ny) $ \p -> do-			drawTurtle c shape size dir p Nothing-			threadDelay 50000+import Control.Concurrent(threadDelay)+import Control.Monad(when, forM_)+import Control.Arrow((***))  step :: Double step = 10++moveSpeed :: Int+moveSpeed = 50000+ 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)]+rotateSpeed :: Int+rotateSpeed = 10000 -before :: (Num a, Ord a) => a -> a -> a -> Bool-before d t x = signum d * t >= signum d * x+turtleDraw, turtleDrawNotUndo, turtleDrawUndo ::+	Character -> Layer -> TurtleState -> TurtleState -> IO ()+turtleDraw c l t0 t1 = if undo t1+	then turtleDrawUndo c l t0 t1+	else turtleDrawNotUndo c l t0 t1+turtleDrawUndo c l t0 t1 = do+	let	p0@(x0, y0) = position t0+		p1@(x1, y1) = position t1+		lineOrigin = if line t0 then Just p1 else Nothing+	when (line t0) $ undoLayer l+	forM_ (getDirections (direction t0) (direction t1)) $ \d -> do+		drawTurtle c (shape t1) (size t1) d p0 Nothing+		threadDelay rotateSpeed+	forM_ (getPoints x0 y0 x1 y1) $ \p -> do+		drawTurtle c (shape t1) (size t1) (direction t1) p lineOrigin+		threadDelay moveSpeed+	drawTurtle c (shape t1) (size t1) (direction t1) p1 lineOrigin+turtleDrawNotUndo c l t0 t1 = do+	let	p0@(x0, y0) = position t0+		p1@(x1, y1) = position t1+		lineOrigin = if line t1 then Just p0 else Nothing+	forM_ (getDirections (direction t0) (direction t1)) $ \d -> do+		drawTurtle c (shape t1) (size t1) d p0 Nothing+		threadDelay rotateSpeed+	forM_ (getPoints x0 y0 x1 y1) $ \p -> do+		drawTurtle c (shape t1) (size t1) (direction t1) p lineOrigin+		threadDelay moveSpeed+	drawTurtle c (shape t1) (size t1) (direction t1) p1 lineOrigin+	when (line t1) $ drawLine l x0 y0 x1 y1 +getPoints :: Double -> Double -> Double -> Double -> [(Double, Double)]+getPoints x1 y1 x2 y2 = zip [x1, x1 + dx .. x2 - dx] [y1, y1 + dy .. y2 - dy]+	where+	len = ((x2 - x1) ** 2 + (y2 - y1) ** 2) ** (1/2)+	dx = (x2 - x1) * step / len+	dy = (y2 - y1) * step / len+ 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+getDirections ds de = [ds, ds + dd .. de - dd]+	where+	dd = if de > ds then stepDir else - stepDir  drawTurtle :: Character -> [(Double, Double)] -> Double -> Double -> 	(Double, Double) -> Maybe (Double, Double) -> IO ()-drawTurtle c sh s d (x, y) org = do-	let sp = mkShape sh s d x y+drawTurtle c sh s d (px, py) org = do+	let sp = map (((+ px) *** (+ py)) . rotatePoint . ((* s) *** (* s))) sh 	maybe (drawCharacter c sp)-		(flip (drawCharacterAndLine c sp) (x, y)) org--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)+		(\(x0, y0) -> (drawCharacterAndLine c sp x0 y0 px py)) org+	where+	rotatePoint (x, y) = let rad = d * pi / 180 in+		(x * cos rad - y * sin rad, x * sin rad + y * cos rad)
src/Graphics/X11/TurtleInput.hs view
@@ -1,72 +1,73 @@ module Graphics.X11.TurtleInput (-	TurtleState(turtlePos, turtleUndoNum, turtlePenDown),--	makeInput,-	inputToTurtle,+	TurtleState, 	TurtleInput(..),-	initialTurtleState++	getTurtleStates,+	getPosition,+	getPendown,+	undonum ) where -import Control.Concurrent-import Graphics.X11.TurtleState-import Prelude hiding (Left)+import Graphics.X11.TurtleState(TurtleState(..), initialTurtleState)+import Control.Concurrent.Chan(Chan, newChan, getChanContents)+import Prelude hiding(Left) +getPosition :: TurtleState -> (Double, Double)+getPosition = position++getPendown :: TurtleState -> Bool+getPendown = pendown+ data TurtleInput 	= Shape [(Double, Double)] 	| ShapeSize Double 	| Goto Double Double-	| RotateTo Double-	| PenUp-	| PenDown+	| Rotate Double+	| Penup+	| Pendown 	| Undo 	| Forward Double 	| Left Double-	| SetUndoNum Int+	| Undonum Int 	deriving Show +getTurtleStates :: [(Double, Double)] -> IO (Chan TurtleInput, [TurtleState])+getTurtleStates sh = do+	let	ts0 = initialTurtleState sh+	(c, tis) <- makeInput+	return (c, ts0 : ts0 : inputToTurtle [] ts0 tis)+ makeInput :: IO (Chan TurtleInput, [TurtleInput]) makeInput = do 	c <- newChan-	ret <- getChanContents c-	return (c, ret)+	tis <- getChanContents c+	return (c, 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- }+nextTurtle :: TurtleState -> TurtleInput -> TurtleState+nextTurtle t (Shape sh) = (clearState t){shape = sh}+nextTurtle t (ShapeSize ss) = (clearState t){size = ss}+nextTurtle t (Goto x y) = (clearState t){position = (x, y), line = pendown t}+nextTurtle t (Rotate d) = (clearState t){direction = d}+nextTurtle t Pendown = (clearState t){pendown = True}+nextTurtle t Penup = (clearState t){pendown = False}+nextTurtle t (Undonum un) = (clearState t){undonum = un}+nextTurtle _ _ = error "not defined" -inputToTurtleNext :: [TurtleState] -> TurtleState -> [TurtleInput] -> [TurtleState]-inputToTurtleNext tsbs nts ti = nts : inputToTurtle tsbs nts ti+clearState :: TurtleState -> TurtleState+clearState t = t{line = False, undo = False, undonum = 1}  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+inputToTurtle [] ts0 (Undo : tis) = ts0 : inputToTurtle [] ts0 tis+inputToTurtle (tsb : tsbs) _ (Undo : tis) =+	let ts1 = tsb{undo = True} in ts1 : inputToTurtle tsbs ts1 tis+inputToTurtle tsbs ts0 (Forward len : tis) = let+	(x0, y0) = position ts0+	dir = direction 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"+	inputToTurtle tsbs ts0 $ Goto x y : tis+inputToTurtle tsbs ts0 (Left dd : tis) =+	inputToTurtle tsbs ts0 $ Rotate (direction ts0 + dd) : tis+inputToTurtle tsbs ts0 (ti : tis) =+	let ts1 = nextTurtle ts0 ti in ts1 : inputToTurtle (ts0 : tsbs) ts1 tis+inputToTurtle _ _ [] = error "no more input"
src/Graphics/X11/TurtleState.hs view
@@ -4,25 +4,24 @@ ) where  data TurtleState = TurtleState {-	turtleShape :: [(Double, Double)],-	turtleSize :: Double,-	turtlePos :: (Double, Double),-	turtleDir :: Double,-	turtlePenDown :: Bool,-	turtleUndo :: Bool,-	turtleUndoNum :: Int+	shape :: [(Double, Double)],+	size :: Double,+	position :: (Double, Double),+	direction :: Double,+	pendown :: Bool,+	line :: Bool,+	undo :: Bool,+	undonum :: 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+initialTurtleState :: [(Double, Double)] -> TurtleState+initialTurtleState sh = TurtleState {+	shape = sh,+	size = 1,+	position = (0, 0),+	direction = 0,+	pendown = True,+	line = False,+	undo = False,+	undonum = 1  }--isUndefined :: String -> a-isUndefined name = error $ name ++ " is undefined"
src/Graphics/X11/WindowLayers.hs view
@@ -21,7 +21,7 @@ ) where  import Graphics.X11(-	Display, Window, Pixmap, Atom, GC, Point(..), Dimension,+	Display, Window, Pixmap, Atom, GC, Point(..), Dimension, Position,  	openDisplay, closeDisplay, flush, defaultScreen, rootWindow, 	whitePixel, blackPixel,	defaultDepth,@@ -41,12 +41,13 @@ import Data.IORef(IORef, newIORef, readIORef, writeIORef, modifyIORef) import Data.Bits((.|.)) import Data.Convertible(convert)-import Data.List.Tools(modifyAt)+import Data.List.Tools(modifyAt, setAt)+import Data.Bool.Tools(whether)  import Control.Monad(replicateM, forM_) import Control.Monad.Tools(doWhile_) import Control.Arrow((***))-import Control.Concurrent(forkIO, ThreadId)+import Control.Concurrent(forkIO, ThreadId, Chan, newChan, writeChan, readChan)  data Field = Field{ 	fDisplay :: Display,@@ -61,7 +62,8 @@ 	fHeight :: IORef Dimension, 	fBuffed :: IORef [IO ()], 	fLayers :: IORef [[Bool -> IO ()]],-	fCharacters :: IORef [IO ()]+	fCharacters :: IORef [IO ()],+	fWait :: Chan ()  }  data Layer = Layer{@@ -74,9 +76,6 @@ 	characterId :: Int  } -forkIOX :: IO () -> IO ThreadId-forkIOX = (initThreads >>) . forkIO- openField :: IO Field openField = do 	_ <- initThreads@@ -100,6 +99,8 @@ 	buffActions <- newIORef [] 	layerActions <- newIORef [] 	characterActions <- newIORef []+	wait <- newChan+	writeChan wait () 	let f = Field{ 		fDisplay = dpy, 		fWindow = win,@@ -113,10 +114,11 @@ 		fHeight = heightRef, 		fBuffed = buffActions, 		fLayers = layerActions,-		fCharacters = characterActions+		fCharacters = characterActions,+		fWait = wait 	 } 	_ <- forkIOX $ runLoop f-	flushWin f+	flushWindow f 	return f  runLoop :: Field -> IO ()@@ -142,15 +144,6 @@ layerSize :: Layer -> IO (Double, Double) layerSize = fieldSize . layerField -fieldSize :: Field -> IO (Double, Double)-fieldSize w = fmap (fromIntegral *** fromIntegral) $ fieldSizeRaw w--fieldSizeRaw :: Field -> IO (Dimension, Dimension)-fieldSizeRaw w = do-	width <- readIORef $ fWidth w-	height <- readIORef $ fHeight w-	return (width, height)- addLayer :: Field -> IO Layer addLayer f = do 	ls <- readIORef $ fLayers f@@ -165,16 +158,39 @@ 	return Character{characterField = f, characterId = length cs}  drawLine :: Layer -> Double -> Double -> Double -> Double -> IO ()-drawLine l@Layer{layerField = f} x1_ y1_ x2_ y2_ = do-	(x1, y1) <- convertPos f x1_ y1_-	(x2, y2) <- convertPos f x2_ y2_-	lineWin f x1 y1 x2 y2-	addLayerAction l $ \buf -> do-		(x1', y1') <- convertPos f x1_ y1_-		(x2', y2') <- convertPos f x2_ y2_-		if buf	then lineUndoBuf f x1' y1' x2' y2'-			else lineWin f x1' y1' x2' y2'+drawLine l@Layer{layerField = f} x1 y1 x2 y2 = do+	drawLineBuf f fBG x1 y1 x2 y2 >> redrawCharacters f+	addLayerAction l $ whether+		(drawLineBuf f fUndoBuf x1 y1 x2 y2)+		(drawLineBuf f fBG x1 y1 x2 y2) +drawCharacter :: Character -> [(Double, Double)] -> IO ()+drawCharacter c = setCharacter c . fillPolygonBuf (characterField c)++drawCharacterAndLine ::	Character -> [(Double, Double)] ->+	Double -> Double -> Double -> Double -> IO ()+drawCharacterAndLine c@Character{characterField = f} ps x1 y1 x2 y2 =+	setCharacter c $ fillPolygonBuf f ps >> drawLineBuf f fBuf x1 y1 x2 y2++undoLayer :: Layer -> IO ()+undoLayer Layer{layerField = f, layerId = lid} = do+	ls <- readIORef $ fLayers f+	writeIORef (fLayers f) $ modifyAt ls lid init+	redraw f++clearLayer :: Layer -> IO ()+clearLayer Layer{layerField = f, layerId = lid} = do+	ls <- readIORef $ fLayers f+	writeIORef (fLayers f) $ setAt ls lid []+	buffed <- readIORef $ fBuffed f+	writeIORef (fBuffed f) $ setAt buffed lid $ return ()+	redrawAll f++forkIOX :: IO () -> IO ThreadId+forkIOX = (initThreads >>) . forkIO++--------------------------------------------------------------------------------+ undoN :: Int undoN = 100 @@ -190,123 +206,73 @@ 				modifyAt ls lid $ (++ [act]) . tail 		else writeIORef (fLayers f) $ modifyAt ls lid (++ [act]) -convertPos :: Field -> Double -> Double -> IO (Double, Double)-convertPos f x y = do+setCharacter :: Character -> IO () -> IO ()+setCharacter Character{characterField = f, characterId = cid} act = do+	cs <- readIORef $ fCharacters f+	writeIORef (fCharacters f) $ setAt cs cid act+	redrawCharacters f+	flushWindow f++fillPolygonBuf :: Field -> [(Double, Double)] -> IO ()+fillPolygonBuf f ps_ = do+	ps <- convertPos f ps_+	fillPolygon (fDisplay f) (fBuf f) (fGC f) (map (uncurry Point) ps)+		nonconvex coordModeOrigin++drawLineBuf :: Field -> (Field -> Pixmap) ->+	Double -> Double -> Double -> Double -> IO ()+drawLineBuf f@Field{fDisplay = dpy, fGC = gc} bf x1_ y1_ x2_ y2_ = do+	[(x1, y1), (x2, y2)] <- convertPos f [(x1_, y1_), (x2_, y2_)]+	X.drawLine dpy (bf f) gc x1 y1 x2 y2++convertPos :: Field -> [(Double, Double)] -> IO [(Position, Position)]+convertPos f ps = do 	(width, height) <- fieldSize f-	return (x + width / 2, - y + height / 2)+	return $ (round . (+ width / 2) *** round . (+ height / 2) . negate)+		`map` ps -clearLayer :: Layer -> IO ()-clearLayer l@Layer{layerField = f, layerId = lid} = do-	setExposeAction f l (const $ const $ return ())-	buffed <- readIORef $ fBuffed f-	writeIORef (fBuffed f) $-		take lid buffed ++ [return ()] ++ drop (lid + 1) buffed-	redrawAll f+fieldSize :: Field -> IO (Double, Double)+fieldSize w = fmap (fromIntegral *** fromIntegral) $ winSize w +winSize :: Field -> IO (Dimension, Dimension)+winSize f = do+	width <- readIORef $ fWidth f+	height <- readIORef $ fHeight f+	return (width, height)+ redrawAll :: Field -> IO () redrawAll f = do 	redrawBuf f 	redraw f-	flushWin f+	flushWindow f  redrawBuf :: Field -> IO () redrawBuf f = do-	clearUndoBuf f+	winSize f >>=+		uncurry (fillRectangle (fDisplay f) (fUndoBuf f) (fGCBG f) 0 0) 	readIORef (fBuffed f) >>= sequence_ -setExposeAction :: Field -> Layer -> (Field -> Bool -> IO ()) -> IO ()-setExposeAction w@Field{fLayers = we} Layer{layerId = lid} act = do-	ls <- readIORef we-	writeIORef we $ take lid ls ++ [[act w]] ++ drop (lid + 1) ls--undoLayer :: Layer -> IO ()-undoLayer Layer{layerField = w, layerId = lid} = do-	ls <- readIORef $ fLayers w-	writeIORef (fLayers w) $ take lid ls ++ [init (ls !! lid)] ++ drop (lid + 1) ls-	redraw w- redraw :: Field -> IO ()-redraw w = do-	undoBufToBG w-	readIORef (fLayers w) >>= mapM_ ($ False) . concat-	readIORef (fCharacters w) >>= sequence_--setCharacter :: Field -> Character -> IO () -> IO ()-setCharacter w c act = do-	bgToBuf w-	setCharacterAction w c act-	readIORef (fCharacters w) >>= sequence_--setCharacterAction :: Field -> Character -> IO () -> IO ()-setCharacterAction Field{fCharacters = wc} Character{characterId = cid} act = do-	cs <- readIORef wc-	writeIORef wc $ take cid cs ++ [act] ++ drop (cid + 1) cs--undoBufToBG :: Field -> IO ()-undoBufToBG w = do-	(width, height) <- fieldSizeRaw w-	copyArea (fDisplay w) (fUndoBuf w) (fBG w) (fGC w) 0 0 width height 0 0--bgToBuf :: Field -> IO ()-bgToBuf w = do-	(width, height) <- fieldSizeRaw w-	copyArea (fDisplay w) (fBG w) (fBuf w) (fGC w) 0 0 width height 0 0--bufToWin :: Field -> IO ()-bufToWin w = do-	(width, height) <- fieldSizeRaw w-	copyArea (fDisplay w) (fBuf w) (fWindow w) (fGC w) 0 0 width height 0 0--fillPolygonBuf :: Field -> [(Double, Double)] -> IO ()-fillPolygonBuf w ps = do-	(width, height) <- fieldSize w-	let	dtp (x, y) = Point (round $ x + width / 2) (round $ - y + height / 2)-	fillPolygon (fDisplay w) (fBuf w) (fGC w) (map dtp ps) nonconvex coordModeOrigin--drawCharacter :: Character -> [(Double, Double)] -> IO ()-drawCharacter c@Character{characterField = w} ps = do-	setCharacter w c (fillPolygonBuf w ps)-	flushWin w--drawCharacterAndLine ::	Character -> [(Double, Double)] -> (Double, Double) ->-		(Double, Double) -> IO ()-drawCharacterAndLine c@Character{characterField = w} ps (x1, y1) (x2, y2) = do-	setCharacter w c (fillPolygonBuf w ps >> lineBuf w x1 y1 x2 y2)-	flushWin w--lineWin :: Field -> Double -> Double -> Double -> Double -> IO ()-lineWin w x1_ y1_ x2_ y2_ = do-	X.drawLine (fDisplay w) (fBG w) (fGC w) x1 y1 x2 y2-	bgToBuf w-	readIORef (fCharacters w) >>= sequence_-	where	[x1, y1, x2, y2] = map round [x1_, y1_, x2_, y2_]--lineUndoBuf :: Field -> Double -> Double -> Double -> Double -> IO ()-lineUndoBuf w x1_ y1_ x2_ y2_ =-	X.drawLine (fDisplay w) (fUndoBuf w) (fGC w) x1 y1 x2 y2-	where	[x1, y1, x2, y2] = map round [x1_, y1_, x2_, y2_]--lineBuf :: Field -> Double -> Double -> Double -> Double -> IO ()-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_]-	X.drawLine (fDisplay w) (fBuf w) (fGC w) x1 y1 x2 y2+redraw f = do+	(width, height) <- winSize f+	copyArea (fDisplay f) (fUndoBuf f) (fBG f) (fGC f) 0 0 width height 0 0+	readChan $ fWait f+	readIORef (fLayers f) >>= mapM_ ($ False) . concat+	readIORef (fCharacters f) >>= sequence_+	writeChan (fWait f) () -clearUndoBuf :: Field -> IO ()-clearUndoBuf w = fieldSizeRaw w >>=-	uncurry (fillRectangle (fDisplay w) (fUndoBuf w) (fGCBG w) 0 0)+redrawCharacters :: Field -> IO ()+redrawCharacters f = do+	(width, height) <- winSize f+	readChan $ fWait f+	copyArea (fDisplay f) (fBG f) (fBuf f) (fGC f) 0 0 width height 0 0+	readIORef (fCharacters f) >>= sequence_+	writeChan (fWait f) () -flushWin :: Field -> IO ()-flushWin f = do-	bufToWin f+flushWindow :: Field -> IO ()+flushWindow f = do+	(width, height) <- winSize f+	readChan $ fWait f+	copyArea (fDisplay f) (fBuf f) (fWindow f) (fGC f) 0 0 width height 0 0 	flush $ fDisplay f--{--changeColor :: Win -> Pixel -> IO ()-changeColor w = setForeground (fDisplay w) (fGC w)--clearBG :: Win -> IO ()-clearBG w = fieldSizeRaw w >>=-	uncurry (fillRectangle (fDisplay w) (fBG w) (fGCWhite w) 0 0)--}+	writeChan (fWait f) ()
xturtle.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.6  name:		xturtle-version:	0.0.6+version:	0.0.7 stability:	experimental author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -30,7 +30,7 @@ library   Hs-source-dirs:	src   Exposed-modules:	Graphics.X11.Turtle-  Build-depends:	base > 3 && < 5, yjtools >= 0.9.12, convertible, X11+  Build-depends:	base > 3 && < 5, yjtools >= 0.9.13, convertible, X11   Ghc-options:		-Wall   Other-modules:	Graphics.X11.WindowLayers,     Graphics.X11.TurtleInput,