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.33 +version: 0.0.35 stability: alpha author: Yoshikuni Jujo maintainer: Yoshikuni Jujo @@ -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 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 @@ -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 diff --git a/src/Graphics/UI/GLUT/Turtle/Console.hs b/src/Graphics/UI/GLUT/Turtle/Console.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/GLUT/Turtle/Console.hs @@ -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) 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 @@ -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" diff --git a/src/Graphics/UI/GLUT/Turtle/GLUTools.hs b/src/Graphics/UI/GLUT/Turtle/GLUTools.hs --- a/src/Graphics/UI/GLUT/Turtle/GLUTools.hs +++ b/src/Graphics/UI/GLUT/Turtle/GLUTools.hs @@ -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 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 @@ -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 diff --git a/tests/testGLUT.hs b/tests/testGLUT.hs --- a/tests/testGLUT.hs +++ b/tests/testGLUT.hs @@ -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