packages feed

gluturtle (empty) → 0.0.1

raw patch · 12 files changed

+1169/−0 lines, 12 filesdep +GLUTdep +Imlibdep +basesetup-changed

Dependencies added: GLUT, Imlib, base, convertible, random, yjsvg, 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,3 @@+import Distribution.Simple++main = defaultMain
+ gluturtle.cabal view
@@ -0,0 +1,40 @@+build-type:	Simple+cabal-version:	>= 1.6++name:		gluturtle+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 glut+description:	turtle like LOGO with glut+	.+	Now alpha alpha alpha alpha version.++source-repository	head+  type:		git+  location:	git://github.com/YoshikuniJujo/gluturtle.git++library+  Hs-source-dirs:	src+  Exposed-modules:	Graphics.UI.GLUT.Turtle+  Build-depends:	base > 3 && < 5, yjtools >= 0.9.16, convertible >= 1.0.8,+    yjsvg >= 0.1.14, Imlib >= 0.1.2, GLUT+  Ghc-options:		-Wall+  Other-modules:	Graphics.UI.GLUT.Turtle.Field, Graphics.UI.GLUT.Turtle.Input,+    Graphics.UI.GLUT.Turtle.Move, Graphics.UI.GLUT.Turtle.State,+    Graphics.UI.GLUT.Turtle.Data, Graphics.UI.GLUT.Turtle.Layers++executable		testTurtle+  Hs-source-dirs:	tests, src+  Main-is:		testGLUT.hs++executable		randomTurtle+  Hs-source-dirs:	tests, src+  Main-is:		randomTurtle.hs+  Build-depends:	random
+ src/Graphics/UI/GLUT/Turtle.hs view
@@ -0,0 +1,339 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE RankNTypes #-}++module Graphics.UI.GLUT.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.GLUT.Turtle.Data(shapeTable, speedTable)+import Graphics.UI.GLUT.Turtle.State(+	TurtleState, direction, visible, undonum, drawed, polyPoints)+import qualified Graphics.UI.GLUT.Turtle.State as S(position, degrees, pendown)+import Graphics.UI.GLUT.Turtle.Input(TurtleInput(..), turtleSeries)+import Graphics.UI.GLUT.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
+ src/Graphics/UI/GLUT/Turtle/Data.hs view
@@ -0,0 +1,22 @@+module Graphics.UI.GLUT.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))]
+ src/Graphics/UI/GLUT/Turtle/Field.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE DoRec #-}++module Graphics.UI.GLUT.Turtle.Field(+	-- * types and classes+	Field,+	Layer,+	Character,+	Coordinates(..),++	-- * basic functions+	openField,+	closeField,+	waitField,+	topleft,+	center,+	coordinates,+	fieldSize,++	-- * draw+	forkField,+	flushField,+	fieldColor,++	-- ** to Layer+	drawLine,+	fillRectangle,+	fillPolygon,+	writeString,+	drawImage,+	undoLayer,+	undoField,+	clearLayer,++	-- ** to Character+	drawCharacter,+	drawCharacterAndLine,+	clearCharacter,++	-- * event driven+	oninputtext,+	onclick,+	onrelease,+	ondrag,+	onmotion,+	onkeypress,+	ontimer,++	addLayer,+	addCharacter+) where++import Graphics.UI.GLUT(+	createWindow, Vertex2(..), renderPrimitive, vertex, PrimitiveMode(..),+	preservingMatrix, GLfloat, swapBuffers, ($=), displayCallback,+	initialDisplayMode, initialWindowSize, Size(..),+	DisplayMode(..), flush, Vertex3(..)+ )+import qualified Graphics.UI.GLUT as G++import Graphics.UI.GLUT.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{+	fCoordinates :: Coordinates,++	fAction :: IORef (IO ()),+	fActions :: IORef [IO ()],++	fLayers :: IORef Layers+ }++addLayer = makeLayer . fLayers+addCharacter = makeCharacter . fLayers++--------------------------------------------------------------------------------++undoField :: Field -> IO ()+undoField f = atomicModifyIORef_ (fActions f) tail++openField :: IO Field+openField = do+	layers <- newLayers 0 (return ()) (return ()) (return ())+	action <- newIORef $ return ()+	actions <- newIORef []++	initialDisplayMode $= [RGBMode, DoubleBuffered]+	initialWindowSize $= Size 640 480+	createWindow "field"+	displayCallback $= (sequence_ =<< readIORef actions) -- testAction+	G.addTimerCallback 10 (timerAction $ do+		G.clearColor $= G.Color4 0 0 0 0+		G.clear [G.ColorBuffer]+		sequence_ =<< readIORef actions+		join $ readIORef action+		swapBuffers)+	G.reshapeCallback $= Just (\size -> G.viewport $= (G.Position 0 0, size))+	print "main loop go"+	print "main loop"+	return Field{+		fCoordinates = CoordCenter,+		fLayers = layers,+		fAction = action,+		fActions = actions+	 }++timerAction act = do+	act+	G.addTimerCallback 10 $ timerAction act++data InputType = XInput | End | Timer++waitInput :: Field -> IO (Chan ())+waitInput f = newChan++closeField :: Field -> IO ()+closeField _ = return ()++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 ()++--------------------------------------------------------------------------------++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) (makeLineAction p q :)+--	G.addTimerCallback 1 $ makeLineAction p q+--	swapBuffers+	flush+{- do+	preservingMatrix $ do+		renderPrimitive Quads $ mapM_ vertex [+			Vertex3 0.10 0.10 0.0,+			Vertex3 (-0.10) 0.10 0.0,+			Vertex3 (-0.10) (-0.10) 0.0,+			Vertex3 0.10 (-0.10) 0.0 :: Vertex3 GLfloat+		 ]+	swapBuffers -}++testAction = do+	G.loadIdentity+	preservingMatrix $ do+		renderPrimitive Lines $ mapM_ vertex [+			Vertex3 0.10 0.10 0.0,+			Vertex3 (-0.10) 0.10 0.0,+			Vertex3 (-0.10) (-0.10) 0.0,+			Vertex3 0.10 (-0.10) 0.0 :: Vertex3 GLfloat+		 ]+--	swapBuffers++makeLineAction :: Position -> Position -> IO ()+makeLineAction p q = do+	preservingMatrix $ do+		renderPrimitive Lines $ mapM_ vertex [+			positionToVertex3 p,+			positionToVertex3 q ]+--	swapBuffers++makeCharacterAction :: [Position] -> IO ()+makeCharacterAction ps =+	preservingMatrix $ do+		renderPrimitive Polygon $ mapM_ (vertex . positionToVertex3) ps++positionToVertex3 :: Position -> Vertex2 GLfloat+positionToVertex3 (Center x y) =+	Vertex2 (fromRational $ toRational x / 300)+		(fromRational $ toRational y / 300)++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 = return ()++--------------------------------------------------------------------------------++drawCharacter :: Field -> Character -> Color -> Color -> [Position] -> Double -> IO ()+drawCharacter f ch fc c ps lw = return ()++drawCharacterAndLine ::	Field -> Character -> Color -> Color -> [Position] ->+	Double -> Position -> Position -> IO ()+drawCharacterAndLine f ch fclr clr sh lw p q =+	writeIORef (fAction f) $ do+		makeLineAction p q+		makeCharacterAction sh++clearCharacter :: Character -> IO ()+clearCharacter ch = character ch $ return ()++--------------------------------------------------------------------------------++oninputtext :: Field -> (String -> IO Bool) -> IO ()+oninputtext _ _ = return ()++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 ()
+ src/Graphics/UI/GLUT/Turtle/Input.hs view
@@ -0,0 +1,108 @@+module Graphics.UI.GLUT.Turtle.Input(TurtleInput(..), turtleSeries) where++import Graphics.UI.GLUT.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"
+ src/Graphics/UI/GLUT/Turtle/Layers.hs view
@@ -0,0 +1,100 @@+module Graphics.UI.GLUT.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)
+ src/Graphics/UI/GLUT/Turtle/Move.hs view
@@ -0,0 +1,118 @@+module Graphics.UI.GLUT.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.GLUT.Turtle.State(TurtleState(..), makeShape)+import Graphics.UI.GLUT.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)
+ src/Graphics/UI/GLUT/Turtle/State.hs view
@@ -0,0 +1,74 @@+module Graphics.UI.GLUT.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_)
+ tests/randomTurtle.hs view
@@ -0,0 +1,61 @@+module Main where++import Graphics.UI.GLUT.Turtle+import Graphics.UI.GLUT.Turtle.Field+import Graphics.UI.GLUT(initialize, addTimerCallback, mainLoop)+import System.Random+import System.Environment+import Control.Monad+import Control.Concurrent+import Data.Word++main :: IO ()+main = do+	prgName <- getProgName+	rawArgs <- getArgs+	args <- initialize prgName rawArgs+	f <- openField+	t <- newTurtle f+	preprocess t+	(x0, y0) <- position t+	addTimerCallback 100 $ timerProc $ draw t x0 y0+	mainLoop++timerProc act = do+	act+	addTimerCallback 20 $ timerProc act++randomWord8 :: IO Word8+randomWord8 = fmap fromIntegral $ (randomRIO (0, 255) :: IO Int)++randomTurtle :: Turtle -> IO ()+randomTurtle t = do+	preprocess t+	(x0, y0) <- position t+	sequence_ $ repeat $ draw t x0 y0++preprocess :: Turtle -> IO ()+preprocess t = do+	penup t+	shape t "turtle"+	shapesize t 2 2+	(x0, y0) <- position t+	forward t 100+	pendown t+	left t 90+	circle t 100+	penup t+	goto t x0 y0+	pendown t+	position t >>= print++draw t x0 y0 = do+	d <- randomRIO (- 180, 180)+	r <- randomWord8+	g <- randomWord8+	b <- randomWord8+	pencolor t (r, g, b)+	left t d+	forward t 15+	d <- distance t x0 y0+	when (d > 100) $ undo t
+ tests/testGLUT.hs view
@@ -0,0 +1,17 @@+import Graphics.UI.GLUT.Turtle+import Graphics.UI.GLUT+import Control.Concurrent++import System.Environment++main = do+	prgName <- getProgName+	rawArgs <- getArgs+	args <- initialize prgName rawArgs+	f <- openField+	t <- newTurtle f+--	speed t "slowest"+	threadDelay 1000000+	left t 45+	forward t 100+	mainLoop