module Graphics.UI.GLUT.Turtle.Field(
Field,
Layer,
Character,
Coordinates(..),
openField,
closeField,
waitField,
topleft,
center,
coordinates,
fieldSize,
forkField,
flushField,
fieldColor,
drawLine,
fillRectangle,
fillPolygon,
writeString,
drawImage,
undoLayer,
undoField,
clearLayer,
drawCharacter,
drawCharacterAndLine,
clearCharacter,
outputString,
oninputtext,
onclick,
onrelease,
ondrag,
onmotion,
onkeypress,
ontimer,
addLayer,
addCharacter
) where
import Control.Monad
import Graphics.UI.GLUT.Turtle.Triangles
import Graphics.UI.GLUT(
createWindow, Vertex2(..), renderPrimitive, vertex, PrimitiveMode(..),
preservingMatrix, GLfloat, swapBuffers, ($=), displayCallback,
initialDisplayMode, initialWindowSize, Size(..),
DisplayMode(..), flush
)
import qualified Graphics.UI.GLUT as G
import Graphics.UI.GLUT.Turtle.Layers(
Layers, Layer, Character, newLayers,
makeLayer, undoLayer, clearLayer,
makeCharacter, character)
import Text.XML.YJSVG(Position(..), Color(..))
import Control.Concurrent(ThreadId, forkIO)
import Data.IORef(IORef, newIORef, readIORef, writeIORef)
import Data.IORef.Tools(atomicModifyIORef_)
data Coordinates = CoordTopLeft | CoordCenter
data Field = Field{
fCoordinates :: Coordinates,
fAction :: IORef (IO ()),
fActions :: IORef [IO ()],
fString :: IORef String,
fString2 :: IORef [String],
fInputtext :: IORef (String -> IO Bool),
fLayers :: IORef Layers
}
addLayer :: Field -> IO Layer
addLayer = makeLayer . fLayers
addCharacter :: Field -> IO Character
addCharacter = makeCharacter . fLayers
undoField :: Field -> IO ()
undoField f = atomicModifyIORef_ (fActions f) tail
openField :: IO Field
openField = do
layers <- newLayers 0 (return ()) (return ()) (return ())
action <- newIORef $ return ()
actions <- newIORef []
str <- newIORef ""
str2 <- newIORef []
inputtext <- newIORef $ const $ return True
initialDisplayMode $= [RGBMode, DoubleBuffered]
initialWindowSize $= Size 640 640
_ <- createWindow "field"
displayCallback $= (sequence_ =<< readIORef actions)
G.addTimerCallback 10 (timerAction $ do
G.clearColor $= G.Color4 0 0 0 0
G.clear [G.ColorBuffer]
sequence_ =<< readIORef actions
join $ readIORef action
G.lineWidth $= 1.0
printString (2.5) (1800) =<< readIORef str
zipWithM_ (printString (2.5)) [1600, 1400 .. 0] =<< readIORef str2
swapBuffers)
G.reshapeCallback $= Just (\size -> G.viewport $= (G.Position 0 0, size))
let f = Field{
fCoordinates = CoordCenter,
fLayers = layers,
fAction = action,
fActions = actions,
fString = str,
fString2 = str2,
fInputtext = inputtext
}
G.keyboardMouseCallback $= Just (keyboardProc f)
return f
printString :: GLfloat -> GLfloat -> String -> IO ()
printString x y str =
preservingMatrix $ do
G.scale (0.0005 :: GLfloat) 0.0005 0.0005
G.clearColor $= G.Color4 0 0 0 0
G.color (G.Color4 0 1 0 0 :: G.Color4 GLfloat)
w <- G.stringWidth G.Roman "Stroke font"
G.translate (G.Vector3 (x * fromIntegral w)
y 0 :: G.Vector3 GLfloat)
G.renderString G.Roman str
timerAction :: IO a -> IO ()
timerAction act = do
_ <- act
G.addTimerCallback 10 $ timerAction act
closeField :: Field -> IO ()
closeField _ = return ()
waitField :: Field -> IO ()
waitField = const $ return ()
topleft, center :: Field -> IO ()
topleft = const $ return ()
center = const $ return ()
coordinates :: Field -> IO Coordinates
coordinates = return . fCoordinates
fieldSize :: Field -> IO (Double, Double)
fieldSize = const $ return (0, 0)
forkField :: Field -> IO () -> IO ThreadId
forkField _f = forkIO
flushField :: Field -> Bool -> IO a -> IO a
flushField _f _real act = act
fieldColor :: Field -> Layer -> Color -> IO ()
fieldColor _f _l _clr = return ()
drawLine :: Field -> Layer -> Double -> Color -> Position -> Position -> IO ()
drawLine f _ w c p q = do
atomicModifyIORef_ (fActions f) (makeLineAction p q c w :)
flush
makeLineAction :: Position -> Position -> Color -> Double -> IO ()
makeLineAction p q c w = preservingMatrix $ do
G.lineWidth $= fromRational (toRational w)
G.color $ colorToColor4 c
renderPrimitive Lines $ mapM_ vertex [
positionToVertex3 p,
positionToVertex3 q ]
colorToColor4 :: Color -> G.Color4 GLfloat
colorToColor4 (RGB r g b) = G.Color4
(fromIntegral r / 255) (fromIntegral g / 255) (fromIntegral b / 255) 0
colorToColor4 _ = error "colorToColor4: not implemented"
makeCharacterAction :: [Position] -> Color -> Color -> Double -> IO ()
makeCharacterAction ps c lc lw =
preservingMatrix $ do
G.color $ colorToColor4 c
renderPrimitive Triangles $
mapM_ (vertex . positionToVertex3 . posToPosition) $
triangleToPositions $
toTriangles $ map positionToPos ps
G.lineWidth $= fromRational (toRational lw)
G.color $ colorToColor4 lc
renderPrimitive LineLoop $ mapM_ (vertex . positionToVertex3) ps
type Pos = (Double, Double)
triangleToPositions :: [(Pos, Pos, Pos)] -> [Pos]
triangleToPositions [] = []
triangleToPositions ((a, b, c) : rest) = a : b : c : triangleToPositions rest
positionToPos :: Position -> Pos
positionToPos (Center x y) = (x, y)
positionToPos _ = error "positionToPos: not implemented"
posToPosition :: Pos -> Position
posToPosition (x, y) = Center x y
positionToVertex3 :: Position -> Vertex2 GLfloat
positionToVertex3 (Center x y) =
Vertex2 (fromRational $ toRational x / 300)
(fromRational $ toRational y / 300 + 0.2)
positionToVertex3 _ = error "positionToVertex3: not implemented"
writeString :: Field -> Layer -> String -> Double -> Color -> Position ->
String -> IO ()
writeString _f _ _fname _size _clr _pos _str = return ()
drawImage :: Field -> Layer -> FilePath -> Position -> Double -> Double -> IO ()
drawImage _f _ _fp _pos _w _h = return ()
fillRectangle :: Field -> Layer -> Position -> Double -> Double -> Color -> IO ()
fillRectangle _f _ _p _w _h _clr = return ()
fillPolygon :: Field -> Layer -> [Position] -> Color -> Color -> Double -> IO ()
fillPolygon f _ ps clr lc lw =
atomicModifyIORef_ (fActions f) (makeCharacterAction ps clr lc lw :)
drawCharacter :: Field -> Character -> Color -> Color -> [Position] -> Double -> IO ()
drawCharacter f _ fclr clr sh lw = writeIORef (fAction f) $
makeCharacterAction sh fclr clr lw
drawCharacterAndLine :: Field -> Character -> Color -> Color -> [Position] ->
Double -> Position -> Position -> IO ()
drawCharacterAndLine f _ fclr clr sh lw p q = writeIORef (fAction f) $ do
makeLineAction p q clr lw
makeCharacterAction sh fclr clr lw
clearCharacter :: Character -> IO ()
clearCharacter ch = character ch $ return ()
outputString :: Field -> String -> IO ()
outputString f = atomicModifyIORef_ (fString2 f) . (:)
oninputtext :: Field -> (String -> IO Bool) -> IO ()
oninputtext = writeIORef . fInputtext
onclick, onrelease :: Field -> (Int -> Double -> Double -> IO Bool) -> IO ()
onclick _ _ = return ()
onrelease _ _ = return ()
ondrag :: Field -> (Int -> Double -> Double -> IO ()) -> IO ()
ondrag _ _ = return ()
onmotion :: Field -> (Double -> Double -> IO ()) -> IO ()
onmotion _ _ = return ()
onkeypress :: Field -> (Char -> IO Bool) -> IO ()
onkeypress _ _ = return ()
ontimer :: Field -> Int -> IO Bool -> IO ()
ontimer _ _ _ = return ()
keyboardProc :: Field -> G.Key -> G.KeyState -> G.Modifiers -> G.Position -> IO ()
keyboardProc f (G.Char '\r') G.Down _ _ = do
str <- readIORef $ fString f
atomicModifyIORef_ (fString2 f) (str :)
writeIORef (fString f) ""
continue <- ($ str) =<< readIORef (fInputtext f)
unless continue G.leaveMainLoop
keyboardProc f (G.Char '\b') G.Down _ _ = atomicModifyIORef_ (fString f) init
keyboardProc f (G.Char c) state _ _
| state == G.Down = atomicModifyIORef_ (fString f) (++ [c])
| otherwise = return ()
keyboardProc _ _ _ _ _ = return ()