module FRP.MoeGLUT (module FRP.MoeGLUT,
module Graphics.UI.GLUT) where
import FRP.Moe.Core
import Control.Arrow
import Data.IORef
import Graphics.UI.GLUT
type Time = Int
type Input = Maybe (Key, KeyState, Modifiers, Position)
type Prog b = SF Input b
type Handle b = IORef (Prog b, Time, b)
timer :: Handle b -> Int -> (b -> IO ()) -> IdleCallback
timer r tick act = do clear [ColorBuffer]
(sf, t, y) <- readIORef r
t' <- get elapsedTime
let deltat = t' t
timeOut = tick * 2
deltat' = if deltat < timeOut then deltat else timeOut
dt = fromIntegral deltat' / 1000
(y, sf') = runSF sf dt Nothing
writeIORef r (sf', t', y)
print deltat'
addTimerCallback tick (timer r tick act)
act y
swapBuffers
keyMouse :: Handle b -> KeyboardMouseCallback
keyMouse r k ks mod pos = do (sf, t, _) <- readIORef r
t' <- get elapsedTime
let (y, sf') = runSF sf (fromIntegral (t' t) / 1000) (Just (k, ks, mod, pos))
y `seq` writeIORef r (sf', t', y)
defaultReshape :: ReshapeCallback
defaultReshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
ortho2D 0 (fromIntegral w) 0 (fromIntegral h)
matrixMode $= Modelview 0
data DisplaySetup = DisplaySetup {displayTitle :: String,
displayMode :: [DisplayMode],
displaySize :: Size,
displayPosition :: Position,
displayColor :: Color4 GLclampf,
displayReshape :: ReshapeCallback,
displayInit :: (String, [String]) -> IO ()
}
defaultDisplaySetup = DisplaySetup {displayTitle = "moeDefault",
displayMode = [DoubleBuffered, RGBAMode],
displaySize = Size 800 600,
displayPosition = Position 0 0,
displayColor = Color4 0 0 0 0,
displayReshape = defaultReshape,
displayInit = const $ return ()
}
startProg :: DisplaySetup -> Int -> Prog b -> b -> (b -> IO ()) -> IO ()
startProg ds tick sf y0 act = let title = displayTitle ds
mode = displayMode ds
size = displaySize ds
position = displayPosition ds
color = displayColor ds
reshape = displayReshape ds
init = displayInit ds
in do nameAndArgs <- getArgsAndInitialize
initialDisplayMode $= mode
initialWindowSize $= size
initialWindowPosition $= position
createWindow title
clearColor $= color
init nameAndArgs
t0 <- get elapsedTime
r <- newIORef (sf, t0, y0)
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyMouse r)
addTimerCallback tick (timer r tick act)
displayCallback $= return ()
mainLoop
start = startProg defaultDisplaySetup