wxturtle (empty) → 0.0.1

raw patch · 11 files changed

+1168/−0 lines, 11 filesdep +Imlibdep +basedep +convertiblesetup-changed

Dependencies added: Imlib, base, convertible, wx, yjsvg, yjtools

Files

• LICENSE +27/−0
• Setup.hs +3/−0
• src/Graphics/UI/WX/Turtle.hs +339/−0
• src/Graphics/UI/WX/Turtle/Data.hs +22/−0
• src/Graphics/UI/WX/Turtle/Field.hs +307/−0
• src/Graphics/UI/WX/Turtle/Input.hs +108/−0
• src/Graphics/UI/WX/Turtle/Layers.hs +100/−0
• src/Graphics/UI/WX/Turtle/Move.hs +118/−0
• src/Graphics/UI/WX/Turtle/State.hs +74/−0
• tests/testWX.hs +37/−0
• wxturtle.cabal +33/−0

@@ -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.

@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain

@@ -0,0 +1,339 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE RankNTypes #-}++module Graphics.UI.WX.Turtle(+	-- * meta data+	xturtleVersion,++	-- * types and classes+	Field,+	Turtle,+	ColorClass,++	-- * Field functions+	-- ** meta+	openField,+	closeField,+	waitField,+	topleft,+	center,++	-- ** on events+	oninputtext,+	onclick,+	onrelease,+	ondrag,+	onmotion,+	onkeypress,+	ontimer,++	-- * Turtle functions+	-- ** meta+	newTurtle,+	killTurtle,+	inputs,+	runInputs,+	getSVG,++	-- ** move turtle+	forward,+	backward,+	goto,+	setx,+	sety,+	left,+	right,+	setheading,+	circle,+	home,+	undo,+	sleep,+	flush,++	-- ** draw+	dot,+	stamp,+	beginfill,+	endfill,+	write,+	image,+	bgcolor,+	clear,++	-- ** change states+	addshape,+	beginpoly,+	endpoly,+	getshapes,+	shape,+	shapesize,+	hideturtle,+	showturtle,+	penup,+	pendown,+	pencolor,+	pensize,+	fillcolor,+	radians,+	degrees,+	speed,+	flushoff,+	flushon,++	-- ** informations+	position,+	xcor,+	ycor,+	distance,+	heading,+	towards,+	isdown,+	isvisible,+	windowWidth,+	windowHeight+) where++import Graphics.UI.WX.Turtle.Data(shapeTable, speedTable)+import Graphics.UI.WX.Turtle.State(+	TurtleState, direction, visible, undonum, drawed, polyPoints)+import qualified Graphics.UI.WX.Turtle.State as S(position, degrees, pendown)+import Graphics.UI.WX.Turtle.Input(TurtleInput(..), turtleSeries)+import Graphics.UI.WX.Turtle.Move(+	Field, Coordinates(..), openField, closeField, waitField,+	topleft, center, coordinates, fieldSize, forkField, flushField,+	addLayer, clearLayer, addCharacter, clearCharacter, moveTurtle,+	oninputtext, onclick, onrelease, ondrag, onmotion, onkeypress, ontimer)+import Text.XML.YJSVG(SVG(..), Position(..), Color(..))+import qualified Text.XML.YJSVG as S(center, topleft)++import Control.Concurrent(killThread, newChan, writeChan, getChanContents)+import Control.Monad(replicateM_, zipWithM_)+import Control.Arrow((&&&))+import Data.IORef(IORef, newIORef, readIORef)+import Data.IORef.Tools(atomicModifyIORef_)+import Data.Fixed(mod')++--------------------------------------------------------------------------------++xturtleVersion :: (Int, String)+xturtleVersion = (69, "0.1.11")++--------------------------------------------------------------------------------++data Turtle = Turtle {+	field :: Field, input :: TurtleInput -> IO (),+	info :: forall a . (TurtleState -> a) -> IO a,+	shapes :: IORef [(String, [(Double, Double)])],+	inputs :: IO [TurtleInput], killTurtle :: IO ()}++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)++--------------------------------------------------------------------------------++newTurtle :: Field -> IO Turtle+newTurtle f = do+	index <- newIORef 1; shapesRef <- newIORef shapeTable+	chan <- newChan; hist <- getChanContents chan+	let states = turtleSeries hist+	l <- addLayer f; c <- addCharacter f+	thr <- forkField f $ zipWithM_ (moveTurtle f c l) states $ tail states+	let t = Turtle {+		field = f,+		input = (atomicModifyIORef_ index succ >>) . writeChan chan,+		info = \n -> fmap (n . (states !!)) $ readIORef index,+		shapes = shapesRef,+		inputs = fmap (flip take hist . pred) $ readIORef index,+		killTurtle = flushField f True $+			clearLayer l >> clearCharacter c >> killThread thr}+	shape t "classic" >> input t (Undonum 0) >> return t++runInputs :: Turtle -> [TurtleInput] -> IO ()+runInputs = mapM_ . input++getSVG :: Turtle -> IO [SVG]+getSVG = fmap reverse . flip info drawed++convertPosition :: Turtle -> Position -> IO Position+convertPosition t p = do+	(w, h) <- windowSize t+	coord <- coordinates $ field t+	return $ case coord of+		CoordCenter -> S.center w h p+		CoordTopLeft -> S.topleft w h p++--------------------------------------------------------------------------------++forward, backward :: Turtle -> Double -> IO ()+forward t = input t . Forward+backward t = forward t . negate++goto :: Turtle -> Double -> Double -> IO ()+goto t@Turtle{field = f} x y = do+	coord <- coordinates f+	input t $ Goto $ case coord of+		CoordCenter -> Center x y+		CoordTopLeft -> TopLeft x y++setx, sety :: Turtle -> Double -> IO ()+setx t x = do+	pos <- info t S.position >>= convertPosition t+	input t $ Goto $ case pos of+		Center _ y -> Center x y+		TopLeft _ y -> TopLeft x y+sety t y = do+	pos <- info t S.position >>= convertPosition t+	input t $ Goto $ case pos of+		Center x _ -> Center x y+		TopLeft x _ -> TopLeft x y++left, right, setheading :: Turtle -> Double -> IO ()+left t = input t . TurnLeft+right t = left t . negate+setheading t = input t . Rotate++circle :: Turtle -> Double -> IO ()+circle t r = do+	deg <- info t S.degrees+	forward t (r * pi / 36)+	left t (deg / 36)+	replicateM_ 35 $ forward t (2 * r * pi / 36) >> left t (deg / 36)+	forward t (r * pi / 36)+	input t $ Undonum 74++home :: Turtle -> IO ()+home t = goto t 0 0 >> setheading t 0 >> input t (Undonum 3)++undo :: Turtle -> IO ()+undo t = info t undonum >>= flip replicateM_ (input t Undo)++sleep :: Turtle -> Int -> IO ()+sleep t = input t . Sleep++flush :: Turtle -> IO ()+flush = (`input` Flush)++--------------------------------------------------------------------------------++dot :: Turtle -> Double -> IO ()+dot t = input t . Dot++stamp :: Turtle -> IO ()+stamp = (`input` Stamp)++beginfill, endfill :: Turtle -> IO ()+beginfill = (`input` SetFill True)+endfill = (`input` SetFill False)++write :: Turtle -> String -> Double -> String -> IO ()+write t fnt sz = input t . Write fnt sz++image :: Turtle -> FilePath -> Double -> Double -> IO ()+image t fp = curry $ input t . uncurry (PutImage fp)++bgcolor :: ColorClass c => Turtle -> c -> IO ()+bgcolor t = input t . Bgcolor . getColor++clear :: Turtle -> IO ()+clear = (`input` Clear)++--------------------------------------------------------------------------------++addshape :: Turtle -> String -> [(Double, Double)] -> IO ()+addshape t n s = atomicModifyIORef_ (shapes t) ((n, s) :)++beginpoly :: Turtle -> IO ()+beginpoly = (`input` SetPoly True)++endpoly :: Turtle -> IO [(Double, Double)]+endpoly t = input t (SetPoly False) >> info t polyPoints >>=+	mapM (fmap (posX &&& posY) . convertPosition t)++getshapes :: Turtle -> IO [String]+getshapes = fmap (map fst) . readIORef . shapes++shape :: Turtle -> String -> IO ()+shape t n = readIORef (shapes t) >>=+	maybe (putStrLn $ "no shape named " ++ n) (input t . Shape) . lookup n++shapesize :: Turtle -> Double -> Double -> IO ()+shapesize t = curry $ input t . uncurry Shapesize++hideturtle, showturtle :: Turtle -> IO ()+hideturtle = (`input` SetVisible False)+showturtle = (`input` SetVisible True)++penup, pendown :: Turtle -> IO ()+penup = (`input` SetPendown False)+pendown = (`input` SetPendown True)++pencolor :: ColorClass c => Turtle -> c -> IO ()+pencolor t = input t . Pencolor . getColor++fillcolor :: ColorClass c => Turtle -> c -> IO ()+fillcolor t = input t . Fillcolor . getColor++pensize :: Turtle -> Double -> IO ()+pensize t = input t . Pensize++radians :: Turtle -> IO ()+radians = (`degrees` (2 * pi))++degrees :: Turtle -> Double -> IO ()+degrees t = input t . Degrees++speed :: Turtle -> String -> IO ()+speed t str = case lookup str speedTable of+	Just (ps, ds) -> do+		input t $ PositionStep ps+		input t $ DirectionStep ds+		input t $ Undonum 3+	Nothing -> putStrLn "no such speed"++flushoff, flushon :: Turtle -> IO ()+flushoff = (`input` SetFlush False)+flushon = (`input` SetFlush True)++--------------------------------------------------------------------------------++position :: Turtle -> IO (Double, Double)+position t = fmap (posX &&& posY) $ info t S.position >>= convertPosition t++xcor, ycor :: Turtle -> IO Double+xcor = fmap fst . position+ycor = fmap snd . position++distance :: Turtle -> Double -> Double -> IO Double+distance t x0 y0 = do+	(x, y) <- position t+	return $ ((x - x0) ** 2 + (y - y0) ** 2) ** (1 / 2)++heading :: Turtle -> IO Double+heading t = do+	deg <- info t S.degrees+	dir <- fmap (* (deg / (2 * pi))) $ info t direction+	return $ dir `mod'` deg++towards :: Turtle -> Double -> Double -> IO Double+towards t x0 y0 = do+	(x, y) <- position t+	deg <- info t S.degrees+	let	dir = atan2 (y0 - y) (x0 - x) * deg / (2 * pi)+	return $ if dir < 0 then dir + deg else dir++isdown, isvisible :: Turtle -> IO Bool+isdown = flip info S.pendown+isvisible = flip info visible++windowWidth, windowHeight :: Turtle -> IO Double+windowWidth = fmap fst . windowSize+windowHeight = fmap snd . windowSize++windowSize :: Turtle -> IO (Double, Double)+windowSize = fieldSize . field

@@ -0,0 +1,22 @@+module Graphics.UI.WX.Turtle.Data(+	-- * tables+	shapeTable, speedTable) where++import Control.Arrow(second, (&&&))++shapeTable :: [(String, [(Double, Double)])]+shapeTable = [+	("classic", unfold [(- 10, 0), (- 16, 6), (0, 0)]),+	("turtle", unfold [+		(- 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)])]+	where unfold = uncurry (++) .+		(id &&& reverse . map (second negate) . init . tail)++speedTable :: [(String, (Maybe Double, Maybe Double))]+speedTable = [+	("fastest", (Nothing, Nothing)),+	("fast", (Just 60, Just $ pi / 3)),+	("normal", (Just 20, Just $ pi / 9)),+	("slow", (Just 10, Just $ pi / 18)),+	("slowest", (Just 3, Just $ pi / 60))]

@@ -0,0 +1,307 @@+{-# LANGUAGE DoRec #-}++module Graphics.UI.WX.Turtle.Field(+	-- * types and classes+	Field(fFrame),+	Layer,+	Character,+	Coordinates(..),++	-- * basic functions+	openField,+	closeField,+	waitField,+	topleft,+	center,+	coordinates,+	fieldSize,++	-- * draw+	forkField,+	flushField,+	fieldColor,++	-- ** to Layer+	addLayer,+	drawLine,+	fillRectangle,+	fillPolygon,+	writeString,+	drawImage,+	undoLayer,+	undoField,+	clearLayer,++	-- ** to Character+	addCharacter,+	drawCharacter,+	drawCharacterAndLine,+	clearCharacter,++	-- * event driven+	oninputtext,+	onclick,+	onrelease,+	ondrag,+	onmotion,+	onkeypress,+	ontimer+) where++import Graphics.UI.WX(+	on, command, Prop(..), text, button, frame, layout, widget, set, panel,+	Frame, Panel, minsize, sz, column, circle, paint, Point2(..), Point,+	line, repaint, DC, Rect, dcClear, polygon, red, green, brushColor, penColor,+	rgb, row, textEntry, processEnter, get, hfill, fill, size, Size2D(..), resize,+	TextCtrl, penWidth+ )+import qualified Graphics.UI.WX as WX++import Graphics.UI.WX.Turtle.Layers(+	Layers, Layer, Character, newLayers, redrawLayers,+	makeLayer, background, addDraw, undoLayer, clearLayer,+	makeCharacter, character)+import Text.XML.YJSVG(Position(..), Color(..))++import Control.Monad(when, unless, forever, replicateM, forM_, join)+import Control.Monad.Tools(doWhile_, doWhile)+import Control.Arrow((***))+import Control.Concurrent(+	ThreadId, forkIO, killThread, threadDelay,+	Chan, newChan, readChan, writeChan)+import Data.IORef(IORef, newIORef, readIORef, writeIORef)+import Data.IORef.Tools(atomicModifyIORef_)+import Data.Maybe(fromMaybe)+import Data.List(delete)+import Data.Convertible(convert)+import Data.Function.Tools(const2, const3)++--------------------------------------------------------------------------------++data Coordinates = CoordTopLeft | CoordCenter++data Field = Field{+	fFrame :: Frame (),+	fPanel :: Panel (),+	fAction :: IORef (DC () -> Rect -> IO ()),+	fActions :: IORef [DC () -> Rect -> IO ()],+	fCharacter :: Character,+	fCoordinates :: Coordinates,++	fPenColor :: (Int, Int, Int),+	fDrawColor :: (Int, Int, Int),++	fSize :: IORef (Double, Double),++	fInputtext :: IORef (String -> IO Bool),++	fLayers :: IORef Layers+ }++--------------------------------------------------------------------------------++undoField :: Field -> IO ()+undoField f = do+	atomicModifyIORef_ (fActions f) tail++openField :: IO Field+openField = do+	fr <- frame [text := "turtle"]+	p <- panel fr []+	quit <- button fr [text := "Quit", on command := WX.close fr]+	inputAction <- newIORef $ \_ -> return True+	rec input <- textEntry fr [+		processEnter := True,+		on command := do+			str <- get input text+			putStrLn str+			set input [text := ""]+			cont <- ($ str) =<< readIORef inputAction+			when (not cont) $ WX.close fr]+	set fr [layout := column 5 [+		fill $ minsize (sz 300 300) $ widget p,+		row 5 [hfill $ widget input] ]] -- , widget quit] ]]+	act <- newIORef $ \dc rct -> circle dc (Point 40 25) 25 []+	acts <- newIORef []+	layers <- newLayers 50 (return ())+--		(writeIORef act (\dc rect -> dcClear dc) >> repaint p)+		(return ())+		(return ())+--		(writeIORef act (\dc rect -> dcClear dc) >> repaint p)+--		(return ())+	Size x y <- get p size+	print x+	print y+	sz <- newIORef (fromIntegral x, fromIntegral y)+	let	f = Field{+			fFrame = fr,+			fPanel = p,+			fAction = act,+			fActions = acts,+			fCoordinates = CoordCenter,+			fPenColor = (0, 0, 0),+			fSize = sz,+			fLayers = layers,+			fInputtext = inputAction+		 }+	set p [	on paint := \dc rct -> do+			act <- readIORef $ fAction f+			acts <- readIORef $ fActions f+			mapM_ (($ rct) . ($ dc)) acts+			act dc rct,+		on resize := do+			Size x y <- get p size+			writeIORef sz (fromIntegral x, fromIntegral y) ]+	return f++data InputType = XInput | End | Timer++waitInput :: Field -> IO (Chan ())+waitInput f = newChan++closeField :: Field -> IO ()+closeField = WX.close . fFrame++waitField :: Field -> IO ()+waitField = const $ return ()++topleft, center :: Field -> IO ()+topleft = const $ return ()+center = const $ return ()++coordinates :: Field -> IO Coordinates+coordinates = return . fCoordinates++fieldSize :: Field -> IO (Double, Double)+fieldSize = const $ return (0, 0)++--------------------------------------------------------------------------------++forkField :: Field -> IO () -> IO ThreadId+forkField f act = do+	tid <- forkIO act+	return tid++flushField :: Field -> Bool -> IO a -> IO a+flushField f real act = act++fieldColor :: Field -> Layer -> Color -> IO ()+fieldColor f l clr = return ()++--------------------------------------------------------------------------------++addLayer = makeLayer . fLayers++drawLayer f l drw = addDraw l (drw, drw)++drawLine :: Field -> Layer -> Double -> Color -> Position -> Position -> IO ()+drawLine f l w c p q = do+	atomicModifyIORef_ (fActions f) $ (act :)+	repaint $ fPanel f+	where+	act = \dc rect -> do +		set dc [penColor := colorToWX c, penWidth := round w]+		p' <- positionToPoint f p+		q' <- positionToPoint f q+		line dc p' q' []++getPenColor :: Field -> WX.Color+getPenColor Field{fPenColor = (r, g, b)} = rgb r g b++colorToWX :: Color -> WX.Color+colorToWX (RGB{colorRed = r, colorGreen = g, colorBlue = b}) = rgb r g b++{- addDraw l (do+	atomicModifyIORef_ (fAction f) $ \f dc rect -> do+		f dc rect+		line dc (positionToPoint p) (positionToPoint q) []+	repaint $ fPanel f, do+	atomicModifyIORef_ (fAction f) $ \f dc rect -> do+		f dc rect+		line dc (positionToPoint p) (positionToPoint q) []+	repaint $ fPanel f)+-}++positionToPoint :: Field -> Position -> IO Point+positionToPoint f (Center x y) = do+	(sx, sy) <- readIORef $ fSize f+	return $ Point (round $ x + sx / 2) (round $ - y + sy / 2)++writeString :: Field -> Layer -> String -> Double -> Color -> Position ->+	String -> IO ()+writeString f l fname size clr pos str = return ()++drawImage :: Field -> Layer -> FilePath -> Position -> Double -> Double -> IO ()+drawImage f l fp pos w h = return ()++fillRectangle :: Field -> Layer -> Position -> Double -> Double -> Color -> IO ()+fillRectangle f l p w h clr = return ()++fillPolygon :: Field -> Layer -> [Position] -> Color -> Color -> Double -> IO ()+fillPolygon f l ps clr lc lw = do+	atomicModifyIORef_ (fActions f) $ (act :)+	repaint $ fPanel f+	where+	act = \dc rect -> do+		set dc [brushColor := colorToWX clr, penColor := colorToWX lc,+			penWidth := round lw]+		sh' <- mapM (positionToPoint f) ps+		polygon dc sh' []++--------------------------------------------------------------------------------++addCharacter = makeCharacter . fLayers++drawCharacter :: Field -> Character -> Color -> Color -> [Position] -> Double -> IO ()+drawCharacter f ch fc c ps lw = do+	writeIORef (fAction f) $ \dc rect -> do+		set dc [brushColor := colorToWX fc, penColor := colorToWX c,+			penWidth := round lw]+		sh' <- mapM (positionToPoint f) ps+		polygon dc sh' []+	repaint $ fPanel f++drawCharacterAndLine ::	Field -> Character -> Color -> Color -> [Position] ->+	Double -> Position -> Position -> IO ()+drawCharacterAndLine f ch fclr clr sh lw p q = do+--	putStrLn $ "drawCharacterAndLine" ++ show p ++ " : " ++ show q+	writeIORef (fAction f) $ \dc rect -> do+		set dc [brushColor := colorToWX fclr, penColor := colorToWX clr,+			penWidth := round lw]+		p' <- positionToPoint f p+		q' <- positionToPoint f q+		line dc p' q' []+		sh' <- mapM (positionToPoint f) sh+		polygon dc sh' []+	repaint $ fPanel f+		+{-+	atomicModifyIORef_ (fAction f) $ \f dc rect -> do+		f dc rect+		line dc (positionToPoint p) (positionToPoint q) []+-}+	repaint $ fPanel f++clearCharacter :: Character -> IO ()+clearCharacter ch = character ch $ return ()++--------------------------------------------------------------------------------++oninputtext :: Field -> (String -> IO Bool) -> IO ()+oninputtext = writeIORef . fInputtext++onclick, onrelease :: Field -> (Int -> Double -> Double -> IO Bool) -> IO ()+onclick _ _ = return ()+onrelease _ _ = return ()++ondrag :: Field -> (Int -> Double -> Double -> IO ()) -> IO ()+ondrag _ _ = return ()++onmotion :: Field -> (Double -> Double -> IO ()) -> IO ()+onmotion _ _ = return ()++onkeypress :: Field -> (Char -> IO Bool) -> IO ()+onkeypress _ _ = return ()++ontimer :: Field -> Int -> IO Bool -> IO ()+ontimer f t fun = return ()

@@ -0,0 +1,108 @@+module Graphics.UI.WX.Turtle.Input(TurtleInput(..), turtleSeries) where++import Graphics.UI.WX.Turtle.State(TurtleState(..), initTurtleState, makeShape)+import Text.XML.YJSVG(SVG(..), Color(..), Position(..))++--------------------------------------------------------------------------------++data TurtleInput+	= Goto Position+	| Forward Double+	| RotateRad Double+	| Rotate Double+	| TurnLeft Double+	| Dot Double+	| Stamp+	| Write String Double String+	| PutImage FilePath Double Double+	| Undo+	| Undonum Int+	| Clear+	| Sleep Int+	| Flush+	| Shape [(Double, Double)]+	| Shapesize Double Double+	| Pensize Double+	| Pencolor Color+	| Fillcolor Color+	| Bgcolor Color+	| SetPendown Bool+	| SetVisible Bool+	| SetFill Bool+	| SetPoly Bool+	| SetFlush Bool+	| PositionStep (Maybe Double)+	| DirectionStep (Maybe Double)+	| Degrees Double+	deriving (Show, Read)++turtleSeries :: [TurtleInput] -> [TurtleState]+turtleSeries tis = let ts0 = initTurtleState in ts0 : ts0 : turtles [] ts0 tis++turtles :: [TurtleState] -> TurtleState -> [TurtleInput] -> [TurtleState]+turtles [] ts0 (Undo : tis) = ts0 : turtles [] ts0 tis+turtles (tsb : tsbs) _ (Undo : tis) =+	let ts1 = tsb{undo = True} in ts1 : turtles tsbs ts1 tis+turtles tsbs ts0 (Forward len : tis) = case position ts0 of+	Center x0 y0 -> let+		x = x0 + len * cos (direction ts0)+		y = y0 + len * sin (direction ts0) in+		turtles tsbs ts0 $ Goto (Center x y) : tis+	TopLeft x0 y0 -> let+		x = x0 + len * cos (direction ts0)+		y = y0 - len * sin (direction ts0) in+		turtles tsbs ts0 $ Goto (TopLeft x y) : tis+turtles tsbs ts0 (Rotate dir : tis) = turtles tsbs ts0 $+	RotateRad (dir * 2 * pi / degrees ts0) : tis+turtles tsbs ts0 (TurnLeft dd : tis) = turtles tsbs ts0 $+	RotateRad (direction ts0 + dd * 2 * pi / degrees ts0) : tis+turtles tsbs ts0 (ti : tis) =+	let ts1 = nextTurtle ts0 ti in ts1 : turtles (ts0 : tsbs) ts1 tis+turtles _ _ [] = error "no more input"++reset :: TurtleState -> TurtleState+reset t = t{draw = Nothing, clear = False, undo = False, undonum = 1,+	sleep = Nothing, flush = False}++set :: TurtleState -> Maybe SVG -> TurtleState+set t drw = t{draw = drw, drawed = maybe id (:) drw $ drawed t}++nextTurtle :: TurtleState -> TurtleInput -> TurtleState+nextTurtle t (Goto pos) = (reset t){position = pos,+	fillPoints = (if fill t then (pos :) else id) $ fillPoints t,+	polyPoints = (if poly t then (pos :) else id) $ polyPoints t}+	`set` if not $ pendown t then Nothing+		else Just $ Line pos (position t) (pencolor t) (pensize t)+nextTurtle t (RotateRad dir) = (reset t){direction = dir}+nextTurtle t@TurtleState{pencolor = clr} (Dot sz) = reset t `set`+	Just (Rect (position t) sz sz 0 clr clr)+nextTurtle t@TurtleState{pencolor = clr, fillcolor = fclr} Stamp = reset t `set`+	Just (Polyline (makeShape t (direction t) (position t)) fclr clr $+		pensize t)+nextTurtle t@TurtleState{pencolor = clr} (Write fnt sz str) = reset t `set`+	Just (Text (position t) sz clr fnt str)+nextTurtle t (PutImage fp w h) = reset t `set` Just (Image (position t) w h fp)+nextTurtle t (Undonum un) = (reset t){undonum = un}+nextTurtle t Clear = (reset t){clear = True, drawed = [last $ drawed t]}+nextTurtle t (Sleep time) = (reset t){sleep = Just time}+nextTurtle t Flush = (reset t){flush = True}+nextTurtle t (Shape sh) = (reset t){shape = sh}+nextTurtle t (Shapesize sx sy) = (reset t){shapesize = (sx, sy)}+nextTurtle t (Pensize ps) = (reset t){pensize = ps}+nextTurtle t (Pencolor clr) = (reset t){pencolor = clr}+nextTurtle t (Fillcolor clr) = (reset t){fillcolor = clr}+nextTurtle t (Bgcolor clr) = (reset t){+	draw = Just $ Fill clr, drawed = init (drawed t) ++ [Fill clr]}+nextTurtle t (SetPendown pd) = (reset t){pendown = pd}+nextTurtle t (SetVisible v) = (reset t){visible = v}+nextTurtle t (SetFill fl) = (reset t){fill = fl, fillPoints = [position t | fl]}+	`set` (if not (fill t) || fl then Nothing else+		Just $ Polyline (fillPoints t) (fillcolor t) (pencolor t)+			(pensize t))+nextTurtle t (SetPoly p) = (reset t){+	poly = p, polyPoints = if p then [position t] else polyPoints t}+nextTurtle t (SetFlush ss) = (reset t){stepbystep = ss}+nextTurtle t (PositionStep ps) = (reset t){positionStep = ps}+nextTurtle t (DirectionStep ds) = (reset t){directionStep = ds}+nextTurtle t (Degrees ds) = (reset t){degrees = ds}+nextTurtle _ _ = error "not defined"

@@ -0,0 +1,100 @@+module Graphics.UI.WX.Turtle.Layers(+	-- * types+	Layers,+	Layer,+	Character,+	+	-- * initialize+	newLayers,+	makeLayer,+	makeCharacter,++	-- * draws+	redrawLayers,+	background,+	addDraw,+	undoLayer,+	clearLayer,+	character+) where++import Control.Monad(when, unless)+import Data.IORef(IORef, newIORef, readIORef, atomicModifyIORef)+import Data.IORef.Tools(atomicModifyIORef_)+import Data.List.Tools(setAt, modifyAt)++--------------------------------------------------------------------------------++data Layers = Layers{+	bgs :: [IO ()], buffs :: [IO ()], layers :: [[(IO (), IO ())]],+	chars :: [IO ()], buffSize :: Int,+	clearBuffers :: IO (), clearLayers :: IO (), clearCharacters :: IO ()}++data Layer = Layer{layerId :: Int, layerLayers :: IORef Layers}+data Character = Character{charId :: Int, charLayers :: IORef Layers}++--------------------------------------------------------------------------------++newLayers :: Int -> IO () -> IO () -> IO () -> IO (IORef Layers)+newLayers bsize cbuf clyr cchr = newIORef Layers{+	bgs = [], buffs = [], layers = [], chars = [], buffSize = bsize,+	clearBuffers = cbuf, clearLayers = clyr, clearCharacters = cchr}++makeLayer :: IORef Layers -> IO Layer+makeLayer rls = atomicModifyIORef rls $ \ls -> (ls{+		bgs = bgs ls ++[return ()], buffs = buffs ls ++ [return ()],+		layers = layers ls ++ [[]]},+	Layer{layerId = length $ layers ls, layerLayers = rls})++makeCharacter :: IORef Layers -> IO Character+makeCharacter rls = atomicModifyIORef rls $ \ls -> (ls{+		chars = chars ls ++ [return ()]},+	Character{charId = length $ chars ls, charLayers = rls})++--------------------------------------------------------------------------------++redrawLayers :: IORef Layers -> IO ()+redrawLayers rls = readIORef rls >>= \ls -> do+	clearBuffers ls >> sequence_ (bgs ls) >> sequence_ (buffs ls)+	clearLayers ls >> mapM_ snd (concat $ layers ls)+	clearCharacters ls >> sequence_ (chars ls)++background :: Layer -> IO () -> IO ()+background Layer{layerId = lid, layerLayers = rls} act =+	atomicModifyIORef_ rls (\ls -> ls{bgs = setAt (bgs ls) lid act})+		>> redrawLayers rls++addDraw :: Layer -> (IO (), IO ()) -> IO ()+addDraw Layer{layerId = lid, layerLayers = rls} acts@(_, act) = do+	readIORef rls >>= \ls -> do+		act >> clearCharacters ls >> sequence_ (chars ls)+		unless (length (layers ls !! lid) < buffSize ls) $+			fst $ head $ layers ls !! lid+	atomicModifyIORef_ rls $ \ls ->+		if length (layers ls !! lid) < buffSize ls+			then ls{layers = modifyAt (layers ls) lid (++ [acts])}+			else let (a, _) : as = layers ls !! lid in ls{+				layers = setAt (layers ls) lid $ as ++ [acts],+				buffs = modifyAt (buffs ls) lid (>> a)}++undoLayer :: Layer -> IO Bool+undoLayer Layer{layerId = lid, layerLayers = rls} = do+	done <- atomicModifyIORef rls $ \ls -> if null $ layers ls !! lid+		then (ls, False)+		else (ls{layers = modifyAt (layers ls) lid init}, True)+	when done $ readIORef rls >>= \ls -> do+		clearLayers ls >> mapM_ snd (concat $ layers ls)+		clearCharacters ls >> sequence_ (chars ls)+	return done++clearLayer :: Layer -> IO ()+clearLayer Layer{layerId = lid, layerLayers = rls} =+	atomicModifyIORef_ rls (\ls -> ls{+		bgs = setAt (bgs ls) lid $ return (),+		buffs = setAt (buffs ls) lid $ return (),+		layers = setAt (layers ls) lid []}) >> redrawLayers rls++character :: Character -> IO () -> IO ()+character Character{charId = cid, charLayers = rls} act = do+	atomicModifyIORef_ rls $ \ls -> ls{chars = setAt (chars ls) cid act}+	readIORef rls >>= \ls -> clearCharacters ls >> sequence_ (chars ls)

@@ -0,0 +1,118 @@+module Graphics.UI.WX.Turtle.Move(+	-- * types+	Field,+	Coordinates(..),++	-- * process Field+	openField,+	closeField,+	waitField,+	topleft,+	center,+	coordinates,+	fieldSize,++	-- * draws+	forkField,+	flushField,+	clearLayer,+	clearCharacter,+	moveTurtle,++	-- * event+	oninputtext,+	onclick,+	onrelease,+	ondrag,+	onmotion,+	onkeypress,+	ontimer,+	addLayer,+	addCharacter+) where++import Graphics.UI.WX.Turtle.State(TurtleState(..), makeShape)+import Graphics.UI.WX.Turtle.Field(+	Field, Layer, Character, Coordinates(..),+	openField, closeField, waitField, coordinates, topleft, center,+	fieldSize, forkField, flushField, clearLayer,+	clearCharacter, addLayer, addCharacter,+	oninputtext, onclick, onrelease, ondrag, onmotion, onkeypress, ontimer,+	fieldColor, drawLine, fillRectangle, fillPolygon, writeString,+	drawImage, undoField, undoLayer, drawCharacter, drawCharacterAndLine)+import Text.XML.YJSVG(SVG(..), Position(..))+import qualified Text.XML.YJSVG as S(topleft)++import Control.Concurrent(threadDelay)+import Control.Monad(when, unless, forM_)+import Control.Monad.Tools(unlessM)+import Data.Maybe(isJust)++--------------------------------------------------------------------------------++moveTurtle :: Field -> Character -> Layer -> TurtleState -> TurtleState -> IO ()+moveTurtle _ _ _ _ TurtleState{sleep = Just t} = threadDelay $ 1000 * t+moveTurtle f _ _ _ TurtleState{flush = True} = flushField f True $ return ()+moveTurtle f c l t0 t1 = do+	(w, h) <- fieldSize f+	when (undo t1) $ fl $ do+		when (clear t0) redraw+		when (isJust $ draw t0) $ do+--			unlessM (undoLayer l) $ clearLayer l >> redraw+			undoField f+			when (visible t1) $ drawTtl (direction t0) $ position t0+	when (visible t1) $ do+		forM_ (directions t0 t1) $ \dir -> fl $+			drawTtl dir (position t0) >> threadDelay (interval t0)+		forM_ (positions w h t0 t1) $ \p -> fl $+			drawTtl (direction t1) p >> threadDelay (interval t0)+		fl $ drawTtl (direction t1) $ position t1+	when (visible t0 && not (visible t1)) $ fl $ clearCharacter c+	when (clear t1) $ fl $ clearLayer l+	unless (undo t1) $ fl $ maybe (return ()) (drawSVG f l) (draw t1)+	where+	fl = flushField f $ stepbystep t0+	redraw = mapM_ (drawSVG f l) $ reverse $ drawed t1+	drawTtl dir pos = drawTurtle f c t1 dir pos begin+	begin	| undo t1 && pendown t0 = Just $ position t1+		| pendown t1 = Just $ position t0+		| otherwise = Nothing++drawSVG :: Field -> Layer -> SVG -> IO ()+drawSVG f l (Line p0 p1 clr lw) = drawLine f l lw clr p0 p1+drawSVG f l (Rect pos w h 0 fc _) = fillRectangle f l pos w h fc+drawSVG f l (Polyline ps fc lc lw) = fillPolygon f l ps fc lc lw+drawSVG f l (Fill clr) = fieldColor f l clr+drawSVG f l (Text pos sz clr fnt str) = writeString f l fnt sz clr pos str+drawSVG f l (Image pos w h fp) = drawImage f l fp pos w h+drawSVG _ _ _ = error "not implemented"++positions :: Double -> Double -> TurtleState -> TurtleState -> [Position]+positions w h t0 t1 =+	maybe [] (mkPositions w h (position t0) (position t1)) $ positionStep t0++mkPositions :: Double -> Double -> Position -> Position -> Double -> [Position]+mkPositions w h p1 p2 step = case (p1, p2) of+	(Center x0 y0, Center x1 y1) -> map (uncurry Center) $ mp x0 y0 x1 y1+	(TopLeft x0 y0, TopLeft x1 y1) -> map (uncurry TopLeft) $ mp x0 y0 x1 y1+	_ -> mkPositions w h (S.topleft w h p1) (S.topleft w h p2) step+	where+	mp x0 y0 x1 y1 = let dist = ((x1 - x0) ** 2 + (y1 - y0) ** 2) ** (1 / 2)+		in take (floor $ dist / step) $ zip+			[x0, x0 + step * (x1 - x0) / dist .. ]+			[y0, y0 + step * (y1 - y0) / dist .. ]++directions :: TurtleState -> TurtleState -> [Double]+directions t0 t1 = case directionStep t0 of+	Nothing -> []+	Just step -> [ds, ds + dd .. de - dd]+		where+		dd = if de > ds then step else - step+		ds = direction t0+		de = direction t1++drawTurtle :: Field -> Character -> TurtleState -> Double -> Position ->+	Maybe Position -> IO ()+drawTurtle f c ts@TurtleState{fillcolor = fclr, pencolor = clr} dir pos = maybe+	(drawCharacter f c fclr clr (makeShape ts dir pos) (pensize ts))+	(drawCharacterAndLine f c fclr clr (makeShape ts dir pos) (pensize ts) pos)

@@ -0,0 +1,74 @@+module Graphics.UI.WX.Turtle.State(+	TurtleState(..), initTurtleState, makeShape) where++import Text.XML.YJSVG(Position(..), SVG(Fill), Color(RGB))+import Data.Tuple.Tools(rotate)+import Control.Arrow((***))++data TurtleState = TurtleState {+	position :: Position,+	direction :: Double,+	degrees :: Double,+	shape :: [(Double, Double)],+	shapesize :: (Double, Double),+	pensize :: Double,+	pencolor :: Color,+	fillcolor :: Color,+	pendown :: Bool,+	visible :: Bool,+	stepbystep :: Bool,++	draw :: Maybe SVG,+	drawed :: [SVG],+	clear :: Bool,+	undo :: Bool,+	undonum :: Int,+	sleep :: Maybe Int,+	flush :: Bool,+	fill :: Bool,+	poly :: Bool,+	fillPoints :: [Position],+	polyPoints :: [Position],++	positionStep :: Maybe Double,+	directionStep :: Maybe Double,+	interval :: Int}++initTurtleState :: TurtleState+initTurtleState = TurtleState {+	position = Center 0 0,+	direction = 0,+	degrees = 360,+	shape = [],+	shapesize = (1, 1),+	pensize = 1,+	pencolor = RGB 0 0 0,+	fillcolor = RGB 0 0 0,+	pendown = True,+	visible = True,+	stepbystep = True,++	draw = Nothing,+	drawed = [Fill $ RGB 255 255 255],+	clear = False,+	undo = False,+	undonum = 0,+	sleep = Nothing,+	flush = False,+	fill = False,+	poly = False,+	fillPoints = [],+	polyPoints = [],++	positionStep = Just 10,+	directionStep = Just $ pi / 18,+	interval = 10000}++makeShape :: TurtleState -> Double -> Position -> [Position]+makeShape ts dir_ pos = (mkPos . move . rotate dir . resize) `map` shape ts+	where+	move = (+ posX pos) *** (+ posY pos)+	resize = uncurry (***) $ ((*) *** (*)) $ shapesize ts+	(mkPos, dir) = case pos of+		Center{} -> (uncurry Center, dir_)+		TopLeft{} -> (uncurry TopLeft, - dir_)

@@ -0,0 +1,37 @@+import Graphics.UI.WX.Turtle+import Graphics.UI.WX++main = start gui++gui = do+	f <- openField+	t <- newTurtle f+	oninputtext f $ action t+	speed t "slowest"+--	left t 45+--	forward t 300+--	right t 135+--	forward t 250+--	undo t+--	ff <- frame [text := "Hello!"]+--	quit <- button ff [text := "Quit", on command := close ff]+--	set ff [layout := widget quit]++action t "quit" = return False+action t "forward" = forward t 100 >> return True+action t "backward" = backward t 100 >> return True+action t "undo" = undo t >> return True+action t "left" = left t 90 >> return True+action t "right" = right t 90 >> return True+action t "red" = pencolor t (255, 0, 0) >> return True+action t "blue" = fillcolor t (0, 0, 255) >> return True+action t "bold" = pensize t 5 >> return True+action t "normal" = pensize t 1 >> return True+action t "big" = shapesize t 3 3 >> return True+action t "turtle" = shape t "turtle" >> return True+action t "stamp" = stamp t >> return True+action t "penup" = penup t >> return True+action t "begin" = beginfill t >> return True+action t "end" = endfill t >> return True+action t "turtlecolor" = pencolor t (0, 0, 255) >> fillcolor t (0, 255, 0) >> return True+action _ _ = return True

@@ -0,0 +1,33 @@+build-type:	Simple+cabal-version:	>= 1.6++name:		wxturtle+version:	0.0.1+stability:	alpha+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 with wxHaskell+description:	turtle like LOGO with wxHaskell++source-repository	head+  type:		git+  location:	git://github.com/YoshikuniJujo/wxturtle.git++library+  Hs-source-dirs:	src+  Exposed-modules:	Graphics.UI.WX.Turtle+  Build-depends:	base > 3 && < 5, yjtools >= 0.9.16, convertible >= 1.0.8,+    yjsvg >= 0.1.14, Imlib >= 0.1.2, wx+  Ghc-options:		-Wall+  Other-modules:	Graphics.UI.WX.Turtle.Field, Graphics.UI.WX.Turtle.Input,+    Graphics.UI.WX.Turtle.Move, Graphics.UI.WX.Turtle.State,+    Graphics.UI.WX.Turtle.Data, Graphics.UI.WX.Turtle.Layers++executable		testTurtle+  Hs-source-dirs:	tests, src+  Main-is:		testWX.hs