module FRP.UISF.Render.GLUT (
Window,
WindowData (..),
openWindow,
closeWindow,
renderGraphicInOpenGL,
glutKeyToKey
) where
import Graphics.UI.GLUT hiding (Key(..), SpecialKey(..), MouseButton(..), vertex, Rect)
import qualified Graphics.UI.GLUT as GLUT
import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.OpenGL (($=), GLfloat)
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Concurrent.STM.TChan
import Control.Exception (catch,IOException)
import Control.Monad.STM (atomically)
import Control.Monad (when)
import Data.IORef
import Data.List (unfoldr)
import FRP.UISF.UITypes
import FRP.UISF.Graphics
import FRP.UISF.Graphics.Graphic (Graphic(..))
import FRP.UISF.Graphics.Text (uitextLines)
data WindowData = WindowData {
setGraphics :: (Graphic, DirtyBit) -> IO (),
getWindow :: IO (Maybe Window),
getWindowDim :: IO Dimension,
getNextEvent :: IO UIEvent,
peekNextEvent :: IO UIEvent,
getElapsedGUITime :: IO Double
}
openWindow :: RGB -> String -> Dimension -> IO WindowData
openWindow rgb title (x,y) = do
gRef <- newIORef (nullGraphic, False)
wRef <- newIORef Nothing
wdRef <- newIORef (x,y)
eChan <- atomically newTChan
continue <- newEmptyMVar
let w = WindowData (writeIORef gRef) (readIORef wRef)
(readIORef wdRef) (nextEvent tryReadTChan eChan)
(nextEvent tryPeekTChan eChan) guiTime
forkIO (f gRef wRef wdRef eChan continue)
takeMVar continue
return w
where
nextEvent r c = do
me <- atomically $ r c
case me of
Nothing -> return NoUIEvent
Just e -> return e
f gRef wRef wdRef eChan continue = do
(_progName, otherArgs) <- getArgsAndInitialize
initialDisplayMode $= [DoubleBuffered]
w <- createWindow title
windowSize $= Size (fromIntegral x) (fromIntegral y)
writeIORef wRef (Just w)
catch (actionOnWindowClose $= ContinueExecution)
(const (return ())::IOException->IO())
setBackgroundColor rgb
displayCallback $= displayCB gRef
idleCallback $= Just (idleCB gRef)
reshapeCallback $= Just (reshapeCB wdRef)
keyboardMouseCallback $= Just (keyboardMouseCB eChan)
motionCallback $= Just (motionCB eChan)
passiveMotionCallback $= Just (motionCB eChan)
catch (closeCallback $= Just (closeCB wRef))
(const (return ())::IOException->IO())
lineSmooth $= Enabled
blend $= Enabled
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
lineWidth $= 1.5
putMVar continue ()
mainLoop
closeWindow :: Window -> IO ()
closeWindow = destroyWindow
setBackgroundColor :: RGB -> IO ()
setBackgroundColor rgb = clearColor $= Color4 r g b 0
where (r',g',b') = extractRGB rgb
r = fromIntegral r' / 255
g = fromIntegral g' / 255
b = fromIntegral b' / 255
displayCB :: IORef (Graphic, DirtyBit) -> DisplayCallback
displayCB ref = do
(g, _) <- readIORef ref
loadIdentity
clear [ColorBuffer, StencilBuffer]
(Size x y) <- get windowSize
renderGraphicInOpenGL (fromIntegral x, fromIntegral y) g
swapBuffers
postRedisplay Nothing
idleCB :: IORef (Graphic, DirtyBit) -> IdleCallback
idleCB ref = do
db <- atomicModifyIORef ref (\(g,db) -> ((g,False),db))
when db $ postRedisplay Nothing
reshapeCB :: IORef Dimension -> ReshapeCallback
reshapeCB wdref size@(Size w h) = do
writeIORef wdref (fromIntegral w, fromIntegral h)
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
ortho2D 0 (realToFrac w) (realToFrac h) 0
matrixMode $= Modelview 0
loadIdentity
postRedisplay Nothing
keyboardMouseCB :: TChan UIEvent -> KeyboardMouseCallback
keyboardMouseCB chan key d modifiers (Position x y) = do
let k = glutKeyToKey key
down = (d == Down)
p = (fromIntegral x, fromIntegral y)
mods <- updateKeyState k down
case k of
(Char c) ->
atomically $ writeTChan chan Key{ char = c, modifiers = mods, isDown = down}
(SpecialKey sk) ->
atomically $ writeTChan chan SKey{ skey = sk, modifiers = mods, isDown = down}
(MouseButton mb) ->
atomically $ writeTChan chan Button{ pt = p, mbutton = mb, isDown = down}
motionCB :: TChan UIEvent -> MotionCallback
motionCB chan (Position x y) =
atomically $ writeTChan chan MouseMove{ pt = (fromIntegral x, fromIntegral y)}
closeCB :: IORef (Maybe Window) -> CloseCallback
closeCB ref = writeIORef ref Nothing
guiTime :: IO Double
guiTime = do
mills <- get elapsedTime
return $ fromIntegral mills / 1000
renderGraphicInOpenGL :: Dimension -> Graphic -> IO ()
renderGraphicInOpenGL _ NoGraphic = return ()
renderGraphicInOpenGL s (GColor rgb graphic) = (GL.color color >> renderGraphicInOpenGL s graphic) where
(r,g,b) = extractRGB rgb
color = GL.Color3 (c2f r) (c2f g) (c2f b) :: GL.Color3 GLfloat
c2f i = fromIntegral i / 255
renderGraphicInOpenGL _ (GText (x,y) uistr) =
let tlines = zip (uitextLines uistr) [0..]
drawLine (s,i) = do
let ss = unfoldr buildList (0,unwrapUIT s)
buildList (_,[]) = Nothing
buildList (x,(c,f,str):rest) = Just ((x,c,f,str), (x+textWidth' f str, rest))
th = textHeight s
yoff = (i * th) + (th `div` 2) + 3
mapM_ (drawStr yoff) ss
drawStr yoff (xoff, c, f, str) = GL.preservingMatrix $ do
case c of
Nothing -> return ()
Just rgb -> GL.color color where
(r,g,b) = extractRGB rgb
color = GL.Color3 (c2f r) (c2f g) (c2f b) :: GL.Color3 GLfloat
c2f i = fromIntegral i / 255
GL.currentRasterPosition $= GLUT.Vertex4
(fromIntegral $ x + xoff)
(fromIntegral $ y + yoff) 0 1
GLUT.renderString f str
in mapM_ drawLine tlines
renderGraphicInOpenGL _ (GPolyLine ps) =
GL.renderPrimitive GL.LineStrip (mapM_ vertex ps)
renderGraphicInOpenGL _ (GPolygon ps) =
GL.renderPrimitive GL.Polygon (mapM_ vertex ps)
renderGraphicInOpenGL _ (GEllipse rect) = GL.preservingMatrix $ do
let ((x, y), (width, height)) = normaliseRect rect
r@(r1,r2) = (width / 2, height / 2)
GL.translate $ vectorR (x + r1, y + r2) --r
GL.renderPrimitive GL.Polygon $ mapM_ vertexR
[ (r1 * cos i, r2 * sin i) | i <- segment 0 (2 * pi) (6 / (r1 + r2)) ]
renderGraphicInOpenGL _ (GArc rect start extent) = GL.preservingMatrix $ do
let ((x, y), (width, height)) = normaliseRect rect
r@(r1, r2) = (width / 2, height / 2)
GL.translate $ vectorR (x + r1, y + r2)
GL.renderPrimitive GL.LineStrip $ mapM_ vertexR
[ (r1 * cos i, r2 * sin i) | i <- segment ((start + extent) * pi / 180)
(start * pi / 180) (6 / (r1 + r2)) ]
renderGraphicInOpenGL _ (GBezier []) = return ()
renderGraphicInOpenGL s (GBezier ps) = renderGraphicInOpenGL s (GPolyLine ps') where
ps' = map (bezier ps) (segment 0 1 dt)
dt = 1 / (lineLength ps / 8)
lineLength :: [Point] -> Double
lineLength ((x1,y1):(x2,y2):ps') =
let dx = fromIntegral $ x2 x1
dy = fromIntegral $ y2 y1
in sqrt (dx * dx + dy * dy) + lineLength ((x2,y2):ps')
lineLength _ = 0
bezier :: [Point] -> Double -> Point
bezier [(x1,y1)] _t = (x1, y1)
bezier [(x1,y1),(x2,y2)] t = (x1 + round (fromIntegral (x2 x1) * t),
y1 + round (fromIntegral (y2 y1) * t))
bezier ps t = bezier (map (\ (p, q) -> bezier [p,q] t) (zip ps (tail ps))) t
renderGraphicInOpenGL s (GTranslate (x,y) g) =
GL.translate (vector (x,y)) >> renderGraphicInOpenGL s g >> GL.translate (vector (0x,0y))
renderGraphicInOpenGL s@(_,windowY) (GBounded ((x,y), (w,h)) g) = do
let [x', y', w', h'] = map fromIntegral [x, windowYyh, w, h]
oldScissor <- GL.get GL.scissor
let ((x'',y''),(w'',h'')) = maybe ((x',y'),(w',h'))
(\(GL.Position a b, GL.Size c d) -> intersect ((x',y'),(w',h')) ((a,b),(c,d))) oldScissor
GL.scissor $= Just (GL.Position x'' y'', GL.Size w'' h'')
renderGraphicInOpenGL s g
GL.scissor $= oldScissor
where
intersect ((x,y),(w,h)) ((x',y'),(w',h')) = ((x'',y''),(w'',h'')) where
x'' = min x x'
y'' = min y y'
w'' = max 0 $ (min (x+w) (x'+w')) x''
h'' = max 0 $ (min (y+h) (y'+h')) y''
renderGraphicInOpenGL s (GRotate p a' g) =
GL.preservingMatrix $ GL.rotate a (vector p) >> renderGraphicInOpenGL s g
where a = realToFrac a'
renderGraphicInOpenGL s (GScale x' y' g) =
GL.preservingMatrix $ GL.scale x y (1::GLfloat) >> renderGraphicInOpenGL s g
where x = realToFrac x'
y = realToFrac y'
renderGraphicInOpenGL s (OverGraphic over base) =
renderGraphicInOpenGL s base >> renderGraphicInOpenGL s over
normaliseRect :: Rect -> ((Double, Double),(Double, Double))
normaliseRect ((x, y), (w, h)) = ((fromIntegral x', fromIntegral y'), (fromIntegral w', fromIntegral h'))
where (x',w') = if w < 0 then (x+w, 0w) else (x, w)
(y',h') = if h < 0 then (y+h, 0h) else (y, h)
segment :: (Num t, Ord t) => t -> t -> t -> [t]
segment start stop step = ts start
where ts i = if i >= stop then [stop] else i : ts (i + step)
vertex :: Point -> IO ()
vertex (x,y) = GL.vertex $ GL.Vertex3 (fromIntegral x) (fromIntegral y) (0::GLfloat)
vertexR :: (Double,Double) -> IO ()
vertexR (x,y) = GL.vertex $ GL.Vertex3 (realToFrac x) (realToFrac y) (0::GLfloat)
vector :: (Int, Int) -> GL.Vector3 GLfloat
vector (x,y) = GL.Vector3 (fromIntegral x) (fromIntegral y) 0
vectorR :: (Double,Double) -> GL.Vector3 GLfloat
vectorR (x,y) = GL.Vector3 (realToFrac x) (realToFrac y) 0
glutKeyToKey :: GLUT.Key -> Key
glutKeyToKey key
= case key of
GLUT.Char '\13' -> SpecialKey KeyEnter
GLUT.Char '\9' -> SpecialKey KeyTab
GLUT.Char '\ESC' -> SpecialKey KeyEsc
GLUT.Char '\DEL' -> SpecialKey KeyDelete
GLUT.Char '\BS' -> SpecialKey KeyBackspace
GLUT.Char c -> Char c
GLUT.SpecialKey GLUT.KeyF1 -> SpecialKey KeyF1
GLUT.SpecialKey GLUT.KeyF2 -> SpecialKey KeyF2
GLUT.SpecialKey GLUT.KeyF3 -> SpecialKey KeyF3
GLUT.SpecialKey GLUT.KeyF4 -> SpecialKey KeyF4
GLUT.SpecialKey GLUT.KeyF5 -> SpecialKey KeyF5
GLUT.SpecialKey GLUT.KeyF6 -> SpecialKey KeyF6
GLUT.SpecialKey GLUT.KeyF7 -> SpecialKey KeyF7
GLUT.SpecialKey GLUT.KeyF8 -> SpecialKey KeyF8
GLUT.SpecialKey GLUT.KeyF9 -> SpecialKey KeyF9
GLUT.SpecialKey GLUT.KeyF10 -> SpecialKey KeyF10
GLUT.SpecialKey GLUT.KeyF11 -> SpecialKey KeyF11
GLUT.SpecialKey GLUT.KeyF12 -> SpecialKey KeyF12
GLUT.SpecialKey GLUT.KeyLeft -> SpecialKey KeyLeft
GLUT.SpecialKey GLUT.KeyUp -> SpecialKey KeyUp
GLUT.SpecialKey GLUT.KeyRight -> SpecialKey KeyRight
GLUT.SpecialKey GLUT.KeyDown -> SpecialKey KeyDown
GLUT.SpecialKey GLUT.KeyPageUp -> SpecialKey KeyPageUp
GLUT.SpecialKey GLUT.KeyPageDown -> SpecialKey KeyPageDown
GLUT.SpecialKey GLUT.KeyHome -> SpecialKey KeyHome
GLUT.SpecialKey GLUT.KeyEnd -> SpecialKey KeyEnd
GLUT.SpecialKey GLUT.KeyInsert -> SpecialKey KeyInsert
GLUT.SpecialKey GLUT.KeyNumLock -> SpecialKey KeyNumLock
GLUT.SpecialKey GLUT.KeyBegin -> SpecialKey KeyBegin
GLUT.SpecialKey GLUT.KeyDelete -> SpecialKey KeyDelete
GLUT.SpecialKey (GLUT.KeyUnknown i) -> SpecialKey (KeyUnknown i)
GLUT.SpecialKey GLUT.KeyShiftL -> SpecialKey KeyShiftL
GLUT.SpecialKey GLUT.KeyShiftR -> SpecialKey KeyShiftR
GLUT.SpecialKey GLUT.KeyCtrlL -> SpecialKey KeyCtrlL
GLUT.SpecialKey GLUT.KeyCtrlR -> SpecialKey KeyCtrlR
GLUT.SpecialKey GLUT.KeyAltL -> SpecialKey KeyAltL
GLUT.SpecialKey GLUT.KeyAltR -> SpecialKey KeyAltR
GLUT.MouseButton GLUT.LeftButton -> MouseButton LeftButton
GLUT.MouseButton GLUT.MiddleButton -> MouseButton MiddleButton
GLUT.MouseButton GLUT.RightButton -> MouseButton RightButton
GLUT.MouseButton GLUT.WheelUp -> MouseButton WheelUp
GLUT.MouseButton GLUT.WheelDown -> MouseButton WheelDown
GLUT.MouseButton (GLUT.AdditionalButton i) -> MouseButton (AdditionalButton i)