packages feed

gluturtle 0.0.31 → 0.0.33

raw patch · 8 files changed

+365/−413 lines, 8 files

Files

gluturtle.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.6  name:		gluturtle-version:	0.0.31+version:	0.0.33 stability:	alpha author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -28,8 +28,9 @@   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,-    Graphics.UI.GLUT.Turtle.Triangles, Graphics.UI.GLUT.Turtle.TriangleTools+    Graphics.UI.GLUT.Turtle.Data,+    Graphics.UI.GLUT.Turtle.Triangles, Graphics.UI.GLUT.Turtle.TriangleTools,+    Graphics.UI.GLUT.Turtle.GLUTools  executable		testTurtle   Hs-source-dirs:	tests, src
src/Graphics/UI/GLUT/Turtle.hs view
@@ -15,8 +15,9 @@ 	-- * Field functions 	-- ** meta 	openField,+	openConsole,+	setConsole, 	closeField,-	waitField, 	topleft, 	center, @@ -108,11 +109,11 @@ 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(prompt, initialize, setFieldSize,-	Field, Coordinates(..), openField, closeField, waitField,+	Field, Coordinates(..), openField, closeField, 	topleft, center, coordinates, fieldSize, forkField, flushField,-	addLayer, clearLayer, addCharacter, clearCharacter, moveTurtle,+	clearCharacter, moveTurtle, 	oninputtext, onclick, onrelease, ondrag, onmotion, onkeypress, ontimer,-	outputString)+	outputString, openConsole, setConsole) import Text.XML.YJSVG(SVG(..), Position(..), Color(..)) import qualified Text.XML.YJSVG as S(center, topleft) @@ -151,8 +152,8 @@ 	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+--	_ <- addLayer f; c <- addCharacter f+	thr <- forkField f $ zipWithM_ (moveTurtle f) states $ tail states 	let t = Turtle { 		field = f, 		input = (atomicModifyIORef_ index succ >>) . writeChan chan,@@ -160,7 +161,8 @@ 		shapes = shapesRef, 		inputs = fmap (flip take hist . pred) $ readIORef index, 		killTurtle = flushField f True $-			clearLayer l >> clearCharacter f >> killThread thr}+--			clearLayer l >>+			clearCharacter f >> killThread thr} 	shape t "classic" >> input t (Undonum 0) >> return t  runInputs :: Turtle -> [TurtleInput] -> IO ()
src/Graphics/UI/GLUT/Turtle/Field.hs view
@@ -1,18 +1,15 @@-{-# LANGUAGE DoRec #-}- module Graphics.UI.GLUT.Turtle.Field(-	initialize,  	-- * types and classes-	Field(fRunning),-	Layer,-	Character,+	Field, 	Coordinates(..),  	-- * basic functions+	initialize, 	openField,+	openConsole,+	setConsole, 	closeField,-	waitField, 	topleft, 	center, 	coordinates,@@ -30,9 +27,7 @@ 	fillPolygon, 	writeString, 	drawImage,-	undoLayer, 	undoField,-	clearLayer,  	-- ** to Character 	drawCharacter,@@ -50,9 +45,6 @@ 	onkeypress, 	ontimer, -	addLayer,-	addCharacter,- 	prompt ) where @@ -60,211 +52,223 @@  import Graphics.UI.GLUT.Turtle.Triangles -import Graphics.UI.GLUT(-	createWindow, Vertex2(..), renderPrimitive, vertex, PrimitiveMode(..),-	preservingMatrix, GLfloat, swapBuffers, ($=), displayCallback,-	initialDisplayMode, initialWindowSize, Size(..),-	DisplayMode(..), flush, currentWindow, Window- )-import qualified Graphics.UI.GLUT as G--import Graphics.UI.GLUT.Turtle.Layers(-	Layers, Layer, Character, newLayers,-	makeLayer, undoLayer, clearLayer,-	makeCharacter, character)+import qualified Graphics.UI.GLUT.Turtle.GLUTools as G+import Graphics.UI.GLUT.Turtle.GLUTools(+	($=), initialize, createWindow, printLines, keyboardCallback, loop,+	displayAction) import Text.XML.YJSVG(Position(..), Color(..)) --- import Control.Monad(when, unless, forever, replicateM, forM_, join)-import Control.Concurrent(ThreadId, forkIO)+import Control.Concurrent(ThreadId, forkIO, Chan, newChan, writeChan, readChan) import Data.IORef(IORef, newIORef, readIORef, writeIORef) import Data.IORef.Tools(atomicModifyIORef_) import Data.Maybe-import System.Environment  -------------------------------------------------------------------------------- -initialize :: IO [String]-initialize = do-	prgName <- getProgName-	rawArgs <- getArgs-	G.initialize prgName rawArgs-+prompt :: Field -> String -> IO () prompt f p = do-	writeIORef (fPrompt f) p-	atomicModifyIORef_ (fString f) (\ls -> init ls ++ [p ++ last ls])+	mc <- getConsole f+	case mc of+		Just c -> do+			writeIORef (cPrompt c) p+			atomicModifyIORef_ (cCommand c)+				(\ls -> init ls ++ [p ++ last ls])+		_ -> return ()  data Coordinates = CoordTopLeft | CoordCenter +data Console = Console{+	cPrompt :: IORef String,+	cCommand :: IORef [String],+	cHistory :: IORef [String],+	cChanged :: IORef Int,+	cChanChanged :: IORef Int,+	cChan :: Chan String+ }+ data Field = Field{-	fChanged :: IORef Int,-	fAct :: IO (),-	fCoordinates :: Coordinates,+	fConsole :: IORef (Maybe Console), +	fFieldWindow :: G.Window,+	fSize :: IORef (Int, Int),+	fCoordinates :: IORef Coordinates, 	fBgcolor :: IORef [Color],+ 	fAction :: IORef (IO ()), 	fActions :: IORef [Maybe (IO ())], -	fString :: IORef [String],-	fString2 :: IORef [String],+	fChanged :: IORef Int,  	fInputtext :: IORef (String -> IO Bool),--	fWidth :: IORef Int,-	fHeight :: IORef Int,--	fFieldWindow :: Window,-	fConsoleWindow :: Window,--	fPrompt :: IORef String,--	fLayers :: IORef Layers,--	fRunning :: IORef Bool,-	fBusy :: IORef Bool+	fOnclick :: IORef (Int -> Double -> Double -> IO Bool)  } -addLayer :: Field -> IO Layer-addLayer = makeLayer . fLayers-addCharacter :: Field -> IO Character-addCharacter = makeCharacter . fLayers- -------------------------------------------------------------------------------- -undoField :: Field -> IO ()-undoField f = do-	a : _ <- readIORef $ fActions f-	when (isNothing a) $ atomicModifyIORef_ (fBgcolor f) tail-	atomicModifyIORef_ (fActions f) myTail+openConsole :: String -> Int -> Int -> IO Console+openConsole name w h = do+	cwindow <- createWindow name w h+	cprompt <- newIORef ""+	ccommand <- newIORef [""]+	chistory <- newIORef []+	cchanged <- newIORef 1+	cchanchanged <- newIORef 0+	cchan <- newChan+	let	c = Console{+			cPrompt = cprompt,+			cCommand = ccommand,+			cHistory = chistory,+			cChanged = cchanged,+			cChanChanged = cchanchanged,+			cChan = cchan }+	keyboardCallback $ processKeyboard c+	displayAction cchanged $ do+		cmd <- readIORef ccommand+		hst <- readIORef chistory+		printLines cwindow 1.0 $ reverse cmd ++ hst+	return c -myTail [] = error "myTail failed"-myTail (x : xs) = xs+processKeyboard ::+	Console -> Char -> G.KeyState -> G.Modifiers -> G.Position -> IO ()+processKeyboard console '\r' G.Down _ _ = do+	atomicModifyIORef_ (cChanged console) (+ 1)+	p <- readIORef $ cPrompt console+	str <- readIORef (cCommand console)+	atomicModifyIORef_ (cHistory console) (reverse str ++)+	writeIORef (cCommand console) [p]+	atomicModifyIORef_ (cChanChanged console) (+ 1)+	writeChan (cChan console) $ drop (length p) $ concat str+processKeyboard c '\b' G.Down _ _ = do+	atomicModifyIORef_ (cChanged c) (+ 1)+	p <- readIORef $ cPrompt c+	atomicModifyIORef_ (cCommand c) $ \s -> case s of+		[""] -> [""]+		[ss] | length ss <= length p -> s+		_ -> case (init s, last s) of+			(i, "") -> init i ++ [init $ last i]+			(i, l) -> i ++ [init l]+processKeyboard c chr G.Down _ _ = do+	atomicModifyIORef_ (cChanged c) (+ 1)+	atomicModifyIORef_ (cCommand c) (`addToTail` chr)+processKeyboard _ _ _ _ _ = return () +addToTail :: [String] -> Char -> [String]+addToTail [] _ = error "bad"+addToTail strs c+	| length (last strs) < 50 = init strs ++ [last strs ++ [c]]+	| otherwise = strs ++ [[c]]+ openField :: String -> Int -> Int -> IO Field openField name w h = do-	fc <- newIORef 0-	fb <- newIORef False-	fr <- newIORef False-	fw <- newIORef w-	fh <- newIORef h-	layers <- newLayers 0 (return ()) (return ()) (return ())-	bgc <- newIORef $ [RGB 255 255 255]-	action <- newIORef $ return ()-	actions <- newIORef [] -- [makeFieldColor $ RGB 255 255 255]-	str <- newIORef [""]-	str2 <- newIORef []-	inputtext <- newIORef $ const $ return True+	fsize <- newIORef (w, h)+	fcoord <- newIORef CoordCenter+	fbgcolor <- newIORef [RGB 255 255 255] -	prmpt <- newIORef ""+	faction <- newIORef $ return ()+	factions <- newIORef [] -	initialDisplayMode $= [RGBMode, DoubleBuffered]-	initialWindowSize $= Size (fromIntegral w) (fromIntegral h)-	wt <- createWindow name-	wc <- createWindow "console"-	let act = do-		change <- readIORef fc-		when (change > 0) $ do-			currentWindow $= Just wt-			G.clearColor $= G.Color4 0 0 0 0-			G.clear [G.ColorBuffer]-			makeFieldColor . head =<< readIORef bgc-			sequence_ . reverse . catMaybes =<< readIORef actions-			join $ readIORef action-			swapBuffers-			currentWindow $= Just wc+	fchanged <- newIORef 0+	finputtext <- newIORef $ const $ return True+	fclick <- newIORef (\_ _ _ -> return True)++	ffield <- createWindow name w h++	let	act = do+			G.currentWindow $= Just ffield+			actwt+		actwt = do+			G.Size w' h' <- G.get G.windowSize+			writeIORef fsize $ (fromIntegral w', fromIntegral h') 			G.clearColor $= G.Color4 0 0 0 0 			G.clear [G.ColorBuffer]-			G.lineWidth $= 1.0-			ss1 <- readIORef str-			ss2 <- readIORef str2-			zipWithM_ (printString (-2.8)) [-1800, -1600 .. 1800] (reverse ss1 ++ ss2)-			swapBuffers-			atomicModifyIORef_ fc (subtract 1)-	currentWindow $= Just wt-	displayCallback $= atomicModifyIORef_ fc (+ 1) >> act-	currentWindow $= Just wc-	displayCallback $= act---	G.keyboardMouseCallback $= Just (\_ _ _ _ -> act)-	G.addTimerCallback 10 $ timerAction act+			makeFieldColor . head =<< readIORef fbgcolor+			sequence_ . reverse . catMaybes =<< readIORef factions+			join $ readIORef faction+			G.swapBuffers+	displayAction fchanged act 	G.reshapeCallback $= Just (\size -> G.viewport $= (G.Position 0 0, size))++	fconsole <- newIORef Nothing 	let f = Field{-		fChanged = fc,-		fAct = act,-		fCoordinates = CoordCenter,-		fLayers = layers,-		fAction = action,-		fActions = actions,-		fString = str,-		fString2 = str2,-		fWidth = fw,-		fHeight = fh,-		fInputtext = inputtext,-		fFieldWindow = wt,-		fConsoleWindow = wc,-		fPrompt = prmpt,+		fConsole = fconsole, -		fBgcolor = bgc,+		fFieldWindow = ffield,+		fSize = fsize,+		fCoordinates = fcoord,+		fBgcolor = fbgcolor, -		fBusy = fb,-		fRunning = fr+		fAction = faction,+		fActions = factions,++		fChanged = fchanged,++		fInputtext = finputtext,+		fOnclick = fclick 	 }-	G.keyboardMouseCallback $= Just (\k ks m p -> do-		keyboardProc f k ks m p-		atomicModifyIORef_ (fChanged f) (+ 1))---		act)-{--		busy <- readIORef $ fBusy f-		when (k == G.Char '\r' && not busy) $ do-			writeIORef (fBusy f) True-			G.addTimerCallback 10 $ timerActionN f 10 act)--}---	G.keyboardMouseCallback $= Just (\_ _ _ _ -> act)---	G.addTimerCallback 10 $ timerAction act+	G.keyboardMouseCallback $= Just (processKeyboardMouse f)+ 	return f -printString :: GLfloat -> GLfloat -> String -> IO ()-printString x y str =-	preservingMatrix $ do-		G.scale (0.0005 :: GLfloat)  0.0005 0.0005-		G.clearColor $= G.Color4 0 0 0 0-		G.color (G.Color4 0 1 0 0 :: G.Color4 GLfloat)-		w <- G.stringWidth G.Roman "Stroke font"-		G.translate (G.Vector3 (x * fromIntegral w)-			y 0 :: G.Vector3 GLfloat)-		G.renderString G.Roman str+setConsole :: Field -> Console -> IO ()+setConsole f console = do+	loop (cChanChanged console) $ do+		cmd <- readChan $ cChan console+		continue <- readIORef (fInputtext f) >>= ($ cmd)+		unless continue G.leaveMainLoop+	writeIORef (fConsole f) $ Just console -timerAction :: IO a -> IO ()-timerAction act = do-	_ <- act-	G.addTimerCallback 10 $ timerAction act+processKeyboardMouse :: Field -> G.Key -> G.KeyState -> G.Modifiers -> G.Position -> IO ()+processKeyboardMouse f (G.Char c) ks m p = do+	mc <- getConsole f+	case mc of+		Just con -> do+			processKeyboard con c ks m p+			atomicModifyIORef_ (fChanged f) (+ 1)+		Nothing -> return ()+processKeyboardMouse f (G.MouseButton mb) G.Down _m (G.Position x_ y_) = do+	coord <- readIORef (fCoordinates f)+	continue <- case coord of+		CoordCenter -> do+			(w, h) <- fieldSize f+			let	x = fromIntegral x_ - (w / 2)+				y = (h / 2) - fromIntegral y_+			readIORef (fOnclick f) >>= (\fun -> fun (buttonToInt mb) x y)+		CoordTopLeft -> do+			let	(x, y) = (fromIntegral x_, fromIntegral y_)+			readIORef (fOnclick f) >>= (\fun -> fun (buttonToInt mb) x y)+	unless continue G.leaveMainLoop+processKeyboardMouse _f (G.MouseButton _mb) G.Up _m _p = do+	return ()+processKeyboardMouse _f (G.SpecialKey _sk) _ks _m _p = do+	return () -timerActionN :: Field -> Int -> IO a -> IO ()--- timerActionN f 0 _ = writeIORef (fBusy f) False-timerActionN f n act = do-	b <- readIORef $ fRunning f-	if b then act >> G.addTimerCallback 10 (timerActionN f undefined act)-		else act >> writeIORef (fBusy f) False---	_ <- act---	G.addTimerCallback 10 $ timerActionN f (n - 1) act+buttonToInt :: G.MouseButton -> Int+buttonToInt G.LeftButton = 1+buttonToInt G.MiddleButton = 2+buttonToInt G.RightButton = 3+buttonToInt G.WheelUp = 4+buttonToInt G.WheelDown = 5+buttonToInt (G.AdditionalButton n) = n --- data InputType = XInput | End | Timer+undoField :: Field -> IO ()+undoField f = do+	a : _ <- readIORef $ fActions f+	when (isNothing a) $ atomicModifyIORef_ (fBgcolor f) tail+	atomicModifyIORef_ (fActions f) tail  closeField :: Field -> IO ()-closeField _ = return ()--waitField :: Field -> IO ()-waitField = const $ return ()+closeField _ = G.leaveMainLoop  topleft, center :: Field -> IO ()-topleft = const $ return ()-center = const $ return ()+topleft = flip writeIORef CoordTopLeft . fCoordinates+center = flip writeIORef CoordCenter . fCoordinates  coordinates :: Field -> IO Coordinates-coordinates = return . fCoordinates+coordinates = readIORef . fCoordinates  fieldSize :: Field -> IO (Double, Double) fieldSize f = do-	w <- readIORef $ fWidth f-	h <- readIORef $ fHeight f+	(w, h) <- readIORef $ fSize f 	return (fromIntegral w, fromIntegral h)  --------------------------------------------------------------------------------@@ -275,23 +279,19 @@ flushField :: Field -> Bool -> IO a -> IO a flushField _f _real act = act -fieldColor :: Field -> Layer -> Color -> IO ()-fieldColor f _l clr = do---	atomicModifyIORef_ (fActions f) ((++ [makeFieldColor clr]) . myInit)+fieldColor :: Field -> Color -> IO ()+fieldColor f clr = do 	atomicModifyIORef_ (fBgcolor f) (clr :) 	atomicModifyIORef_ (fActions f) (Nothing :) -myInit [] = error "myInit failed"-myInit [x] = []-myInit (x : xs) = x : myInit xs--makeFieldColor clr = preservingMatrix $ do+makeFieldColor :: Color -> IO ()+makeFieldColor clr = G.preservingMatrix $ do 	G.color $ colorToColor4 clr-	renderPrimitive Quads $ mapM_ vertex [+	G.renderPrimitive G.Quads $ mapM_ G.vertex [ 		G.Vertex2 (-1) (-1), 		G.Vertex2 (-1) 1, 		G.Vertex2 1 1,-		G.Vertex2 1 (-1) :: Vertex2 GLfloat ]+		G.Vertex2 1 (-1) :: G.Vertex2 G.GLfloat ]  -------------------------------------------------------------------------------- @@ -299,128 +299,112 @@ setFieldSize f w_ h_ = do 	let	w = round w_ 		h = round h_-	writeIORef (fWidth f) w-	writeIORef (fHeight f) h-	currentWindow $= Just (fFieldWindow f)-	G.windowSize $= Size (fromIntegral w) (fromIntegral h)+	writeIORef (fSize f) (w, h)+	G.currentWindow $= Just (fFieldWindow f)+	G.windowSize $= G.Size (fromIntegral w) (fromIntegral h) -drawLine :: Field -> Layer -> Double -> Color -> Position -> Position -> IO ()-drawLine f _ w c p q = do+drawLine :: Field -> Double -> Color -> Position -> Position -> IO ()+drawLine f w c p q = do 	atomicModifyIORef_ (fActions f) (Just (makeLineAction f p q c w) :)---	G.addTimerCallback 1 $ makeLineAction p q c---	swapBuffers 	atomicModifyIORef_ (fChanged f) (+ 1)-	flush+	G.flush  makeLineAction :: Field -> Position -> Position -> Color -> Double -> IO ()-makeLineAction f p q c w = preservingMatrix $ do+makeLineAction f p q c w = G.preservingMatrix $ do 	G.lineWidth $= fromRational (toRational w)-	G.color $ colorToColor4 c -- (G.Color4 1 0 0 0 :: G.Color4 GLfloat)+	G.color $ colorToColor4 c 	pp <- positionToVertex3 f p 	qq <- positionToVertex3 f q-	renderPrimitive Lines $ mapM_ vertex [pp, qq]+	G.renderPrimitive G.Lines $ mapM_ G.vertex [pp, qq] -colorToColor4 :: Color -> G.Color4 GLfloat+colorToColor4 :: Color -> G.Color4 G.GLfloat colorToColor4 (RGB r g b) = G.Color4 	(fromIntegral r / 255) (fromIntegral g / 255) (fromIntegral b / 255) 0 colorToColor4 _ = error "colorToColor4: not implemented" -makeQuads :: Field -> [Position] -> Color -> IO ()-makeQuads f ps c = do-	vs <- mapM (positionToVertex3 f) ps-	preservingMatrix $ do-		G.color $ colorToColor4 c-		renderPrimitive Quads $ mapM_ vertex vs- makeCharacterAction :: Field -> [Position] -> Color -> Color -> Double -> IO () makeCharacterAction f ps c lc lw = do+	ps' <- mapM (positionToPos f) ps 	vs <- mapM (positionToVertex3 f . posToPosition) $-		triangleToPositions $ toTriangles $ map positionToPos ps+		triangleToPositions $ toTriangles ps' 	vs' <- mapM (positionToVertex3 f) ps-	preservingMatrix $ do+	G.preservingMatrix $ do 		G.color $ colorToColor4 c-		renderPrimitive Triangles $ mapM_ vertex vs---			mapM_ vertex . positionToVertex3 f . posToPosition) $---			triangleToPositions $---			toTriangles $ map positionToPos ps---		renderPrimitive Polygon $ mapM_ (vertex . positionToVertex3 f) ps+		G.renderPrimitive G.Triangles $ mapM_ G.vertex vs 		G.lineWidth $= fromRational (toRational lw) 		G.color $ colorToColor4 lc-		renderPrimitive LineLoop $ mapM_ vertex vs'+		G.renderPrimitive G.LineLoop $ mapM_ G.vertex vs'  type Pos = (Double, Double) triangleToPositions :: [(Pos, Pos, Pos)] -> [Pos] triangleToPositions [] = [] triangleToPositions ((a, b, c) : rest) = a : b : c : triangleToPositions rest -positionToPos :: Position -> Pos-positionToPos (Center x y) = (x, y)-positionToPos _ = error "positionToPos: not implemented"+positionToPos :: Field -> Position -> IO Pos+positionToPos _ (Center x y) = return (x, y)+positionToPos f (TopLeft x y) = do+	(w, h) <- fieldSize f+	return (x - w / 2, h / 2 - y)  posToPosition :: Pos -> Position posToPosition (x, y) = Center x y -positionToVertex3 :: Field -> Position -> IO (Vertex2 GLfloat)+positionToVertex3 :: Field -> Position -> IO (G.Vertex2 G.GLfloat) positionToVertex3 f (Center x y) = do-	w <- readIORef $ fWidth f-	h <- readIORef $ fHeight f-	return $ Vertex2+	(w, h) <- readIORef $ fSize f+	return $ G.Vertex2 		(fromRational $ 2 * toRational x / fromIntegral w) 		(fromRational $ 2 * toRational y / fromIntegral h)-positionToVertex3 _ _ = error "positionToVertex3: not implemented"+positionToVertex3 f (TopLeft x y) = do+	(w, h) <- readIORef $ fSize f+	let	x' = 2 * toRational x / fromIntegral w - 1+		y' = 1 - 2 * toRational y / fromIntegral h+	return $ G.Vertex2 (fromRational x') (fromRational y') -writeString :: Field -> Layer -> String -> Double -> Color -> Position ->+writeString :: Field -> String -> Double -> Color -> Position -> 	String -> IO ()-writeString f _ _fname size clr (Center x_ y_) str =+writeString f _fname size clr (Center x_ y_) str = 	atomicModifyIORef_ (fActions f) (Just action :) 	where-	action = preservingMatrix $ do-		h <- readIORef $ fHeight f-		w <- readIORef $ fWidth f+	action = G.preservingMatrix $ do+		(w, h) <- readIORef $ fSize f 		let	size' = size / 15-			ratio = 3.5 * fromIntegral h -- 2000+			ratio = 3.5 * fromIntegral h 			x_ratio = 2 * ratio / fromIntegral w 			y_ratio = 2 * ratio / fromIntegral h 			x = x_ratio * fromRational (toRational $ x_ / size') 			y = y_ratio * fromRational (toRational $ y_ / size')---			s = 0.0005 * fromRational (toRational size') 			s = 1 / ratio * fromRational (toRational size') 		G.color $ colorToColor4 clr-		G.scale (s :: GLfloat) (s :: GLfloat) (s :: GLfloat)+		G.scale (s :: G.GLfloat) (s :: G.GLfloat) (s :: G.GLfloat) 		G.clearColor $= G.Color4 0 0 0 0-		G.translate (G.Vector3 x y 0 :: G.Vector3 GLfloat)+		G.translate (G.Vector3 x y 0 :: G.Vector3 G.GLfloat) 		G.renderString G.Roman str-writeString _ _ _ _ _ _ _ = error "writeString: not implemented"+writeString _ _ _ _ _ _ = error "writeString: not implemented" -drawImage :: Field -> Layer -> FilePath -> Position -> Double -> Double -> IO ()-drawImage _f _ _fp _pos _w _h = return ()+drawImage :: Field -> FilePath -> Position -> Double -> Double -> IO ()+drawImage _f _fp _pos _w _h = return () -fillRectangle :: Field -> Layer -> Position -> Double -> Double -> Color -> IO ()-fillRectangle f _ p w h clr = do return ()-{--	atomicModifyIORef_ (fActions f) (makeQuads f [-		Center 0 0, Center 0 100, Center 100 100, Center 100 0] clr])--}+fillRectangle :: Field -> Position -> Double -> Double -> Color -> IO ()+fillRectangle _f _p _w _h _clr = return () -fillPolygon :: Field -> Layer -> [Position] -> Color -> Color -> Double -> IO ()-fillPolygon f _ ps clr lc lw = do+fillPolygon :: Field -> [Position] -> Color -> Color -> Double -> IO ()+fillPolygon f ps clr lc lw = do 	atomicModifyIORef_ (fActions f) (Just (makeCharacterAction f ps clr lc lw) :) 	atomicModifyIORef_ (fChanged f) (+ 1)  -------------------------------------------------------------------------------- -drawCharacter :: Field -> Character -> Color -> Color -> [Position] -> Double -> IO ()-drawCharacter f _ fclr clr sh lw = do+drawCharacter :: Field -> Color -> Color -> [Position] -> Double -> IO ()+drawCharacter f fclr clr sh lw = do 	makeCharacterAction f sh fclr clr lw 	writeIORef (fAction f) $ 		makeCharacterAction f sh fclr clr lw 	atomicModifyIORef_ (fChanged f) (+ 1) -drawCharacterAndLine ::	Field -> Character -> Color -> Color -> [Position] ->+drawCharacterAndLine ::	Field -> Color -> Color -> [Position] -> 	Double -> Position -> Position -> IO ()-drawCharacterAndLine f _ fclr clr sh lw p q = do---	makeLineAction f p q clr lw---	makeCharacterAction f sh fclr clr lw+drawCharacterAndLine f fclr clr sh lw p q = do 	writeIORef (fAction f) $ do 		makeLineAction f p q clr lw 		makeCharacterAction f sh fclr clr lw@@ -431,14 +415,21 @@  -------------------------------------------------------------------------------- +getConsole :: Field -> IO (Maybe Console)+getConsole = readIORef . fConsole+ outputString :: Field -> String -> IO ()-outputString f = atomicModifyIORef_ (fString2 f) . (:)+outputString f str = do+	mc <- getConsole f+	case mc of+		Just c -> atomicModifyIORef_ (cHistory c) (str :)+		_ -> return ()  oninputtext :: Field -> (String -> IO Bool) -> IO () oninputtext = writeIORef . fInputtext  onclick, onrelease :: Field -> (Int -> Double -> Double -> IO Bool) -> IO ()-onclick _ _ = return ()+onclick f act = writeIORef (fOnclick f) act onrelease _ _ = return ()  ondrag :: Field -> (Int -> Double -> Double -> IO ()) -> IO ()@@ -452,30 +443,3 @@  ontimer :: Field -> Int -> IO Bool -> IO () ontimer _ _ _ = return ()--keyboardProc :: Field -> G.Key -> G.KeyState -> G.Modifiers -> G.Position -> IO ()-keyboardProc f (G.Char '\r') G.Down _ _ = do-	p <- readIORef $ fPrompt f-	str <- readIORef (fString f)-	atomicModifyIORef_ (fString2 f) (reverse str ++)-	writeIORef (fString f) [p]-	continue <- ($ drop (length p) $ concat str) =<< readIORef (fInputtext f)-	unless continue G.leaveMainLoop-keyboardProc f (G.Char '\b') G.Down _ _ = do-	p <- readIORef $ fPrompt f-	atomicModifyIORef_ (fString f) $ \s -> case s of-		[""] -> [""]-		[ss] | length ss <= length p -> s-		s -> case last s of-			"" -> init (init s) ++ [init $ last $ init s]-			_ -> init s ++ [init $ last s]-keyboardProc f (G.Char c) state _ _-	| state == G.Down = atomicModifyIORef_ (fString f) (`addToTail` c)-	| otherwise = return ()-keyboardProc _ _ _ _ _ = return ()--addToTail :: [String] -> Char -> [String]-addToTail strs c-	| null strs = error "bad"-	| length (last strs) < 50 = init strs ++ [last strs ++ [c]]-	| otherwise = strs ++ [[c]]
+ src/Graphics/UI/GLUT/Turtle/GLUTools.hs view
@@ -0,0 +1,71 @@+module Graphics.UI.GLUT.Turtle.GLUTools (+	initialize,+	createWindow,+	printLines,+	keyboardCallback,+	displayAction,+	loop,++	module Graphics.UI.GLUT+) where++import Graphics.UI.GLUT hiding (initialize, createWindow)+import qualified Graphics.UI.GLUT as G+import System.Environment+import Control.Monad+import Data.IORef+import Data.IORef.Tools++initialize :: IO [String]+initialize = do+	prgName <- getProgName+	rawArgs <- getArgs+	args <- G.initialize prgName rawArgs+	initialDisplayMode $= [RGBMode, DoubleBuffered]+	return args++createWindow :: String -> Int -> Int -> IO Window+createWindow name w h = do+	initialWindowSize $= Size (fromIntegral w) (fromIntegral h)+	G.createWindow name++printLines :: G.Window -> Double -> [String] -> IO ()+printLines win w strs = do+	G.currentWindow $= Just win+	G.clearColor $= G.Color4 0 0 0 0+	G.clear [G.ColorBuffer]+	G.lineWidth $= (fromRational $ toRational w)+	zipWithM_ (printString (-2.8)) [-1800, -1600 .. 1800] strs+	G.swapBuffers++printString :: G.GLfloat -> G.GLfloat -> String -> IO ()+printString x y str =+	G.preservingMatrix $ do+		G.scale (0.0005 :: G.GLfloat)  0.0005 0.0005+		G.clearColor $= G.Color4 0 0 0 0+		G.color (G.Color4 0 1 0 0 :: G.Color4 G.GLfloat)+		w <- G.stringWidth G.Roman "Stroke font"+		G.translate (G.Vector3 (x * fromIntegral w)+			y 0 :: G.Vector3 G.GLfloat)+		G.renderString G.Roman str++keyboardCallback ::+	(Char -> G.KeyState -> G.Modifiers -> G.Position -> IO ()) -> IO ()+keyboardCallback f = G.keyboardMouseCallback $= Just (\k ks m p -> case k of+	G.Char chr -> do+		f chr ks m p+	_ -> return ())++displayAction :: IORef Int -> IO () -> IO ()+displayAction changed act = loop changed act >> G.displayCallback $= act++loop :: IORef Int -> IO a -> IO ()+loop changed act = G.addTimerCallback 10 $ timerAction changed act++timerAction :: IORef Int -> IO a -> IO ()+timerAction changed act = do+	c <- readIORef changed+	when (c > 0) $ do+		_ <- act+		atomicModifyIORef_ changed (subtract 1)+	G.addTimerCallback 10 $ timerAction changed act
− src/Graphics/UI/GLUT/Turtle/Layers.hs 
@@ -1,100 +0,0 @@-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
@@ -7,8 +7,9 @@  	-- * process Field 	openField,+	openConsole,+	setConsole, 	closeField,-	waitField, 	topleft, 	center, 	coordinates,@@ -18,7 +19,6 @@ 	-- * draws 	forkField, 	flushField,-	clearLayer, 	clearCharacter, 	moveTurtle, @@ -30,8 +30,8 @@ 	onmotion, 	onkeypress, 	ontimer,-	addLayer,-	addCharacter,+--	addLayer,+--	addCharacter,  	outputString, @@ -40,10 +40,10 @@  import Graphics.UI.GLUT.Turtle.State(TurtleState(..), makeShape) import Graphics.UI.GLUT.Turtle.Field(prompt, initialize, setFieldSize,-	Field(fRunning), Layer, Character, Coordinates(..),-	openField, closeField, waitField, coordinates, topleft, center,-	fieldSize, forkField, flushField, clearLayer,-	clearCharacter, addLayer, addCharacter,+	Field, Coordinates(..), openConsole, setConsole,+	openField, closeField, coordinates, topleft, center,+	fieldSize, forkField, flushField,+	clearCharacter, 	oninputtext, onclick, onrelease, ondrag, onmotion, onkeypress, ontimer, 	fieldColor, drawLine, fillRectangle, fillPolygon, writeString, 	drawImage, undoField, drawCharacter, drawCharacterAndLine,@@ -55,14 +55,12 @@ import Control.Monad(when, unless, forM_) import Data.Maybe(isJust) -import Data.IORef- -------------------------------------------------------------------------------- -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+moveTurtle :: Field -> TurtleState -> TurtleState -> IO ()+moveTurtle _ _ TurtleState{sleep = Just t} = threadDelay $ 1000 * t+moveTurtle f _ TurtleState{flush = True} = flushField f True $ return ()+moveTurtle f t0 t1 = do 	(w, h) <- fieldSize f 	when (undo t1) $ fl $ do 		when (clear t0) redraw@@ -70,32 +68,30 @@ 			undoField f 			when (visible t1) $ drawTtl (direction t0) $ position t0 	when (visible t1) $ do-		writeIORef (fRunning f) True 		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-		writeIORef (fRunning f) False 	when (visible t0 && not (visible t1)) $ fl $ clearCharacter f-	when (clear t1) $ fl $ clearLayer l-	unless (undo t1) $ fl $ maybe (return ()) (drawSVG f l) (draw t1)+--	when (clear t1) $ fl $ clearLayer l+	unless (undo t1) $ fl $ maybe (return ()) (drawSVG f) (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+	redraw = mapM_ (drawSVG f) $ reverse $ drawed t1+	drawTtl dir pos = drawTurtle f 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"+drawSVG :: Field -> SVG -> IO ()+drawSVG f (Line p0 p1 clr lw) = drawLine f lw clr p0 p1+drawSVG f (Rect pos w h 0 fc _) = fillRectangle f pos w h fc+drawSVG f (Polyline ps fc lc lw) = fillPolygon f ps fc lc lw+drawSVG f (Fill clr) = fieldColor f clr+drawSVG f (Text pos sz clr fnt str) = writeString f fnt sz clr pos str+drawSVG f (Image pos w h fp) = drawImage f fp pos w h+drawSVG _ _ = error "not implemented"  positions :: Double -> Double -> TurtleState -> TurtleState -> [Position] positions w h t0 t1 =@@ -121,8 +117,8 @@ 		ds = direction t0 		de = direction t1 -drawTurtle :: Field -> Character -> TurtleState -> Double -> Position ->+drawTurtle :: Field -> 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)+drawTurtle f ts@TurtleState{fillcolor = fclr, pencolor = clr} dir pos = maybe+	(drawCharacter f fclr clr (makeShape ts dir pos) (pensize ts))+	(drawCharacterAndLine f fclr clr (makeShape ts dir pos) (pensize ts) pos)
src/Graphics/UI/GLUT/Turtle/Triangles.hs view
@@ -2,16 +2,28 @@  import Graphics.UI.GLUT.Turtle.TriangleTools +isHoleRight :: [Pos] -> Bool+isHoleRight ps = isRight tri+	where+	i = far ps+	tri = index3 ps i+ toTriangles :: [Pos] -> [(Pos, Pos, Pos)] toTriangles ps+	| isHoleRight ps = toTriangles' ps+	| otherwise = toTriangles' $ reverse ps++toTriangles' :: [Pos] -> [(Pos, Pos, Pos)]+toTriangles' ps 	| length ps < 3 = [] 	| otherwise = toTrianglesTop $ deleteOnline $ deletePoint ps +deletePoint :: Eq a => [a] -> [a] deletePoint [] = [] deletePoint [p] = [p]-deletePoint pa@(p0 : ps)+deletePoint pall@(p0 : ps) 	| p0 == last ps = ps-	| otherwise = pa+	| otherwise = pall  toTrianglesTop :: [Pos] -> [(Pos, Pos, Pos)] toTrianglesTop [a, b, c] = [(a, b, c)]
tests/testGLUT.hs view
@@ -5,8 +5,11 @@ main = do 	_args <- initialize 	f <- openField "test" 640 480+	c <- openConsole "console" 640 480+	setConsole f c 	prompt f "> " 	t <- newTurtle f+	onclick f $ \_bn x y -> goto t x y >> return True 	oninputtext f (processInput f t) --	speed t "slowest" --	fillcolor t ((255, 255, 255) :: (Int, Int, Int))@@ -36,12 +39,15 @@ processInput _ t "penup" = penup t >> return True processInput _ t "pendown" = pendown t >> return True processInput _ t "message" = write t "KochiGothic" 100 "Hello, world!" >> return True-processInput _ t "0very1very2very3very4very5very6very7very8very9very0very-long-line"+processInput _ _ "0very1very2very3very4very5very6very7very8very9very0very-long-line" 	= putStrLn "very long line" >> return True processInput _ t "hide" = hideturtle t >> return True processInput _ t "bred" = bgcolor t ((255, 0, 0) :: (Int, Int, Int)) >> return True processInput _ t "bgreen" = bgcolor t ((0, 255, 0) :: (Int, Int, Int)) >> return True processInput _ t "home" = goto t 0 0 >> return True processInput _ t "undo" = undo t >> return True-processInput f t "size" = setFieldSize f 100 200 >> return True+processInput f _ "size" = setFieldSize f 100 200 >> return True+processInput f _ "topleft" = topleft f >> return True+processInput f _ "center" = center f >> return True+processInput _ t "goto100" = goto t 100 100 >> return True processInput _ _ _ = return True