packages feed

gluturtle 0.0.33 → 0.0.35

raw patch · 7 files changed

+432/−352 lines, 7 filesdep +stm

Dependencies added: stm

Files

gluturtle.cabal view
@@ -2,7 +2,7 @@ cabal-version:	>= 1.6  name:		gluturtle-version:	0.0.33+version:	0.0.35 stability:	alpha author:		Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer:	Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -24,13 +24,14 @@   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, GLUT+    yjsvg >= 0.1.14, GLUT, stm   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.Triangles, Graphics.UI.GLUT.Turtle.TriangleTools,-    Graphics.UI.GLUT.Turtle.GLUTools+    Graphics.UI.GLUT.Turtle.GLUTools,+    Graphics.UI.GLUT.Turtle.Console  executable		testTurtle   Hs-source-dirs:	tests, src
src/Graphics/UI/GLUT/Turtle.hs view
@@ -8,6 +8,7 @@  	-- * types and classes 	Field,+	Console, 	Turtle, 	ColorClass, 	setFieldSize,@@ -22,7 +23,7 @@ 	center,  	-- ** on events-	oninputtext,+	oncommand, 	onclick, 	onrelease, 	ondrag,@@ -96,9 +97,9 @@ 	windowWidth, 	windowHeight, -	outputString,+	consoleOutput, -	prompt,+	consolePrompt,  	initialize ) where@@ -108,12 +109,12 @@ 	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, initialize, setFieldSize,+import Graphics.UI.GLUT.Turtle.Move(consolePrompt, initialize, setFieldSize, Console, 	Field, Coordinates(..), openField, closeField, 	topleft, center, coordinates, fieldSize, forkField, flushField, 	clearCharacter, moveTurtle,-	oninputtext, onclick, onrelease, ondrag, onmotion, onkeypress, ontimer,-	outputString, openConsole, setConsole)+	oncommand, onclick, onrelease, ondrag, onmotion, onkeypress, ontimer,+	consoleOutput, openConsole, setConsole) import Text.XML.YJSVG(SVG(..), Position(..), Color(..)) import qualified Text.XML.YJSVG as S(center, topleft) @@ -152,7 +153,6 @@ 	index <- newIORef 1; shapesRef <- newIORef shapeTable 	chan <- newChan; hist <- getChanContents chan 	let states = turtleSeries hist---	_ <- addLayer f; c <- addCharacter f 	thr <- forkField f $ zipWithM_ (moveTurtle f) states $ tail states 	let t = Turtle { 		field = f,@@ -161,7 +161,6 @@ 		shapes = shapesRef, 		inputs = fmap (flip take hist . pred) $ readIORef index, 		killTurtle = flushField f True $---			clearLayer l >> 			clearCharacter f >> killThread thr} 	shape t "classic" >> input t (Undonum 0) >> return t
+ src/Graphics/UI/GLUT/Turtle/Console.hs view
@@ -0,0 +1,79 @@+module Graphics.UI.GLUT.Turtle.Console (+	Console,+	openConsole,+	consolePrompt,+	consoleOutput,+	consoleKeyboard,+	consoleCommand+) where++import Graphics.UI.GLUT.Turtle.GLUTools(+	KeyState(..), Modifiers,+	createWindow, printCommands, keyboardCallback, displayAction)+import Data.IORef(IORef, newIORef, readIORef, writeIORef)+import Data.IORef.Tools(atomicModifyIORef_)+import Control.Applicative((<$>))+import Control.Concurrent.STM(atomically)+import Control.Concurrent.STM.TChan(+	TChan, newTChan, readTChan, writeTChan, isEmptyTChan)++--------------------------------------------------------------------------------++data Console = Console{+	cPrompt :: IORef String,+	cCommand :: IORef String,+	cHistory :: IORef [String],+	cUpdate :: IORef Int,+	cResult :: TChan String+ }++openConsole :: String -> Int -> Int -> IO Console+openConsole name w h = do+	cwindow <- createWindow name w h+	cprompt <- newIORef ""+	ccommand <- newIORef ""+	chistory <- newIORef []+	cupdate <- newIORef 1+	cresult <- atomically newTChan+	let	console = Console{+			cPrompt = cprompt,+			cCommand = ccommand,+			cHistory = chistory,+			cUpdate = cupdate,+			cResult = cresult }+	keyboardCallback $ consoleKeyboard console+	displayAction cupdate $ do+		prmpt <- readIORef cprompt+		cmd <- readIORef ccommand+		hst <- readIORef chistory+		printCommands cwindow $ (prmpt ++ reverse cmd) : hst+	return console++consolePrompt :: Console -> String -> IO ()+consolePrompt = writeIORef . cPrompt++consoleOutput :: Console -> String -> IO ()+consoleOutput console str = do+	atomicModifyIORef_ (cUpdate console) succ+	atomicModifyIORef_ (cHistory console) (str :)++consoleKeyboard :: Console -> Char -> KeyState -> Modifiers -> IO ()+consoleKeyboard console '\r' Down _ = do+	atomicModifyIORef_ (cUpdate console) succ+	prmpt <- readIORef $ cPrompt console+	cmd <- readIORef $ cCommand console+	atomicModifyIORef_ (cHistory console) $ ((prmpt ++ reverse cmd) :)+	writeIORef (cCommand console) ""+	atomically $ writeTChan (cResult console) $ reverse cmd+consoleKeyboard console '\b' Down _ = do+	atomicModifyIORef_ (cUpdate console) succ+	atomicModifyIORef_ (cCommand console) $ drop 1+consoleKeyboard console chr Down _ = do+	atomicModifyIORef_ (cUpdate console) succ+	atomicModifyIORef_ (cCommand console) (chr :)+consoleKeyboard _ _ _ _ = return ()++consoleCommand :: Console -> IO (Maybe String)+consoleCommand console = atomically $ do+	emp <- isEmptyTChan $ cResult console+	if emp then return Nothing else Just <$> readTChan (cResult console)
src/Graphics/UI/GLUT/Turtle/Field.hs view
@@ -2,13 +2,12 @@  	-- * types and classes 	Field,+	Console, 	Coordinates(..),  	-- * basic functions 	initialize, 	openField,-	openConsole,-	setConsole, 	closeField, 	topleft, 	center,@@ -16,6 +15,12 @@ 	fieldSize, 	setFieldSize, +	-- * about Console+	openConsole,+	setConsole,+	consolePrompt,+	consoleOutput,+ 	-- * draw 	forkField, 	flushField,@@ -27,6 +32,7 @@ 	fillPolygon, 	writeString, 	drawImage,+	clearField, 	undoField,  	-- ** to Character@@ -34,230 +40,119 @@ 	drawCharacterAndLine, 	clearCharacter, -	outputString,- 	-- * event driven-	oninputtext,+	oncommand, 	onclick, 	onrelease, 	ondrag, 	onmotion, 	onkeypress,-	ontimer,--	prompt+	ontimer ) where -import Control.Monad--import Graphics.UI.GLUT.Turtle.Triangles--import qualified Graphics.UI.GLUT.Turtle.GLUTools as G+import Graphics.UI.GLUT.Turtle.Console(+	Console, openConsole, consolePrompt, consoleOutput,+	consoleKeyboard, consoleCommand) import Graphics.UI.GLUT.Turtle.GLUTools(-	($=), initialize, createWindow, printLines, keyboardCallback, loop,-	displayAction)+	Window, Key(..), KeyState(..), Modifiers,+	initialize, createWindow, loop, displayAction, keyboardMouseCallback,+	currentWindow, swapBuffers, leaveUnless,+	windowColor, windowSize, setWindowSize,+	glDrawLine, drawPolygon, glWriteString) import Text.XML.YJSVG(Position(..), Color(..)) -import Control.Concurrent(ThreadId, forkIO, Chan, newChan, writeChan, readChan)-import Data.IORef(IORef, newIORef, readIORef, writeIORef)+import Control.Arrow((***))+import Control.Applicative((<$>))+import Control.Monad(when, join)+import Control.Concurrent(ThreadId, forkIO)+import Data.Maybe(isNothing, catMaybes)+import Data.IORef(IORef, newIORef, readIORef, writeIORef, atomicModifyIORef) import Data.IORef.Tools(atomicModifyIORef_)-import Data.Maybe  -------------------------------------------------------------------------------- -prompt :: Field -> String -> IO ()-prompt f p = do-	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{-	fConsole :: IORef (Maybe Console),--	fFieldWindow :: G.Window,+	fWindow :: Window, 	fSize :: IORef (Int, Int), 	fCoordinates :: IORef Coordinates, 	fBgcolor :: IORef [Color], +	fUpdate :: IORef Int, 	fAction :: IORef (IO ()), 	fActions :: IORef [Maybe (IO ())], -	fChanged :: IORef Int,--	fInputtext :: IORef (String -> IO Bool),+	fConsole :: IORef (Maybe Console),+	fOncommand :: IORef (String -> IO Bool), 	fOnclick :: IORef (Int -> Double -> Double -> IO Bool)  }  -------------------------------------------------------------------------------- -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--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 	fsize <- newIORef (w, h) 	fcoord <- newIORef CoordCenter 	fbgcolor <- newIORef [RGB 255 255 255]- 	faction <- newIORef $ return () 	factions <- newIORef []--	fchanged <- newIORef 0-	finputtext <- newIORef $ const $ return True+	fupdate <- newIORef 0+	foncommand <- 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]-			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))-+	fwindow <- createWindow name w h 	fconsole <- newIORef Nothing-	let f = Field{-		fConsole = fconsole,--		fFieldWindow = ffield,-		fSize = fsize,-		fCoordinates = fcoord,-		fBgcolor = fbgcolor,--		fAction = faction,-		fActions = factions,--		fChanged = fchanged,--		fInputtext = finputtext,-		fOnclick = fclick-	 }-	G.keyboardMouseCallback $= Just (processKeyboardMouse f)--	return f+	let	field = Field{+			fConsole = fconsole,+			fWindow = fwindow,+			fSize = fsize,+			fCoordinates = fcoord,+			fBgcolor = fbgcolor,+			fAction = faction,+			fActions = factions,+			fUpdate = fupdate,+			fOncommand = foncommand,+			fOnclick = fclick }+	keyboardMouseCallback $ procKboardMouse field+	displayAction fupdate $ do+		currentWindow fwindow+		writeIORef fsize =<< windowSize+		windowColor . colorToInts . head =<< readIORef fbgcolor+		sequence_ . reverse . catMaybes =<< readIORef factions+		join $ readIORef faction+		swapBuffers+	return field  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+setConsole f c = (writeIORef (fConsole f) (Just c) >>) $ loop $ do+	mcmd <- consoleCommand c+	case mcmd of+		Just cmd -> readIORef (fOncommand f) >>= ($ cmd) >>= leaveUnless+		_ -> return () -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)+procKboardMouse ::+	Field -> Key -> KeyState -> Modifiers -> (Double, Double) -> IO ()+procKboardMouse Field{fConsole = con} (Char chr) ks m _ = readIORef con >>=+	maybe (return ()) (\c -> consoleKeyboard c chr ks m)+procKboardMouse field (MouseButton mb) Down _ (x, y) = do+	coord <- readIORef $ fCoordinates field+	fun <- readIORef $ fOnclick field 	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 ()--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+			(w, h) <- fieldSize field+			fun mb (x - w / 2) (h / 2 - y)+		CoordTopLeft -> fun mb x y+	leaveUnless continue+procKboardMouse _f (MouseButton _mb) Up _m _p = return ()+procKboardMouse _f (SpecialKey _sk) _ks _m _p = return ()  undoField :: Field -> IO () undoField f = do-	a : _ <- readIORef $ fActions f-	when (isNothing a) $ atomicModifyIORef_ (fBgcolor f) tail-	atomicModifyIORef_ (fActions f) tail+	ret <- atomicModifyIORef (fActions f) (\(h : t) -> (t, h))+	when (isNothing ret) $ atomicModifyIORef_ (fBgcolor f) tail  closeField :: Field -> IO ()-closeField _ = G.leaveMainLoop+closeField _ = return ()  topleft, center :: Field -> IO () topleft = flip writeIORef CoordTopLeft . fCoordinates@@ -267,9 +162,7 @@ coordinates = readIORef . fCoordinates  fieldSize :: Field -> IO (Double, Double)-fieldSize f = do-	(w, h) <- readIORef $ fSize f-	return (fromIntegral w, fromIntegral h)+fieldSize f = (fromIntegral *** fromIntegral) <$> readIORef (fSize f)  -------------------------------------------------------------------------------- @@ -284,102 +177,43 @@ 	atomicModifyIORef_ (fBgcolor f) (clr :) 	atomicModifyIORef_ (fActions f) (Nothing :) -makeFieldColor :: Color -> IO ()-makeFieldColor clr = G.preservingMatrix $ do-	G.color $ colorToColor4 clr-	G.renderPrimitive G.Quads $ mapM_ G.vertex [-		G.Vertex2 (-1) (-1),-		G.Vertex2 (-1) 1,-		G.Vertex2 1 1,-		G.Vertex2 1 (-1) :: G.Vertex2 G.GLfloat ]- --------------------------------------------------------------------------------  setFieldSize :: Field -> Double -> Double -> IO () setFieldSize f w_ h_ = do-	let	w = round w_-		h = round h_+	let	(w, h) = (round *** round) (w_, h_) 	writeIORef (fSize f) (w, h)-	G.currentWindow $= Just (fFieldWindow f)-	G.windowSize $= G.Size (fromIntegral w) (fromIntegral h)+	currentWindow $ fWindow f+	setWindowSize w h  drawLine :: Field -> Double -> Color -> Position -> Position -> IO () drawLine f w c p q = do-	atomicModifyIORef_ (fActions f) (Just (makeLineAction f p q c w) :)-	atomicModifyIORef_ (fChanged f) (+ 1)-	G.flush--makeLineAction :: Field -> Position -> Position -> Color -> Double -> IO ()-makeLineAction f p q c w = G.preservingMatrix $ do-	G.lineWidth $= fromRational (toRational w)-	G.color $ colorToColor4 c-	pp <- positionToVertex3 f p-	qq <- positionToVertex3 f q-	G.renderPrimitive G.Lines $ mapM_ G.vertex [pp, qq]--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"--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 ps'-	vs' <- mapM (positionToVertex3 f) ps-	G.preservingMatrix $ do-		G.color $ colorToColor4 c-		G.renderPrimitive G.Triangles $ mapM_ G.vertex vs-		G.lineWidth $= fromRational (toRational lw)-		G.color $ colorToColor4 lc-		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 :: 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)+	atomicModifyIORef_ (fUpdate f) (+ 1)+	atomicModifyIORef_ (fActions f) (Just (makeLineAction f w c p q) :) -posToPosition :: Pos -> Position-posToPosition (x, y) = Center x y+makePolygonAction :: Field -> [Position] -> Color -> Color -> Double -> IO ()+makePolygonAction f ps c lc lw = do+	ps' <- mapM (positionToDoubles f) ps+	drawPolygon ps' (colorToInts c) (colorToInts lc) lw -positionToVertex3 :: Field -> Position -> IO (G.Vertex2 G.GLfloat)-positionToVertex3 f (Center x y) = do-	(w, h) <- readIORef $ fSize f-	return $ G.Vertex2-		(fromRational $ 2 * toRational x / fromIntegral w)-		(fromRational $ 2 * toRational y / fromIntegral h)-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')+makeLineAction :: Field -> Double -> Color -> Position -> Position -> IO ()+makeLineAction f w c p_ q_ = do+	[p, q] <- mapM (positionToDoubles f) [p_, q_]+	glDrawLine (colorToInts c) w p q  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 = do+	(w, h) <- readIORef $ fSize f+	let	ratio = 3.5 * fromIntegral h+		size' = size / 15+		x_ratio = 2 * ratio / fromIntegral w+		y_ratio = 2 * ratio / fromIntegral h+		x = x_ratio * (x_ / size')+		y = y_ratio * (y_ / size')+		s = 1 / ratio * (size')+		action = glWriteString s (colorToInts clr) (x, y) str 	atomicModifyIORef_ (fActions f) (Just action :)-	where-	action = G.preservingMatrix $ do-		(w, h) <- readIORef $ fSize f-		let	size' = size / 15-			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 = 1 / ratio * fromRational (toRational size')-		G.color $ colorToColor4 clr-		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 G.GLfloat)-		G.renderString G.Roman str writeString _ _ _ _ _ _ = error "writeString: not implemented"  drawImage :: Field -> FilePath -> Position -> Double -> Double -> IO ()@@ -390,46 +224,39 @@  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)+	atomicModifyIORef_ (fActions f) (Just (makePolygonAction f ps clr lc lw) :)+	atomicModifyIORef_ (fUpdate f) (+ 1) +clearField :: Field -> IO ()+clearField f = writeIORef (fActions f) []+ --------------------------------------------------------------------------------  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)+	makePolygonAction f sh fclr clr lw+	writeIORef (fAction f) $ makePolygonAction f sh fclr clr lw+	atomicModifyIORef_ (fUpdate f) (+ 1)  drawCharacterAndLine ::	Field -> Color -> Color -> [Position] -> 	Double -> Position -> Position -> IO () 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-	atomicModifyIORef_ (fChanged f) (+ 1)+	writeIORef (fAction f) $+		makeLineAction f lw clr p q >> makePolygonAction f sh fclr clr lw+	atomicModifyIORef_ (fUpdate f) (+ 1)  clearCharacter :: Field -> IO ()-clearCharacter f = writeIORef (fAction f) $ return ()+clearCharacter f = do+	atomicModifyIORef_ (fUpdate f) (+ 1)+	writeIORef (fAction f) $ return ()  -------------------------------------------------------------------------------- -getConsole :: Field -> IO (Maybe Console)-getConsole = readIORef . fConsole--outputString :: Field -> String -> IO ()-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+oncommand :: Field -> (String -> IO Bool) -> IO ()+oncommand = writeIORef . fOncommand  onclick, onrelease :: Field -> (Int -> Double -> Double -> IO Bool) -> IO ()-onclick f act = writeIORef (fOnclick f) act+onclick = writeIORef . fOnclick onrelease _ _ = return ()  ondrag :: Field -> (Int -> Double -> Double -> IO ()) -> IO ()@@ -443,3 +270,17 @@  ontimer :: Field -> Int -> IO Bool -> IO () ontimer _ _ _ = return ()++--------------------------------------------------------------------------------++positionToDoubles :: Field -> Position -> IO (Double, Double)+positionToDoubles f (Center x y) = do+	(w, h) <- readIORef $ fSize f+	return (2 * x / fromIntegral w, 2 * y / fromIntegral h)+positionToDoubles f (TopLeft x y) = do+	(w, h) <- readIORef $ fSize f+	return (2 * x / fromIntegral w - 1, 1 - 2 * y / fromIntegral h)++colorToInts :: Color -> (Int, Int, Int)+colorToInts (RGB r g b) = (fromIntegral r, fromIntegral g, fromIntegral b)+colorToInts _ = error "colorToInts: not implemented"
src/Graphics/UI/GLUT/Turtle/GLUTools.hs view
@@ -1,21 +1,46 @@ module Graphics.UI.GLUT.Turtle.GLUTools ( 	initialize, 	createWindow,-	printLines,+	printCommands, 	keyboardCallback,+	keyboardMouseCallback, 	displayAction, 	loop,+	windowColor, +	currentWindow,+--	separateLine,++	windowSize,+	setWindowSize,+	leaveUnless,++	Key(..),+	glDrawLine,+	drawPolygon,+	glWriteString,+ 	module Graphics.UI.GLUT ) where -import Graphics.UI.GLUT hiding (initialize, createWindow)+import Graphics.UI.GLUT.Turtle.Triangles++import Graphics.UI.GLUT hiding (+	initialize, createWindow, keyboardMouseCallback, currentWindow,+	windowSize, Key(..), SpecialKey, Color) import qualified Graphics.UI.GLUT as G import System.Environment import Control.Monad import Data.IORef import Data.IORef.Tools+import Control.Applicative +data Key = Char Char | MouseButton Int | SpecialKey SpecialKey+	deriving Show++data SpecialKey = SK+	deriving Show+ initialize :: IO [String] initialize = do 	prgName <- getProgName@@ -29,15 +54,34 @@ 	initialWindowSize $= Size (fromIntegral w) (fromIntegral h) 	G.createWindow name -printLines :: G.Window -> Double -> [String] -> IO ()-printLines win w strs = do+printCommands :: G.Window -> [String] -> IO ()+printCommands win strs =+	concatMap reverse <$> mapM separateLine strs >>= printCommands_ win++printCommands_ :: G.Window -> [String] -> IO ()+printCommands_ win strs = do 	G.currentWindow $= Just win 	G.clearColor $= G.Color4 0 0 0 0 	G.clear [G.ColorBuffer]-	G.lineWidth $= (fromRational $ toRational w)+	G.lineWidth $= 1.0 	zipWithM_ (printString (-2.8)) [-1800, -1600 .. 1800] strs 	G.swapBuffers +separateLine :: String -> IO [String]+separateLine "" = return []+separateLine str = do+	n <- getStringNum str 1+	rest <- separateLine (drop n str)+	return $ take n str : rest++getStringNum :: String -> Int -> IO Int+getStringNum str n+	| n >= length str = return n+	| otherwise = G.preservingMatrix $ do+		sw <- G.stringWidth G.Roman (take n str)+		if sw < 3900+			then getStringNum str (n + 1) else return n+ printString :: G.GLfloat -> G.GLfloat -> String -> IO () printString x y str = 	G.preservingMatrix $ do@@ -50,18 +94,38 @@ 		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+	(Char -> G.KeyState -> G.Modifiers -> IO ()) -> IO ()+keyboardCallback f = G.keyboardMouseCallback $= Just (\k ks m _ -> case k of+	G.Char chr -> f chr ks m 	_ -> return ()) +keyboardMouseCallback ::+	(Key -> G.KeyState -> G.Modifiers -> (Double, Double) -> IO ()) -> IO ()+keyboardMouseCallback fun = (G.keyboardMouseCallback $=) $ Just $+	\k ks m (Position x y) ->fun (gKeyToKey k) ks m (fromIntegral x, fromIntegral y)++gKeyToKey :: G.Key -> Key+gKeyToKey (G.Char c) = Char c+gKeyToKey (G.MouseButton b) = MouseButton $ buttonToInt b+gKeyToKey (G.SpecialKey _) = SpecialKey SK++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+ displayAction :: IORef Int -> IO () -> IO ()-displayAction changed act = loop changed act >> G.displayCallback $= act+displayAction changed act = loop_ changed act >> G.displayCallback $= act -loop :: IORef Int -> IO a -> IO ()-loop changed act = G.addTimerCallback 10 $ timerAction changed act+loop_ :: IORef Int -> IO a -> IO ()+loop_ changed act = G.addTimerCallback 10 $ timerAction changed act +loop :: IO a -> IO ()+loop act = G.addTimerCallback 10 $ timerAction' act+ timerAction :: IORef Int -> IO a -> IO () timerAction changed act = do 	c <- readIORef changed@@ -69,3 +133,98 @@ 		_ <- act 		atomicModifyIORef_ changed (subtract 1) 	G.addTimerCallback 10 $ timerAction changed act++timerAction' :: IO a -> IO ()+timerAction' act = act >> G.addTimerCallback 10 (timerAction' act)++windowColor_ :: G.Color4 G.GLfloat -> IO ()+windowColor_ clr = G.preservingMatrix $ do+	G.color clr+	G.renderPrimitive G.Quads $ mapM_ G.vertex [+		G.Vertex2 (-1) (-1),+		G.Vertex2 (-1) 1,+		G.Vertex2 1 1,+		G.Vertex2 1 (-1) :: G.Vertex2 G.GLfloat ]++currentWindow :: Window -> IO ()+currentWindow = (G.currentWindow $=) . Just++windowSize :: IO (Int, Int)+windowSize = do+	G.Size w h <- G.get G.windowSize+	return (fromIntegral w, fromIntegral h)++setWindowSize :: Int -> Int -> IO ()+setWindowSize w h = (G.windowSize $=) $ Size (fromIntegral w) (fromIntegral h)++leaveUnless :: Bool -> IO ()+leaveUnless = flip unless G.leaveMainLoop++glDrawLine_ :: G.Color4 G.GLfloat -> G.GLfloat ->+	G.Vertex3 G.GLfloat -> G.Vertex3 G.GLfloat -> IO ()+glDrawLine_ c w p q = G.preservingMatrix $ do+	G.lineWidth $= w+	G.color c+	G.renderPrimitive G.Lines $ mapM_ G.vertex [p, q]++drawPolygon_ :: [G.Vertex3 G.GLfloat] -> G.Color4 G.GLfloat -> G.Color4 G.GLfloat ->+	G.GLfloat -> IO ()+drawPolygon_ ps c lc lw = G.preservingMatrix $ do+	G.color c+	G.renderPrimitive G.Triangles $ mapM_ G.vertex ps'+	G.lineWidth $= lw+	G.color lc+	G.renderPrimitive G.LineLoop $ mapM_ G.vertex ps+	where+	ps' = map posToVertex3 $ triangleToPositions $ toTriangles $+		map vertex3ToPos ps++vertex3ToPos :: G.Vertex3 G.GLfloat -> Pos+vertex3ToPos (G.Vertex3 x y 0) =+	(fromRational $ toRational x, fromRational $ toRational y)+vertex3ToPos _ = error "vertex3ToPos: bad"++posToVertex3 :: Pos -> G.Vertex3 G.GLfloat+posToVertex3 (x, y) =+	G.Vertex3 (fromRational $ toRational x) (fromRational $ toRational y) 0++triangleToPositions :: [(Pos, Pos, Pos)] -> [Pos]+triangleToPositions [] = []+triangleToPositions ((a, b, c) : rest) = a : b : c : triangleToPositions rest++glWriteString_ ::+	G.GLfloat -> G.Color4 G.GLfloat -> G.GLfloat -> G.GLfloat -> String -> IO ()+glWriteString_ s clr x y str = G.preservingMatrix $ do+	G.color clr+	G.scale (s :: G.GLfloat) (s :: G.GLfloat) (s :: G.GLfloat)+	G.translate (G.Vector3 x y 0 :: G.Vector3 G.GLfloat)+	G.renderString G.Roman str++drawPolygon :: [Pos] -> Clr -> Clr -> Double -> IO ()+drawPolygon ps c lc lw = drawPolygon_ (map doublesToVertex3 ps) (intsToColor4 c)+	(intsToColor4 lc) (doubleToGLfloat lw)++type Pos = (Double, Double)+type Clr = (Int, Int, Int)++doublesToVertex3 :: (Double, Double) -> Vertex3 GLfloat+doublesToVertex3 (x, y) = Vertex3 (doubleToGLfloat x) (doubleToGLfloat y) 0++intsToColor4 :: (Int, Int, Int) -> Color4 GLfloat+intsToColor4 (r, g, b) = Color4+	(fromIntegral r / 255) (fromIntegral g / 255) (fromIntegral b / 255) 0++doubleToGLfloat :: Double -> GLfloat+doubleToGLfloat = fromRational . toRational++glDrawLine :: (Int, Int, Int) -> Double -> Pos -> Pos -> IO ()+glDrawLine c w p q = glDrawLine_ (intsToColor4 c) (doubleToGLfloat w)+	(doublesToVertex3 p) (doublesToVertex3 q)++glWriteString :: Double -> Clr -> Pos -> String -> IO ()+glWriteString size clr (x, y) str =+	glWriteString_ (doubleToGLfloat size) (intsToColor4 clr)+		(doubleToGLfloat x) (doubleToGLfloat y) str++windowColor :: Clr -> IO ()+windowColor clr = windowColor_ $ intsToColor4 clr
src/Graphics/UI/GLUT/Turtle/Move.hs view
@@ -3,6 +3,7 @@  	-- * types 	Field,+	Console, 	Coordinates(..),  	-- * process Field@@ -23,7 +24,7 @@ 	moveTurtle,  	-- * event-	oninputtext,+	oncommand, 	onclick, 	onrelease, 	ondrag,@@ -33,21 +34,20 @@ --	addLayer, --	addCharacter, -	outputString,--	prompt+	consoleOutput,+	consolePrompt ) where  import Graphics.UI.GLUT.Turtle.State(TurtleState(..), makeShape)-import Graphics.UI.GLUT.Turtle.Field(prompt, initialize, setFieldSize,-	Field, Coordinates(..), openConsole, setConsole,+import Graphics.UI.GLUT.Turtle.Field(consolePrompt, initialize, setFieldSize,+	Field, Coordinates(..), openConsole, setConsole, Console, 	openField, closeField, coordinates, topleft, center, 	fieldSize, forkField, flushField, 	clearCharacter,-	oninputtext, onclick, onrelease, ondrag, onmotion, onkeypress, ontimer,+	oncommand, onclick, onrelease, ondrag, onmotion, onkeypress, ontimer, 	fieldColor, drawLine, fillRectangle, fillPolygon, writeString, 	drawImage, undoField, drawCharacter, drawCharacterAndLine,-	outputString)+	consoleOutput, clearField) import Text.XML.YJSVG(SVG(..), Position(..)) import qualified Text.XML.YJSVG as S(topleft) @@ -74,7 +74,7 @@ 			drawTtl (direction t1) p >> threadDelay (interval t0) 		fl $ drawTtl (direction t1) $ position t1 	when (visible t0 && not (visible t1)) $ fl $ clearCharacter f---	when (clear t1) $ fl $ clearLayer l+	when (clear t1) $ fl $ clearField f 	unless (undo t1) $ fl $ maybe (return ()) (drawSVG f) (draw t1) 	where 	fl = flushField f $ stepbystep t0
tests/testGLUT.hs view
@@ -1,16 +1,16 @@ import Graphics.UI.GLUT.Turtle-import Graphics.UI.GLUT hiding (position, initialize)+import Graphics.UI.GLUT hiding (position, initialize, clear)  main :: IO () main = do 	_args <- initialize 	f <- openField "test" 640 480 	c <- openConsole "console" 640 480+	consolePrompt c "> " 	setConsole f c-	prompt f "> " 	t <- newTurtle f 	onclick f $ \_bn x y -> goto t x y >> return True-	oninputtext f (processInput f t)+	oncommand f (processInput f c t) --	speed t "slowest" --	fillcolor t ((255, 255, 255) :: (Int, Int, Int)) --	pencolor t ((255, 255, 255) :: (Int, Int, Int))@@ -19,35 +19,36 @@ --	forward t 100 	mainLoop -processInput :: Field -> Turtle -> String -> IO Bool-processInput _ t "forward" = forward t 100 >> return True-processInput _ t "left" = left t 90 >> return True-processInput _ t "right" = right t 90 >> return True-processInput _ t "begin" = beginfill t >> return True-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 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-processInput _ t "yellow" = pencolor t ((255, 255, 0) :: (Int, Int, Int)) >> return True-processInput _ t "normal" = pensize t 1 >> return True-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 _ _ "0very1very2very3very4very5very6very7very8very9very0very-long-line"+processInput :: Field -> Console -> Turtle -> String -> IO Bool+processInput _ _ t "forward" = forward t 100 >> return True+processInput _ _ t "left" = left t 90 >> return True+processInput _ _ t "right" = right t 90 >> return True+processInput _ _ t "begin" = beginfill t >> return True+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 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+processInput _ _ t "yellow" = pencolor t ((255, 255, 0) :: (Int, Int, Int)) >> return True+processInput _ _ t "normal" = pensize t 1 >> return True+processInput _ _ _ "exit" = return False+processInput _ c t "position" = position t >>= consoleOutput c . 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 _ _ _ "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 _ "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+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 _ _ "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 _ _ t "clear" = clear t >> return True+processInput _ _ _ _ = return True