{-# 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


-- | Options specific to a GLUT window
data GlutOptions = GlutOptions {
    -- | The position of the window
    GlutOptions -> Maybe (GLint, GLint)
winPosition :: Maybe (GLint, GLint),
    -- | The size of the window
    GlutOptions -> (GLint, GLint)
winSize :: (GLsizei, GLsizei),
    -- | Whether to draw in fullscreen mode
    GlutOptions -> Bool
winFullscreen :: Bool,
    -- | The title of the window
    GlutOptions -> Maybe String
winTitle :: Maybe String,
    -- | The (background) color to use when clearing the screen
    GlutOptions -> (Float, Float, Float, Float)
clearCol :: (Float, Float, Float, Float),
    -- | The 'GlutRunMode' under which to run the application
    GlutOptions -> GlutRunMode
runMode :: GlutRunMode,
    -- | Any additional OpenGL-specific setup to run just after the window has
    -- been set up. The typical use-case is to import the OpenGL bindings
    -- ('Graphics.Rendering.OpenGL') and define a @StateVar@ such as @lineWidth@
    GlutOptions -> IdleCallback
openGLSetup :: IO ()
}

-- | 'GlutRunMode' specifies how to run the resulting application
data GlutRunMode =
    -- | Display the output in a window
    GlutNormal |
    -- | Display the output in a window, saving the latest frame in the
    -- specified file location
    GlutCaptureLatest String |
    -- | Display the output in a window, saving all frames in the specified
    -- directory
    GlutCaptureFrames String |
    -- | Display the output in a window for a brief period time, saving the
    -- latest frame in the specified file location
    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
    -- override default OpenGL values
    -- TODO: should access to values like these be provided
    -- directly, in the form of additional GlutOptions?
    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)

-- I/O state

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,
    -- for stats such as FPS
    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 logic

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
    -- prepare precMap for the next iteration
    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 }
    -- TODO: implement own capturePPM/PNG to remove the unecessary dependency
    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

-- note that shared uniforms are evaluated separately for each object
-- (except for any prec subexpressions)
-- it's possible that this may cause unexpected behaviour, in
-- which case a map of pre-computed shared values will be needed
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
    -- pm might have new keys so we need to read it again
    -- FIXME: find an alternative to this really ugly solution
    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


-- Draw logic

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)


-- I/O

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