{-# OPTIONS_HADDOCK hide #-}
module Graphics.Gloss.Internals.Interface.Backend.GLUT
(GLUTState,glutStateInit,initializeGLUT)
where
import Data.IORef
import Control.Monad
import Control.Concurrent
import Graphics.UI.GLUT (get,($=))
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLUT as GLUT
import qualified System.Exit as System
import Graphics.Gloss.Internals.Interface.Backend.Types
import System.IO.Unsafe
glutInitialized :: IORef Bool
{-# NOINLINE glutInitialized #-}
glutInitialized :: IORef Bool
glutInitialized = IO (IORef Bool) -> IORef Bool
forall a. IO a -> a
unsafePerformIO (IO (IORef Bool) -> IORef Bool) -> IO (IORef Bool) -> IORef Bool
forall a b. (a -> b) -> a -> b
$ do Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
data GLUTState
= GLUTState
{
GLUTState -> Int
glutStateFrameCount :: !Int
, GLUTState -> Bool
glutStateHasTimeout :: Bool
, GLUTState -> Bool
glutStateHasIdle :: Bool }
deriving Int -> GLUTState -> ShowS
[GLUTState] -> ShowS
GLUTState -> String
(Int -> GLUTState -> ShowS)
-> (GLUTState -> String)
-> ([GLUTState] -> ShowS)
-> Show GLUTState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GLUTState] -> ShowS
$cshowList :: [GLUTState] -> ShowS
show :: GLUTState -> String
$cshow :: GLUTState -> String
showsPrec :: Int -> GLUTState -> ShowS
$cshowsPrec :: Int -> GLUTState -> ShowS
Show
glutStateInit :: GLUTState
glutStateInit :: GLUTState
glutStateInit
= GLUTState :: Int -> Bool -> Bool -> GLUTState
GLUTState
{ glutStateFrameCount :: Int
glutStateFrameCount = Int
0
, glutStateHasTimeout :: Bool
glutStateHasTimeout = Bool
False
, glutStateHasIdle :: Bool
glutStateHasIdle = Bool
False }
instance Backend GLUTState where
initBackendState :: GLUTState
initBackendState = GLUTState
glutStateInit
initializeBackend :: IORef GLUTState -> Bool -> IO ()
initializeBackend = IORef GLUTState -> Bool -> IO ()
initializeGLUT
exitBackend :: IORef GLUTState -> IO ()
exitBackend = (\IORef GLUTState
_ -> ExitCode -> IO ()
forall a. ExitCode -> IO a
System.exitWith ExitCode
System.ExitSuccess)
openWindow :: IORef GLUTState -> Display -> IO ()
openWindow = IORef GLUTState -> Display -> IO ()
openWindowGLUT
dumpBackendState :: IORef GLUTState -> IO ()
dumpBackendState = IORef GLUTState -> IO ()
dumpStateGLUT
installDisplayCallback :: IORef GLUTState -> [Callback] -> IO ()
installDisplayCallback = IORef GLUTState -> [Callback] -> IO ()
installDisplayCallbackGLUT
installWindowCloseCallback :: IORef GLUTState -> IO ()
installWindowCloseCallback = (\IORef GLUTState
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
installReshapeCallback :: IORef GLUTState -> [Callback] -> IO ()
installReshapeCallback = IORef GLUTState -> [Callback] -> IO ()
installReshapeCallbackGLUT
installKeyMouseCallback :: IORef GLUTState -> [Callback] -> IO ()
installKeyMouseCallback = IORef GLUTState -> [Callback] -> IO ()
installKeyMouseCallbackGLUT
installMotionCallback :: IORef GLUTState -> [Callback] -> IO ()
installMotionCallback = IORef GLUTState -> [Callback] -> IO ()
installMotionCallbackGLUT
installIdleCallback :: IORef GLUTState -> [Callback] -> IO ()
installIdleCallback = IORef GLUTState -> [Callback] -> IO ()
installIdleCallbackGLUT
runMainLoop :: IORef GLUTState -> IO ()
runMainLoop IORef GLUTState
_
= IO ()
forall (m :: * -> *). MonadIO m => m ()
GLUT.mainLoop
postRedisplay :: IORef GLUTState -> IO ()
postRedisplay IORef GLUTState
_
= Maybe Window -> IO ()
forall (m :: * -> *). MonadIO m => Maybe Window -> m ()
GLUT.postRedisplay Maybe Window
forall a. Maybe a
Nothing
getWindowDimensions :: IORef GLUTState -> IO (Int, Int)
getWindowDimensions IORef GLUTState
_
= do GL.Size GLsizei
sizeX GLsizei
sizeY <- StateVar Size -> IO Size
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get StateVar Size
GLUT.windowSize
(Int, Int) -> IO (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
sizeX,GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
sizeY)
getScreenSize :: IORef GLUTState -> IO (Int, Int)
getScreenSize IORef GLUTState
_
= do GL.Size GLsizei
width GLsizei
height <- IO Size -> IO Size
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get IO Size
GLUT.screenSize
(Int, Int) -> IO (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (GLsizei -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
width, GLsizei -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLsizei
height)
elapsedTime :: IORef GLUTState -> IO Double
elapsedTime IORef GLUTState
_
= do Int
t <- GettableStateVar Int -> GettableStateVar Int
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar Int
GLUT.elapsedTime
Double -> IO Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> IO Double) -> Double -> IO Double
forall a b. (a -> b) -> a -> b
$ (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
t) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1000
sleep :: IORef GLUTState -> Double -> IO ()
sleep IORef GLUTState
_ Double
sec
= do Int -> IO ()
threadDelay (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
sec Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000000)
initializeGLUT
:: IORef GLUTState
-> Bool
-> IO ()
initializeGLUT :: IORef GLUTState -> Bool -> IO ()
initializeGLUT IORef GLUTState
_ Bool
debug
= do Bool
initialized <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
glutInitialized
if Bool -> Bool
not Bool
initialized
then do (String
_progName, [String]
_args) <- IO (String, [String])
forall (m :: * -> *). MonadIO m => m (String, [String])
GLUT.getArgsAndInitialize
String
glutVersion <- GettableStateVar String -> GettableStateVar String
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar String
GLUT.glutVersion
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" glutVersion = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
glutVersion String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
StateVar [DisplayMode]
GLUT.initialDisplayMode
StateVar [DisplayMode] -> [DisplayMode] -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= [ DisplayMode
GLUT.RGBMode
, DisplayMode
GLUT.DoubleBuffered]
IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
glutInitialized Bool
True
[DisplayMode]
displayMode <- StateVar [DisplayMode] -> IO [DisplayMode]
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get StateVar [DisplayMode]
GLUT.initialDisplayMode
Bool
displayModePossible <- IO Bool -> IO Bool
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get IO Bool
GLUT.displayModePossible
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
" displayMode = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [DisplayMode] -> String
forall a. Show a => a -> String
show [DisplayMode]
displayMode String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" possible = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
displayModePossible String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
else Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (String -> IO ()
putStrLn String
"Already initialized")
openWindowGLUT
:: IORef GLUTState
-> Display
-> IO ()
openWindowGLUT :: IORef GLUTState -> Display -> IO ()
openWindowGLUT IORef GLUTState
_ Display
display
= do
case Display
display of
InWindow String
windowName (Int
sizeX, Int
sizeY) (Int
posX, Int
posY) ->
do StateVar Size
GLUT.initialWindowSize
StateVar Size -> Size -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLsizei -> GLsizei -> Size
GL.Size
(Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sizeX)
(Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sizeY)
StateVar Position
GLUT.initialWindowPosition
StateVar Position -> Position -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLsizei -> GLsizei -> Position
GL.Position
(Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
posX)
(Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
posY)
Window
_ <- String -> IO Window
forall (m :: * -> *). MonadIO m => String -> m Window
GLUT.createWindow String
windowName
StateVar Size
GLUT.windowSize
StateVar Size -> Size -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLsizei -> GLsizei -> Size
GL.Size
(Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sizeX)
(Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sizeY)
Display
FullScreen ->
do Size
size <- IO Size -> IO Size
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get IO Size
GLUT.screenSize
StateVar Size
GLUT.initialWindowSize StateVar Size -> Size -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Size
size
Window
_ <- String -> IO Window
forall (m :: * -> *). MonadIO m => String -> m Window
GLUT.createWindow String
"Gloss Application"
IO ()
forall (m :: * -> *). MonadIO m => m ()
GLUT.fullScreen
StateVar PerWindowKeyRepeat
GLUT.perWindowKeyRepeat StateVar PerWindowKeyRepeat -> PerWindowKeyRepeat -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= PerWindowKeyRepeat
GLUT.PerWindowKeyRepeatOff
dumpStateGLUT
:: IORef GLUTState
-> IO ()
dumpStateGLUT :: IORef GLUTState -> IO ()
dumpStateGLUT IORef GLUTState
_
= do
Int
wbw <- GettableStateVar Int -> GettableStateVar Int
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar Int
GLUT.windowBorderWidth
Int
whh <- GettableStateVar Int -> GettableStateVar Int
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar Int
GLUT.windowHeaderHeight
Bool
rgba <- IO Bool -> IO Bool
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get IO Bool
GLUT.rgba
(Int, Int, Int, Int)
rgbaBD <- GettableStateVar (Int, Int, Int, Int)
-> GettableStateVar (Int, Int, Int, Int)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar (Int, Int, Int, Int)
GLUT.rgbaBufferDepths
Int
colorBD <- GettableStateVar Int -> GettableStateVar Int
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar Int
GLUT.colorBufferDepth
Int
depthBD <- GettableStateVar Int -> GettableStateVar Int
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar Int
GLUT.depthBufferDepth
(Int, Int, Int, Int)
accumBD <- GettableStateVar (Int, Int, Int, Int)
-> GettableStateVar (Int, Int, Int, Int)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar (Int, Int, Int, Int)
GLUT.accumBufferDepths
Int
stencilBD <- GettableStateVar Int -> GettableStateVar Int
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get GettableStateVar Int
GLUT.stencilBufferDepth
Bool
doubleBuffered <- IO Bool -> IO Bool
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get IO Bool
GLUT.doubleBuffered
Color4 Capability
colorMask <- StateVar (Color4 Capability) -> IO (Color4 Capability)
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get StateVar (Color4 Capability)
GLUT.colorMask
Capability
depthMask <- StateVar Capability -> IO Capability
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get StateVar Capability
GLUT.depthMask
String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"* dumpGlutState\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" windowBorderWidth = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
wbw String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" windowHeaderHeight = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
whh String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" rgba = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
rgba String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" depth rgba = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int, Int, Int, Int) -> String
forall a. Show a => a -> String
show (Int, Int, Int, Int)
rgbaBD String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" color = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
colorBD String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" depth = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
depthBD String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" accum = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int, Int, Int, Int) -> String
forall a. Show a => a -> String
show (Int, Int, Int, Int)
accumBD String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" stencil = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
stencilBD String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" doubleBuffered = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
doubleBuffered String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" mask color = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Color4 Capability -> String
forall a. Show a => a -> String
show Color4 Capability
colorMask String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" depth = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Capability -> String
forall a. Show a => a -> String
show Capability
depthMask String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
installDisplayCallbackGLUT
:: IORef GLUTState -> [Callback]
-> IO ()
installDisplayCallbackGLUT :: IORef GLUTState -> [Callback] -> IO ()
installDisplayCallbackGLUT IORef GLUTState
ref [Callback]
callbacks
= SettableStateVar (IO ())
GLUT.displayCallback SettableStateVar (IO ()) -> IO () -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= IORef GLUTState -> [Callback] -> IO ()
callbackDisplay IORef GLUTState
ref [Callback]
callbacks
callbackDisplay
:: IORef GLUTState -> [Callback]
-> IO ()
callbackDisplay :: IORef GLUTState -> [Callback] -> IO ()
callbackDisplay IORef GLUTState
refState [Callback]
callbacks
= do
[ClearBuffer] -> IO ()
GL.clear [ClearBuffer
GL.ColorBuffer, ClearBuffer
GL.DepthBuffer]
Color4 GLfloat -> IO ()
forall a. Color a => a -> IO ()
GL.color (Color4 GLfloat -> IO ()) -> Color4 GLfloat -> IO ()
forall a b. (a -> b) -> a -> b
$ GLfloat -> GLfloat -> GLfloat -> GLfloat -> Color4 GLfloat
forall a. a -> a -> a -> a -> Color4 a
GL.Color4 GLfloat
0 GLfloat
0 GLfloat
0 (GLfloat
1 :: GL.GLfloat)
let funs :: [IO ()]
funs = [IORef GLUTState -> IO ()
DisplayCallback
f IORef GLUTState
refState | (Display DisplayCallback
f) <- [Callback]
callbacks]
[IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
funs
IO ()
forall (m :: * -> *). MonadIO m => m ()
GLUT.swapBuffers
GLUTState
state <- IORef GLUTState -> IO GLUTState
forall a. IORef a -> IO a
readIORef IORef GLUTState
refState
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ( (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ GLUTState -> Bool
glutStateHasTimeout GLUTState
state)
Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ GLUTState -> Bool
glutStateHasIdle GLUTState
state))
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let msecHeartbeat :: Int
msecHeartbeat = Int
1000
Int -> IO () -> IO ()
GLUT.addTimerCallback Int
msecHeartbeat
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
timerCallback Int
msecHeartbeat
IORef GLUTState -> (GLUTState -> (GLUTState, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef GLUTState
refState
((GLUTState -> (GLUTState, ())) -> IO ())
-> (GLUTState -> (GLUTState, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GLUTState
s -> (GLUTState
s { glutStateHasTimeout :: Bool
glutStateHasTimeout = Bool
True }, ())
IORef GLUTState -> (GLUTState -> (GLUTState, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef GLUTState
refState
((GLUTState -> (GLUTState, ())) -> IO ())
-> (GLUTState -> (GLUTState, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GLUTState
s -> ( GLUTState
s { glutStateFrameCount :: Int
glutStateFrameCount = GLUTState -> Int
glutStateFrameCount GLUTState
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }
, ())
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
timerCallback :: Int -> IO ()
timerCallback :: Int -> IO ()
timerCallback Int
msec
= do Int -> IO () -> IO ()
GLUT.addTimerCallback Int
msec
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do Int -> IO ()
timerCallback Int
msec
installReshapeCallbackGLUT
:: IORef GLUTState -> [Callback]
-> IO ()
installReshapeCallbackGLUT :: IORef GLUTState -> [Callback] -> IO ()
installReshapeCallbackGLUT IORef GLUTState
ref [Callback]
callbacks
= SettableStateVar (Maybe (Size -> IO ()))
GLUT.reshapeCallback SettableStateVar (Maybe (Size -> IO ()))
-> Maybe (Size -> IO ()) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (Size -> IO ()) -> Maybe (Size -> IO ())
forall a. a -> Maybe a
Just (IORef GLUTState -> [Callback] -> Size -> IO ()
callbackReshape IORef GLUTState
ref [Callback]
callbacks)
callbackReshape
:: IORef GLUTState -> [Callback]
-> GLUT.Size
-> IO ()
callbackReshape :: IORef GLUTState -> [Callback] -> Size -> IO ()
callbackReshape IORef GLUTState
ref [Callback]
callbacks (GLUT.Size GLsizei
sizeX GLsizei
sizeY)
= [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ (((Int, Int) -> IO ()) -> IO ())
-> [(Int, Int) -> IO ()] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int, Int) -> IO ()
f -> (Int, Int) -> IO ()
f (GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
sizeX, GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
sizeY))
[IORef GLUTState -> (Int, Int) -> IO ()
ReshapeCallback
f IORef GLUTState
ref | Reshape ReshapeCallback
f <- [Callback]
callbacks]
installKeyMouseCallbackGLUT
:: IORef GLUTState -> [Callback]
-> IO ()
installKeyMouseCallbackGLUT :: IORef GLUTState -> [Callback] -> IO ()
installKeyMouseCallbackGLUT IORef GLUTState
ref [Callback]
callbacks
= SettableStateVar (Maybe KeyboardMouseCallback)
GLUT.keyboardMouseCallback SettableStateVar (Maybe KeyboardMouseCallback)
-> Maybe KeyboardMouseCallback -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= KeyboardMouseCallback -> Maybe KeyboardMouseCallback
forall a. a -> Maybe a
Just (IORef GLUTState -> [Callback] -> KeyboardMouseCallback
callbackKeyMouse IORef GLUTState
ref [Callback]
callbacks)
callbackKeyMouse
:: IORef GLUTState -> [Callback]
-> GLUT.Key
-> GLUT.KeyState
-> GLUT.Modifiers
-> GLUT.Position
-> IO ()
callbackKeyMouse :: IORef GLUTState -> [Callback] -> KeyboardMouseCallback
callbackKeyMouse IORef GLUTState
ref [Callback]
callbacks Key
key KeyState
keystate Modifiers
modifiers (GLUT.Position GLsizei
posX GLsizei
posY)
= [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ ((Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()) -> IO ())
-> [Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map (\Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()
f -> Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()
f Key
key' KeyState
keyState' Modifiers
modifiers' (Int, Int)
pos)
[IORef GLUTState
-> Key -> KeyState -> Modifiers -> (Int, Int) -> IO ()
KeyboardMouseCallback
f IORef GLUTState
ref | KeyMouse KeyboardMouseCallback
f <- [Callback]
callbacks]
where
key' :: Key
key' = Key -> Key
glutKeyToKey Key
key
keyState' :: KeyState
keyState' = KeyState -> KeyState
glutKeyStateToKeyState KeyState
keystate
modifiers' :: Modifiers
modifiers' = Modifiers -> Modifiers
glutModifiersToModifiers Modifiers
modifiers
pos :: (Int, Int)
pos = (GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
posX, GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
posY)
installMotionCallbackGLUT
:: IORef GLUTState -> [Callback]
-> IO ()
installMotionCallbackGLUT :: IORef GLUTState -> [Callback] -> IO ()
installMotionCallbackGLUT IORef GLUTState
ref [Callback]
callbacks
= do SettableStateVar (Maybe (Position -> IO ()))
GLUT.motionCallback SettableStateVar (Maybe (Position -> IO ()))
-> Maybe (Position -> IO ()) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (Position -> IO ()) -> Maybe (Position -> IO ())
forall a. a -> Maybe a
Just (IORef GLUTState -> [Callback] -> Position -> IO ()
callbackMotion IORef GLUTState
ref [Callback]
callbacks)
SettableStateVar (Maybe (Position -> IO ()))
GLUT.passiveMotionCallback SettableStateVar (Maybe (Position -> IO ()))
-> Maybe (Position -> IO ()) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (Position -> IO ()) -> Maybe (Position -> IO ())
forall a. a -> Maybe a
Just (IORef GLUTState -> [Callback] -> Position -> IO ()
callbackMotion IORef GLUTState
ref [Callback]
callbacks)
callbackMotion
:: IORef GLUTState -> [Callback]
-> GLUT.Position
-> IO ()
callbackMotion :: IORef GLUTState -> [Callback] -> Position -> IO ()
callbackMotion IORef GLUTState
ref [Callback]
callbacks (GLUT.Position GLsizei
posX GLsizei
posY)
= do let pos :: (Int, Int)
pos = (GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
posX, GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
posY)
[IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ (((Int, Int) -> IO ()) -> IO ())
-> [(Int, Int) -> IO ()] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int, Int) -> IO ()
f -> (Int, Int) -> IO ()
f (Int, Int)
pos)
[IORef GLUTState -> (Int, Int) -> IO ()
ReshapeCallback
f IORef GLUTState
ref | Motion ReshapeCallback
f <- [Callback]
callbacks]
installIdleCallbackGLUT
:: IORef GLUTState -> [Callback]
-> IO ()
installIdleCallbackGLUT :: IORef GLUTState -> [Callback] -> IO ()
installIdleCallbackGLUT IORef GLUTState
refState [Callback]
callbacks
| (Callback -> Bool) -> [Callback] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Callback -> Bool
isIdleCallback [Callback]
callbacks
= do SettableStateVar (Maybe (IO ()))
GLUT.idleCallback SettableStateVar (Maybe (IO ())) -> Maybe (IO ()) -> IO ()
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IORef GLUTState -> [Callback] -> IO ()
callbackIdle IORef GLUTState
refState [Callback]
callbacks)
IORef GLUTState -> (GLUTState -> (GLUTState, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef GLUTState
refState
((GLUTState -> (GLUTState, ())) -> IO ())
-> (GLUTState -> (GLUTState, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \GLUTState
state -> (GLUTState
state { glutStateHasIdle :: Bool
glutStateHasIdle = Bool
True }, ())
| Bool
otherwise
= () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
callbackIdle
:: IORef GLUTState -> [Callback]
-> IO ()
callbackIdle :: IORef GLUTState -> [Callback] -> IO ()
callbackIdle IORef GLUTState
ref [Callback]
callbacks
= [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
([IO ()] -> IO ()) -> [IO ()] -> IO ()
forall a b. (a -> b) -> a -> b
$ [IORef GLUTState -> IO ()
DisplayCallback
f IORef GLUTState
ref | Idle DisplayCallback
f <- [Callback]
callbacks]
glutKeyToKey :: GLUT.Key -> Key
glutKeyToKey :: Key -> Key
glutKeyToKey Key
key
= case Key
key of
GLUT.Char Char
'\32' -> SpecialKey -> Key
SpecialKey SpecialKey
KeySpace
GLUT.Char Char
'\13' -> SpecialKey -> Key
SpecialKey SpecialKey
KeyEnter
GLUT.Char Char
'\9' -> SpecialKey -> Key
SpecialKey SpecialKey
KeyTab
GLUT.Char Char
'\ESC' -> SpecialKey -> Key
SpecialKey SpecialKey
KeyEsc
GLUT.Char Char
'\DEL' -> SpecialKey -> Key
SpecialKey SpecialKey
KeyDelete
GLUT.Char Char
c -> Char -> Key
Char Char
c
GLUT.SpecialKey SpecialKey
GLUT.KeyF1 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF1
GLUT.SpecialKey SpecialKey
GLUT.KeyF2 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF2
GLUT.SpecialKey SpecialKey
GLUT.KeyF3 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF3
GLUT.SpecialKey SpecialKey
GLUT.KeyF4 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF4
GLUT.SpecialKey SpecialKey
GLUT.KeyF5 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF5
GLUT.SpecialKey SpecialKey
GLUT.KeyF6 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF6
GLUT.SpecialKey SpecialKey
GLUT.KeyF7 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF7
GLUT.SpecialKey SpecialKey
GLUT.KeyF8 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF8
GLUT.SpecialKey SpecialKey
GLUT.KeyF9 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF9
GLUT.SpecialKey SpecialKey
GLUT.KeyF10 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF10
GLUT.SpecialKey SpecialKey
GLUT.KeyF11 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF11
GLUT.SpecialKey SpecialKey
GLUT.KeyF12 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF12
GLUT.SpecialKey SpecialKey
GLUT.KeyLeft -> SpecialKey -> Key
SpecialKey SpecialKey
KeyLeft
GLUT.SpecialKey SpecialKey
GLUT.KeyUp -> SpecialKey -> Key
SpecialKey SpecialKey
KeyUp
GLUT.SpecialKey SpecialKey
GLUT.KeyRight -> SpecialKey -> Key
SpecialKey SpecialKey
KeyRight
GLUT.SpecialKey SpecialKey
GLUT.KeyDown -> SpecialKey -> Key
SpecialKey SpecialKey
KeyDown
GLUT.SpecialKey SpecialKey
GLUT.KeyPageUp -> SpecialKey -> Key
SpecialKey SpecialKey
KeyPageUp
GLUT.SpecialKey SpecialKey
GLUT.KeyPageDown -> SpecialKey -> Key
SpecialKey SpecialKey
KeyPageDown
GLUT.SpecialKey SpecialKey
GLUT.KeyHome -> SpecialKey -> Key
SpecialKey SpecialKey
KeyHome
GLUT.SpecialKey SpecialKey
GLUT.KeyEnd -> SpecialKey -> Key
SpecialKey SpecialKey
KeyEnd
GLUT.SpecialKey SpecialKey
GLUT.KeyInsert -> SpecialKey -> Key
SpecialKey SpecialKey
KeyInsert
GLUT.SpecialKey SpecialKey
GLUT.KeyNumLock -> SpecialKey -> Key
SpecialKey SpecialKey
KeyNumLock
GLUT.SpecialKey SpecialKey
GLUT.KeyBegin -> SpecialKey -> Key
SpecialKey SpecialKey
KeyBegin
GLUT.SpecialKey SpecialKey
GLUT.KeyDelete -> SpecialKey -> Key
SpecialKey SpecialKey
KeyDelete
GLUT.SpecialKey (GLUT.KeyUnknown Int
_) -> SpecialKey -> Key
SpecialKey SpecialKey
KeyUnknown
GLUT.SpecialKey SpecialKey
GLUT.KeyShiftL -> SpecialKey -> Key
SpecialKey SpecialKey
KeyShiftL
GLUT.SpecialKey SpecialKey
GLUT.KeyShiftR -> SpecialKey -> Key
SpecialKey SpecialKey
KeyShiftR
GLUT.SpecialKey SpecialKey
GLUT.KeyCtrlL -> SpecialKey -> Key
SpecialKey SpecialKey
KeyCtrlL
GLUT.SpecialKey SpecialKey
GLUT.KeyCtrlR -> SpecialKey -> Key
SpecialKey SpecialKey
KeyCtrlR
GLUT.SpecialKey SpecialKey
GLUT.KeyAltL -> SpecialKey -> Key
SpecialKey SpecialKey
KeyAltL
GLUT.SpecialKey SpecialKey
GLUT.KeyAltR -> SpecialKey -> Key
SpecialKey SpecialKey
KeyAltR
GLUT.MouseButton MouseButton
GLUT.LeftButton -> MouseButton -> Key
MouseButton MouseButton
LeftButton
GLUT.MouseButton MouseButton
GLUT.MiddleButton -> MouseButton -> Key
MouseButton MouseButton
MiddleButton
GLUT.MouseButton MouseButton
GLUT.RightButton -> MouseButton -> Key
MouseButton MouseButton
RightButton
GLUT.MouseButton MouseButton
GLUT.WheelUp -> MouseButton -> Key
MouseButton MouseButton
WheelUp
GLUT.MouseButton MouseButton
GLUT.WheelDown -> MouseButton -> Key
MouseButton MouseButton
WheelDown
GLUT.MouseButton (GLUT.AdditionalButton Int
i) -> MouseButton -> Key
MouseButton (Int -> MouseButton
AdditionalButton Int
i)
glutKeyStateToKeyState :: GLUT.KeyState -> KeyState
glutKeyStateToKeyState :: KeyState -> KeyState
glutKeyStateToKeyState KeyState
state
= case KeyState
state of
KeyState
GLUT.Down -> KeyState
Down
KeyState
GLUT.Up -> KeyState
Up
glutModifiersToModifiers
:: GLUT.Modifiers
-> Modifiers
glutModifiersToModifiers :: Modifiers -> Modifiers
glutModifiersToModifiers (GLUT.Modifiers KeyState
a KeyState
b KeyState
c)
= KeyState -> KeyState -> KeyState -> Modifiers
Modifiers (KeyState -> KeyState
glutKeyStateToKeyState KeyState
a)
(KeyState -> KeyState
glutKeyStateToKeyState KeyState
b)
(KeyState -> KeyState
glutKeyStateToKeyState KeyState
c)