diff --git a/gluturtle.cabal b/gluturtle.cabal --- a/gluturtle.cabal +++ b/gluturtle.cabal @@ -2,7 +2,7 @@ cabal-version: >= 1.6 name: gluturtle -version: 0.0.20 +version: 0.0.23 stability: alpha author: Yoshikuni Jujo maintainer: Yoshikuni Jujo diff --git a/src/Graphics/UI/GLUT/Turtle.hs b/src/Graphics/UI/GLUT/Turtle.hs --- a/src/Graphics/UI/GLUT/Turtle.hs +++ b/src/Graphics/UI/GLUT/Turtle.hs @@ -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) diff --git a/src/Graphics/UI/GLUT/Turtle/Field.hs b/src/Graphics/UI/GLUT/Turtle/Field.hs --- a/src/Graphics/UI/GLUT/Turtle/Field.hs +++ b/src/Graphics/UI/GLUT/Turtle/Field.hs @@ -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') diff --git a/src/Graphics/UI/GLUT/Turtle/Move.hs b/src/Graphics/UI/GLUT/Turtle/Move.hs --- a/src/Graphics/UI/GLUT/Turtle/Move.hs +++ b/src/Graphics/UI/GLUT/Turtle/Move.hs @@ -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, diff --git a/tests/randomTurtle.hs b/tests/randomTurtle.hs --- a/tests/randomTurtle.hs +++ b/tests/randomTurtle.hs @@ -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" diff --git a/tests/testGLUT.hs b/tests/testGLUT.hs --- a/tests/testGLUT.hs +++ b/tests/testGLUT.hs @@ -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