{-# LANGUAGE ScopedTypeVariables #-}
module Graphics.HaGL.Backend.GLUT (
GlutOptions(..),
GlutRunMode(..),
runGlut
) where
import Prelude hiding (id)
import Control.Monad (when)
import Data.Functor.Identity
import Data.IORef
import Data.Time.Clock
import qualified Data.ByteString as BS
import Graphics.Rendering.OpenGL
import Graphics.Rendering.OpenGL.Capture
import Graphics.UI.GLUT
import Graphics.HaGL.Backend
import Graphics.HaGL.GLType
import Graphics.HaGL.GLExpr
import Graphics.HaGL.ExprID
import Graphics.HaGL.GLObj (GLObj)
import Graphics.HaGL.Eval
import Graphics.HaGL.CodeGen (UniformVar(..))
import qualified Graphics.HaGL.Util.DepMap as DepMap
data GlutOptions = GlutOptions {
GlutOptions -> Maybe (GLint, GLint)
winPosition :: Maybe (GLint, GLint),
GlutOptions -> (GLint, GLint)
winSize :: (GLsizei, GLsizei),
GlutOptions -> Bool
winFullscreen :: Bool,
GlutOptions -> Maybe String
winTitle :: Maybe String,
GlutOptions -> (Float, Float, Float, Float)
clearCol :: (Float, Float, Float, Float),
GlutOptions -> GlutRunMode
runMode :: GlutRunMode,
GlutOptions -> IdleCallback
openGLSetup :: IO ()
}
data GlutRunMode =
GlutNormal |
GlutCaptureLatest String |
GlutCaptureFrames String |
GlutCaptureAndExit String
runGlut :: GlutOptions -> [GLObj] -> IO ()
runGlut :: GlutOptions -> [GLObj] -> IdleCallback
runGlut GlutOptions
options [GLObj]
glObjs = do
GlutOptions -> IdleCallback
initWindow GlutOptions
options
IORef IOState
ioState <- IO (IORef IOState)
initIOState
[RunObj]
runObjs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GLObj -> IO RunObj
genRunObj [GLObj]
glObjs
SettableStateVar (Maybe IdleCallback)
idleCallback forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just (GlutRunMode -> IORef IOState -> [RunObj] -> IdleCallback
update (GlutOptions -> GlutRunMode
runMode GlutOptions
options) IORef IOState
ioState [RunObj]
runObjs)
SettableStateVar IdleCallback
displayCallback forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= [RunObj] -> IdleCallback
display [RunObj]
runObjs
SettableStateVar (Maybe MouseCallback)
mouseCallback forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just (IORef IOState -> MouseCallback
mouse IORef IOState
ioState)
SettableStateVar (Maybe MotionCallback)
motionCallback forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just (IORef IOState -> MotionCallback
motion IORef IOState
ioState)
SettableStateVar (Maybe MotionCallback)
passiveMotionCallback forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just (IORef IOState -> MotionCallback
motion IORef IOState
ioState)
StateVar (Color4 Float)
clearColor forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= let (Float
r, Float
g, Float
b, Float
a) = GlutOptions -> (Float, Float, Float, Float)
clearCol GlutOptions
options in forall a. a -> a -> a -> a -> Color4 a
Color4 Float
r Float
g Float
b Float
a
StateVar Float
lineWidth forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Float
3
StateVar Float
pointSize forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Float
3
GlutOptions -> IdleCallback
openGLSetup GlutOptions
options
forall (m :: * -> *). MonadIO m => m ()
mainLoop
initWindow :: GlutOptions -> IO ()
initWindow :: GlutOptions -> IdleCallback
initWindow GlutOptions
options = do
(String
progName, [String]
_) <- forall (m :: * -> *). MonadIO m => m (String, [String])
getArgsAndInitialize
Window
_ <- forall (m :: * -> *). MonadIO m => String -> m Window
createWindow String
progName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\(GLint
x, GLint
y) -> StateVar Position
windowPosition forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= GLint -> GLint -> Position
Position GLint
x GLint
y)
(GlutOptions -> Maybe (GLint, GLint)
winPosition GlutOptions
options)
StateVar Size
windowSize forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (\(GLint
x, GLint
y) -> GLint -> GLint -> Size
Size GLint
x GLint
y) (GlutOptions -> (GLint, GLint)
winSize GlutOptions
options)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GlutOptions -> Bool
winFullscreen GlutOptions
options) forall (m :: * -> *). MonadIO m => m ()
fullScreen
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (SettableStateVar String
windowTitle forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$=) (GlutOptions -> Maybe String
winTitle GlutOptions
options)
StateVar ActionOnWindowClose
actionOnWindowClose forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= ActionOnWindowClose
MainLoopReturns
StateVar [DisplayMode]
initialDisplayMode forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= [DisplayMode
RGBAMode, DisplayMode
WithAlphaComponent]
StateVar (Maybe ComparisonFunction)
depthFunc forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just ComparisonFunction
Lequal
StateVar Capability
blend forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= Capability
Enabled
StateVar BlendEquation
blendEquation forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= BlendEquation
FuncAdd
StateVar (BlendingFactor, BlendingFactor)
blendFunc forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= (BlendingFactor
SrcAlpha, BlendingFactor
OneMinusSrcAlpha)
data IOState = IOState {
IOState -> Float
initTime :: Float,
IOState -> IORef (DepMap (GLExpr 'HostDomain) Identity)
precMap :: IORef (DepMap.DepMap (GLExpr HostDomain) Identity),
IOState -> Bool
mouseLeftDown :: Bool,
IOState -> Bool
mouseRightDown :: Bool,
IOState -> Float
mouseWheel :: Float,
IOState -> Int
curMouseX :: Int,
IOState -> Int
curMouseY :: Int,
IOState -> Int
totUpdates :: Int,
IOState -> Int
curNumUpdates :: Int,
IOState -> Float
lastStatsUpdate :: Float
}
defIOState :: IOState
defIOState :: IOState
defIOState = IOState {
initTime :: Float
initTime = Float
0,
precMap :: IORef (DepMap (GLExpr 'HostDomain) Identity)
precMap = forall a. HasCallStack => a
undefined,
mouseLeftDown :: Bool
mouseLeftDown = Bool
False,
mouseRightDown :: Bool
mouseRightDown = Bool
False,
mouseWheel :: Float
mouseWheel = Float
0,
curMouseX :: Int
curMouseX = Int
0,
curMouseY :: Int
curMouseY = Int
0,
totUpdates :: Int
totUpdates = Int
0,
curNumUpdates :: Int
curNumUpdates = Int
0,
lastStatsUpdate :: Float
lastStatsUpdate = Float
0
}
initIOState :: IO (IORef IOState)
initIOState :: IO (IORef IOState)
initIOState = do
UTCTime
epoch <- IO UTCTime
getCurrentTime
let initTime :: Float
initTime = forall a. Fractional a => Rational -> a
fromRational forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> Rational
toRational forall a b. (a -> b) -> a -> b
$ UTCTime -> DiffTime
utctDayTime UTCTime
epoch
IORef (DepMap (GLExpr 'HostDomain) Identity)
pm <- forall a. a -> IO (IORef a)
newIORef forall (k :: * -> *) (v :: * -> *). GenHashable k => DepMap k v
DepMap.empty
forall a. a -> IO (IORef a)
newIORef IOState
defIOState { initTime :: Float
initTime = Float
initTime, lastStatsUpdate :: Float
lastStatsUpdate = Float
initTime, precMap :: IORef (DepMap (GLExpr 'HostDomain) Identity)
precMap = IORef (DepMap (GLExpr 'HostDomain) Identity)
pm }
update :: GlutRunMode -> IORef IOState -> [RunObj] -> IdleCallback
update :: GlutRunMode -> IORef IOState -> [RunObj] -> IdleCallback
update GlutRunMode
runMode IORef IOState
ioState [RunObj]
objs = do
GlutRunMode -> IORef IOState -> IdleCallback
outputStatsAndCapture GlutRunMode
runMode IORef IOState
ioState
IORef IOState -> IdleCallback
ioStateUpdate IORef IOState
ioState
IOState
ioState <- forall a. IORef a -> IO a
readIORef IORef IOState
ioState
let updateObj :: RunObj -> IdleCallback
updateObj RunObj
obj = do
StateVar (Maybe Program)
currentProgram forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just (RunObj -> Program
prog RunObj
obj)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IOState -> RunObj -> UniformVar -> IdleCallback
setUniform IOState
ioState RunObj
obj) (RunObj -> Set UniformVar
uniformVars RunObj
obj)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RunObj -> IdleCallback
updateObj [RunObj]
objs
IOState -> IdleCallback
updatePrecMap IOState
ioState
forall (m :: * -> *). MonadIO m => Maybe Window -> m ()
postRedisplay forall a. Maybe a
Nothing
outputStatsAndCapture :: GlutRunMode -> IORef IOState -> IO ()
outputStatsAndCapture :: GlutRunMode -> IORef IOState -> IdleCallback
outputStatsAndCapture GlutRunMode
runMode IORef IOState
ioStateRef = do
IOState
ioState <- forall a. IORef a -> IO a
readIORef IORef IOState
ioStateRef
let numUpdates :: Int
numUpdates = IOState -> Int
curNumUpdates IOState
ioState
UTCTime
epoch <- IO UTCTime
getCurrentTime
let t :: Float
t = forall a. Fractional a => Rational -> a
fromRational forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> Rational
toRational forall a b. (a -> b) -> a -> b
$ UTCTime -> DiffTime
utctDayTime UTCTime
epoch
dt :: Float
dt = Float
t forall a. Num a => a -> a -> a
- IOState -> Float
lastStatsUpdate IOState
ioState
if Float
dt forall a. Ord a => a -> a -> Bool
> Float
1
then do
forall a. IORef a -> a -> IdleCallback
writeIORef IORef IOState
ioStateRef forall a b. (a -> b) -> a -> b
$ IOState
ioState {
totUpdates :: Int
totUpdates = IOState -> Int
totUpdates IOState
ioState forall a. Num a => a -> a -> a
+ Int
1, curNumUpdates :: Int
curNumUpdates = Int
0, lastStatsUpdate :: Float
lastStatsUpdate = Float
t }
String -> IdleCallback
putStrLn forall a b. (a -> b) -> a -> b
$ String
"FPS: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numUpdates forall a. Fractional a => a -> a -> a
/ Float
dt :: Int)
else
forall a. IORef a -> a -> IdleCallback
writeIORef IORef IOState
ioStateRef forall a b. (a -> b) -> a -> b
$ IOState
ioState {
totUpdates :: Int
totUpdates = IOState -> Int
totUpdates IOState
ioState forall a. Num a => a -> a -> a
+ Int
1, curNumUpdates :: Int
curNumUpdates = Int
numUpdates forall a. Num a => a -> a -> a
+ Int
1 }
let captureToFile :: String -> IdleCallback
captureToFile String
fname = IO ByteString
capturePPM forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ByteString -> IdleCallback
BS.writeFile (String
fname forall a. [a] -> [a] -> [a]
++ String
".ppm")
case GlutRunMode
runMode of
GlutRunMode
GlutNormal -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
GlutCaptureLatest String
fname ->
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float
dt forall a. Ord a => a -> a -> Bool
> Float
0.1) (String -> IdleCallback
captureToFile String
fname)
GlutCaptureFrames String
fname ->
String -> IdleCallback
captureToFile forall a b. (a -> b) -> a -> b
$ String
fname forall a. [a] -> [a] -> [a]
++ String
"/frame" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (IOState -> Int
totUpdates IOState
ioState)
GlutCaptureAndExit String
fname ->
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IOState -> Int
totUpdates IOState
ioState forall a. Ord a => a -> a -> Bool
> Int
30) forall a b. (a -> b) -> a -> b
$ do
String -> IdleCallback
captureToFile String
fname
forall (m :: * -> *). MonadIO m => m ()
leaveMainLoop
setUniform :: IOState -> RunObj -> UniformVar -> IO ()
setUniform :: IOState -> RunObj -> UniformVar -> IdleCallback
setUniform IOState
ioState RunObj
obj (UniformVar ExprID
id GLExpr 'HostDomain t
x) = do
(UniformLocation GLint
ul) <- forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get (Program -> String -> GettableStateVar UniformLocation
uniformLocation (RunObj -> Program
prog RunObj
obj) (ExprID -> String
idLabel ExprID
id))
t
val <- forall t. IOEvaluator -> GLExpr 'HostDomain t -> IO t
hostEval (forall t. IOState -> GLExpr 'HostDomain t -> IO t
ioEval IOState
ioState) GLExpr 'HostDomain t
x
forall t. GLType t => GLint -> t -> IdleCallback
uniformSet GLint
ul t
val
updatePrecMap :: IOState -> IO ()
updatePrecMap :: IOState -> IdleCallback
updatePrecMap IOState
ioState = do
let updateVal :: IOState -> GLExpr 'HostDomain t -> p -> IO (Identity t)
updateVal IOState
ioState (GLAtom ExprID
_ (IOPrec GLExpr 'HostDomain t
_ GLExpr 'HostDomain t
x) :: GLExpr HostDomain t) p
_ =
forall a. a -> Identity a
Identity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. IOEvaluator -> GLExpr 'HostDomain t -> IO t
hostEval (forall t. IOState -> GLExpr 'HostDomain t -> IO t
ioEval IOState
ioState) GLExpr 'HostDomain t
x
DepMap (GLExpr 'HostDomain) Identity
pm <- forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ IOState -> IORef (DepMap (GLExpr 'HostDomain) Identity)
precMap IOState
ioState
DepMap (GLExpr 'HostDomain) Identity
_ <- forall (a :: * -> *) (k :: * -> *) (v1 :: * -> *) (v2 :: * -> *).
Applicative a =>
(forall t. k t -> v1 t -> a (v2 t))
-> DepMap k v1 -> a (DepMap k v2)
DepMap.traverseWithKey (forall {t} {p}.
IOState -> GLExpr 'HostDomain t -> p -> IO (Identity t)
updateVal IOState
ioState) DepMap (GLExpr 'HostDomain) Identity
pm
DepMap (GLExpr 'HostDomain) Identity
pm <- forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ IOState -> IORef (DepMap (GLExpr 'HostDomain) Identity)
precMap IOState
ioState
DepMap (GLExpr 'HostDomain) Identity
pm1 <- forall (a :: * -> *) (k :: * -> *) (v1 :: * -> *) (v2 :: * -> *).
Applicative a =>
(forall t. k t -> v1 t -> a (v2 t))
-> DepMap k v1 -> a (DepMap k v2)
DepMap.traverseWithKey (forall {t} {p}.
IOState -> GLExpr 'HostDomain t -> p -> IO (Identity t)
updateVal IOState
ioState) DepMap (GLExpr 'HostDomain) Identity
pm
forall a. IORef a -> a -> IdleCallback
writeIORef (IOState -> IORef (DepMap (GLExpr 'HostDomain) Identity)
precMap IOState
ioState) DepMap (GLExpr 'HostDomain) Identity
pm1
display :: [RunObj] -> DisplayCallback
display :: [RunObj] -> IdleCallback
display [RunObj]
objs = do
[ClearBuffer] -> IdleCallback
clear [ClearBuffer
ColorBuffer, ClearBuffer
DepthBuffer]
let doVao :: RunObj -> IdleCallback
doVao RunObj
obj = do
StateVar (Maybe Program)
currentProgram forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just (RunObj -> Program
prog RunObj
obj)
StateVar (Maybe VertexArrayObject)
bindVertexArrayObject forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= forall a. a -> Maybe a
Just (RunObj -> VertexArrayObject
vao RunObj
obj)
PrimitiveMode -> Maybe [ConstExpr UInt] -> Int -> IdleCallback
draw (RunObj -> PrimitiveMode
primitiveMode RunObj
obj) (RunObj -> Maybe [ConstExpr UInt]
indices RunObj
obj) (RunObj -> Int
numVerts RunObj
obj)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RunObj -> IdleCallback
doVao [RunObj]
objs
IdleCallback
flush
draw :: PrimitiveMode -> Maybe [ConstExpr UInt] -> Int -> IO ()
draw :: PrimitiveMode -> Maybe [ConstExpr UInt] -> Int -> IdleCallback
draw PrimitiveMode
mode Maybe [ConstExpr UInt]
Nothing Int
n =
PrimitiveMode -> GLint -> GLint -> IdleCallback
drawArrays PrimitiveMode
mode GLint
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
draw PrimitiveMode
mode (Just [ConstExpr UInt]
inds) Int
_ =
forall a.
PrimitiveMode -> GLint -> DataType -> Ptr a -> IdleCallback
drawElements PrimitiveMode
mode (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstExpr UInt]
inds) DataType
UnsignedInt (forall a. Int -> Ptr a
makeOff Int
0)
ioStateUpdate :: IORef IOState -> IO ()
ioStateUpdate :: IORef IOState -> IdleCallback
ioStateUpdate IORef IOState
ioState =
let decayWheel :: IOState -> IOState
decayWheel IOState
ioState = IOState
ioState { mouseWheel :: Float
mouseWheel = Float
0.1 forall a. Num a => a -> a -> a
* IOState -> Float
mouseWheel IOState
ioState }
in forall a. IORef a -> (a -> a) -> IdleCallback
modifyIORef IORef IOState
ioState IOState -> IOState
decayWheel
mouse :: IORef IOState -> MouseCallback
mouse :: IORef IOState -> MouseCallback
mouse IORef IOState
ioState MouseButton
LeftButton KeyState
mouseState Position
_ =
let updateLeft :: IOState -> IOState
updateLeft IOState
ioState = IOState
ioState { mouseLeftDown :: Bool
mouseLeftDown = KeyState
mouseState forall a. Eq a => a -> a -> Bool
== KeyState
Down }
in forall a. IORef a -> (a -> a) -> IdleCallback
modifyIORef IORef IOState
ioState IOState -> IOState
updateLeft
mouse IORef IOState
ioState MouseButton
RightButton KeyState
mouseState Position
_ =
let updateRight :: IOState -> IOState
updateRight IOState
ioState = IOState
ioState { mouseRightDown :: Bool
mouseRightDown = KeyState
mouseState forall a. Eq a => a -> a -> Bool
== KeyState
Down }
in forall a. IORef a -> (a -> a) -> IdleCallback
modifyIORef IORef IOState
ioState IOState -> IOState
updateRight
mouse IORef IOState
ioState MouseButton
WheelUp KeyState
_ Position
_ =
let updateWheel :: IOState -> IOState
updateWheel IOState
ioState = IOState
ioState { mouseWheel :: Float
mouseWheel = Float
1 }
in forall a. IORef a -> (a -> a) -> IdleCallback
modifyIORef IORef IOState
ioState IOState -> IOState
updateWheel
mouse IORef IOState
ioState MouseButton
WheelDown KeyState
_ Position
_ =
let updateWheel :: IOState -> IOState
updateWheel IOState
ioState = IOState
ioState { mouseWheel :: Float
mouseWheel = -Float
1 }
in forall a. IORef a -> (a -> a) -> IdleCallback
modifyIORef IORef IOState
ioState IOState -> IOState
updateWheel
mouse IORef IOState
_ MouseButton
_ KeyState
_ Position
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
motion :: IORef IOState -> MotionCallback
motion :: IORef IOState -> MotionCallback
motion IORef IOState
ioState (Position GLint
x GLint
y) =
let updatePos :: IOState -> IOState
updatePos IOState
ioState = IOState
ioState { curMouseX :: Int
curMouseX = forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
x, curMouseY :: Int
curMouseY = forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
y }
in forall a. IORef a -> (a -> a) -> IdleCallback
modifyIORef IORef IOState
ioState IOState -> IOState
updatePos
ioEval :: IOState -> GLExpr HostDomain t -> IO t
ioEval :: forall t. IOState -> GLExpr 'HostDomain t -> IO t
ioEval IOState
ioState e :: GLExpr 'HostDomain t
e@(GLAtom ExprID
_ (IOPrec GLExpr 'HostDomain t
x0 GLExpr 'HostDomain t
_)) = do
DepMap (GLExpr 'HostDomain) Identity
pm <- forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ IOState -> IORef (DepMap (GLExpr 'HostDomain) Identity)
precMap IOState
ioState
case forall (k :: * -> *) t (v :: * -> *).
GenHashable k =>
k t -> DepMap k v -> Maybe (v t)
DepMap.lookup GLExpr 'HostDomain t
e DepMap (GLExpr 'HostDomain) Identity
pm of
Just Identity t
val -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Identity a -> a
runIdentity Identity t
val
Maybe (Identity t)
Nothing -> do
t
val <- forall t. IOEvaluator -> GLExpr 'HostDomain t -> IO t
hostEval (forall t. IOState -> GLExpr 'HostDomain t -> IO t
ioEval IOState
ioState) GLExpr 'HostDomain t
x0
forall a. IORef a -> a -> IdleCallback
writeIORef (IOState -> IORef (DepMap (GLExpr 'HostDomain) Identity)
precMap IOState
ioState) forall a b. (a -> b) -> a -> b
$ forall (k :: * -> *) t (v :: * -> *).
GenHashable k =>
k t -> v t -> DepMap k v -> DepMap k v
DepMap.insert GLExpr 'HostDomain t
e (forall a. a -> Identity a
Identity t
val) DepMap (GLExpr 'HostDomain) Identity
pm
forall (m :: * -> *) a. Monad m => a -> m a
return t
val
ioEval IOState
ioState (GLAtom ExprID
_ (IOFloat String
"time")) = do
let t0 :: Float
t0 = IOState -> Float
initTime IOState
ioState
UTCTime
epoch <- IO UTCTime
getCurrentTime
let t :: t
t = forall a. Fractional a => Rational -> a
fromRational forall a b. (a -> b) -> a -> b
$ forall a. Real a => a -> Rational
toRational forall a b. (a -> b) -> a -> b
$ UTCTime -> DiffTime
utctDayTime UTCTime
epoch
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ t
t forall a. Num a => a -> a -> a
- Float
t0
ioEval IOState
ioState (GLAtom ExprID
_ (IOBool String
"mouseLeft")) =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum) forall a b. (a -> b) -> a -> b
$ IOState -> Bool
mouseLeftDown IOState
ioState
ioEval IOState
ioState (GLAtom ExprID
_ (IOBool String
"mouseRight")) =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum) forall a b. (a -> b) -> a -> b
$ IOState -> Bool
mouseRightDown IOState
ioState
ioEval IOState
ioState (GLAtom ExprID
_ (IOFloat String
"mouseWheel")) =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ IOState -> Float
mouseWheel IOState
ioState
ioEval IOState
ioState (GLAtom ExprID
_ (IOFloat String
"mouseX")) = do
(Size GLint
width GLint
_) <- forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get StateVar Size
windowSize
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (IOState -> Int
curMouseX IOState
ioState) forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
width
ioEval IOState
ioState (GLAtom ExprID
_ (IOFloat String
"mouseY")) = do
(Size GLint
_ GLint
height) <- forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get StateVar Size
windowSize
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ t
1 forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral (IOState -> Int
curMouseY IOState
ioState) forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
height