gluturtle 0.0.20 → 0.0.23

raw patch · 6 files changed

+78/−40 lines, 6 files

Files

gluturtle.cabal +1/−1
src/Graphics/UI/GLUT/Turtle.hs +9/−2
src/Graphics/UI/GLUT/Turtle/Field.hs +56/−24
src/Graphics/UI/GLUT/Turtle/Move.hs +4/−1
tests/randomTurtle.hs +2/−5
tests/testGLUT.hs +6/−7

gluturtle.cabal view

@@ -2,7 +2,7 @@ cabal-version:	>= 1.6  name:		gluturtle-version:	0.0.20+version:	0.0.23 stability:	alpha author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>

src/Graphics/UI/GLUT/Turtle.hs view

@@ -10,6 +10,7 @@ 	Field, 	Turtle, 	ColorClass,+	setFieldSize,  	-- * Field functions 	-- ** meta@@ -47,6 +48,7 @@ 	setheading, 	circle, 	home,+	notundo, 	undo, 	sleep, 	flush,@@ -95,7 +97,9 @@  	outputString, -	prompt+	prompt,++	initialize ) where  import Graphics.UI.GLUT.Turtle.Data(shapeTable, speedTable)@@ -103,7 +107,7 @@ 	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(prompt,+import Graphics.UI.GLUT.Turtle.Move(prompt, initialize, setFieldSize, 	Field, Coordinates(..), openField, closeField, waitField, 	topleft, center, coordinates, fieldSize, forkField, flushField, 	addLayer, clearLayer, addCharacter, clearCharacter, moveTurtle,@@ -214,6 +218,9 @@  home :: Turtle -> IO () home t = goto t 0 0 >> setheading t 0 >> input t (Undonum 3)++notundo :: Turtle -> IO ()+notundo t = input t $ Undonum 0  undo :: Turtle -> IO () undo t = info t undonum >>= flip replicateM_ (input t Undo)

src/Graphics/UI/GLUT/Turtle/Field.hs view

@@ -1,6 +1,8 @@ {-# LANGUAGE DoRec #-}  module Graphics.UI.GLUT.Turtle.Field(+	initialize,+ 	-- * types and classes 	Field, 	Layer,@@ -15,6 +17,7 @@ 	center, 	coordinates, 	fieldSize,+	setFieldSize,  	-- * draw 	forkField,@@ -76,9 +79,16 @@ 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 f p = do 	writeIORef (fPrompt f) p 	atomicModifyIORef_ (fString f) (\ls -> init ls ++ [p ++ last ls])@@ -97,8 +107,8 @@  	fInputtext :: IORef (String -> IO Bool), -	fWidth :: Int,-	fHeight :: Int,+	fWidth :: IORef Int,+	fHeight :: IORef Int,  	fFieldWindow :: Window, 	fConsoleWindow :: Window,@@ -126,6 +136,8 @@  openField :: String -> Int -> Int -> IO Field openField name w h = do+	fw <- newIORef w+	fh <- newIORef h 	layers <- newLayers 0 (return ()) (return ()) (return ()) 	bgc <- newIORef $ [RGB 255 255 255] 	action <- newIORef $ return ()@@ -168,8 +180,8 @@ 		fActions = actions, 		fString = str, 		fString2 = str2,-		fWidth = w,-		fHeight = h,+		fWidth = fw,+		fHeight = fh, 		fInputtext = inputtext, 		fFieldWindow = wt, 		fConsoleWindow = wc,@@ -212,7 +224,10 @@ coordinates = return . fCoordinates  fieldSize :: Field -> IO (Double, Double)-fieldSize f = return (fromIntegral $ fWidth f, fromIntegral $ fHeight f)+fieldSize f = do+	w <- readIORef $ fWidth f+	h <- readIORef $ fHeight f+	return (fromIntegral w, fromIntegral h)  -------------------------------------------------------------------------------- @@ -242,6 +257,15 @@  -------------------------------------------------------------------------------- +setFieldSize :: Field -> Double -> Double -> IO ()+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)+ drawLine :: Field -> Layer -> Double -> Color -> Position -> Position -> IO () drawLine f _ w c p q = do 	atomicModifyIORef_ (fActions f) (Just (makeLineAction f p q c w) :)@@ -253,9 +277,9 @@ makeLineAction f p q c w = preservingMatrix $ do 	G.lineWidth $= fromRational (toRational w) 	G.color $ colorToColor4 c -- (G.Color4 1 0 0 0 :: G.Color4 GLfloat)-	renderPrimitive Lines $ mapM_ vertex [-		positionToVertex3 f p,-		positionToVertex3 f q ]+	pp <- positionToVertex3 f p+	qq <- positionToVertex3 f q+	renderPrimitive Lines $ mapM_ vertex [pp, qq]  colorToColor4 :: Color -> G.Color4 GLfloat colorToColor4 (RGB r g b) = G.Color4@@ -263,24 +287,27 @@ colorToColor4 _ = error "colorToColor4: not implemented"  makeQuads :: Field -> [Position] -> Color -> IO ()-makeQuads f ps c =+makeQuads f ps c = do+	vs <- mapM (positionToVertex3 f) ps 	preservingMatrix $ do 		G.color $ colorToColor4 c-		renderPrimitive Quads $-			mapM_ (vertex . positionToVertex3 f) ps+		renderPrimitive Quads $ mapM_ vertex vs  makeCharacterAction :: Field -> [Position] -> Color -> Color -> Double -> IO ()-makeCharacterAction f ps c lc lw =+makeCharacterAction f ps c lc lw = do+	vs <- mapM (positionToVertex3 f . posToPosition) $+		triangleToPositions $ toTriangles $ map positionToPos ps+	vs' <- mapM (positionToVertex3 f) ps 	preservingMatrix $ do 		G.color $ colorToColor4 c-		renderPrimitive Triangles $-			mapM_ (vertex . positionToVertex3 f . posToPosition) $-			triangleToPositions $-			toTriangles $ map positionToPos ps+		renderPrimitive Triangles $ mapM_ vertex vs+--			mapM_ vertex . positionToVertex3 f . posToPosition) $+--			triangleToPositions $+--			toTriangles $ map positionToPos ps --		renderPrimitive Polygon $ mapM_ (vertex . positionToVertex3 f) ps 		G.lineWidth $= fromRational (toRational lw) 		G.color $ colorToColor4 lc-		renderPrimitive LineLoop $ mapM_ (vertex . positionToVertex3 f) ps+		renderPrimitive LineLoop $ mapM_ vertex vs'  type Pos = (Double, Double) triangleToPositions :: [(Pos, Pos, Pos)] -> [Pos]@@ -294,10 +321,13 @@ posToPosition :: Pos -> Position posToPosition (x, y) = Center x y -positionToVertex3 :: Field -> Position -> Vertex2 GLfloat-positionToVertex3 f (Center x y) =-	Vertex2 (fromRational $ 2 * toRational x / fromIntegral (fWidth f))-		(fromRational $ 2 * toRational y / fromIntegral (fHeight f))+positionToVertex3 :: Field -> Position -> IO (Vertex2 GLfloat)+positionToVertex3 f (Center x y) = do+	w <- readIORef $ fWidth f+	h <- readIORef $ fHeight f+	return $ Vertex2+		(fromRational $ 2 * toRational x / fromIntegral w)+		(fromRational $ 2 * toRational y / fromIntegral h) positionToVertex3 _ _ = error "positionToVertex3: not implemented"  writeString :: Field -> Layer -> String -> Double -> Color -> Position ->@@ -306,10 +336,12 @@ 	atomicModifyIORef_ (fActions f) (Just action :) 	where 	action = preservingMatrix $ do+		h <- readIORef $ fHeight f+		w <- readIORef $ fWidth f 		let	size' = size / 15-			ratio = 3.5 * fromIntegral (fHeight f) -- 2000-			x_ratio = 2 * ratio / fromIntegral (fWidth f)-			y_ratio = 2 * ratio / fromIntegral (fHeight f)+			ratio = 3.5 * fromIntegral h -- 2000+			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')

src/Graphics/UI/GLUT/Turtle/Move.hs view

@@ -1,4 +1,6 @@ module Graphics.UI.GLUT.Turtle.Move(+	initialize,+ 	-- * types 	Field, 	Coordinates(..),@@ -11,6 +13,7 @@ 	center, 	coordinates, 	fieldSize,+	setFieldSize,  	-- * draws 	forkField,@@ -36,7 +39,7 @@ ) where  import Graphics.UI.GLUT.Turtle.State(TurtleState(..), makeShape)-import Graphics.UI.GLUT.Turtle.Field(prompt,+import Graphics.UI.GLUT.Turtle.Field(prompt, initialize, setFieldSize, 	Field, Layer, Character, Coordinates(..), 	openField, closeField, waitField, coordinates, topleft, center, 	fieldSize, forkField, flushField, clearLayer,

tests/randomTurtle.hs view

@@ -1,17 +1,14 @@ module Main where  import Graphics.UI.GLUT.Turtle-import Graphics.UI.GLUT(initialize, addTimerCallback, mainLoop)+import Graphics.UI.GLUT(addTimerCallback, mainLoop) import System.Random-import System.Environment import Control.Monad import Data.Word  main :: IO () main = do-	prgName <- getProgName-	rawArgs <- getArgs-	_args <- initialize prgName rawArgs+	_args <- initialize 	f <- openField "random" 480 480 	t <- newTurtle f --	pencolor t "white"

tests/testGLUT.hs view

@@ -1,13 +1,9 @@ import Graphics.UI.GLUT.Turtle-import Graphics.UI.GLUT hiding (position)--import System.Environment+import Graphics.UI.GLUT hiding (position, initialize)  main :: IO () main = do-	prgName <- getProgName-	rawArgs <- getArgs-	_args <- initialize prgName rawArgs+	_args <- initialize 	f <- openField "test" 640 480 	prompt f "> " 	t <- newTurtle f@@ -28,7 +24,8 @@ processInput _ t "end" = endfill t >> return True processInput _ t "turtle" = shape t "turtle" >> return True processInput _ t "stamp" = stamp t >> return True-processInput _ t "bold" = pensize t 3 >> return True+processInput _ t "bold" = pensize t 7 >> return True+processInput _ t "verybold" = pensize t 10 >> return True processInput _ t "big" = shapesize t 3 3 >> return True processInput _ t "blue" = pencolor t ((0, 0, 255) :: (Int, Int, Int)) >> return True processInput _ t "fblue" = fillcolor t ((0, 0, 255) :: (Int, Int, Int)) >> return True@@ -37,6 +34,7 @@ processInput _ _ "exit" = return False processInput f t "position" = position t >>= outputString f . show >> return True 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" 	= putStrLn "very long line" >> return True@@ -45,4 +43,5 @@ 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 _ _ _ = return True