module FRP.Yampa.GLUT.Adapter
( adaptSimple, adapt, simpleInit
, Action, Reaction
, actionIO, actionExit
, module FRP.Yampa.GLUT.UI
) where
import Control.Arrow
import Control.Newtype
import Data.IORef
import Data.Monoid
import Graphics.UI.GLUT
import FRP.Yampa (SF, reactInit, react)
import FRP.Yampa.Event
import FRP.Yampa.GLUT.InternalUI
import FRP.Yampa.GLUT.UI
adaptSimple :: String -> IO () -> Reaction -> IO ()
adaptSimple title fini sf = simpleInit title >> adapt fini sf
adapt :: IO () -> Reaction -> IO ()
adapt fini sf = do
timeRef <- newIORef (0 :: Int)
let rInit = return NoEvent
rActuate _ _ NoEvent = return False
rActuate _ _ (Event (ActionExit io)) = io >> return True
rActuate _ _ (Event (ActionIO io)) = io >> return False
rh <- reactInit rInit rActuate sf
let reactEvent ev = do
time <- get timeRef
time' <- get elapsedTime
let dt = fromIntegral (time' time) / 1000
b <- react rh (dt, Just (Event ev))
if b then fini
else writeIORef timeRef time'
displayCallback $= reactEvent GlutDisplay
reshapeCallback $= Just (reactEvent . GlutReshape)
motionCallback $= Just (reactEvent . GlutMotion)
passiveMotionCallback $= Just (reactEvent . GlutPassiveMotion)
keyboardMouseCallback $= Just (\k ks m p -> reactEvent (GlutKeyboardMouse k ks m p))
crossingCallback $= Just (reactEvent . GlutCrossing)
mainLoop
simpleInit :: String -> IO ()
simpleInit title = do
_ <- getArgsAndInitialize
gameModeCapabilities $= [ Where' GameModeBitsPerPlane IsEqualTo 24 ]
initialDisplayMode $= [ RGBMode, DoubleBuffered, WithDepthBuffer ]
_ <- createWindow title
actionOnWindowClose $= MainLoopReturns
let scheduleTick = do
let fps = 60
addTimerCallback (1000 `div` fps) tick
tick = do
postRedisplay Nothing
scheduleTick
scheduleTick
data Action = ActionExit (IO ())
| ActionIO (IO ())
actionIO :: IO () -> Action
actionIO = ActionIO
actionExit :: Action
actionExit = ActionExit (return ())
type Reaction = SF (Event UI) (Event Action)
instance Newtype Action (IO ()) where
pack = ActionIO
unpack (ActionIO x) = x
unpack (ActionExit x) = x
instance Monoid Action where
mempty = ActionIO (return ())
a@(ActionExit _) `mappend` _ = a
(ActionIO a) `mappend` (ActionExit b) = ActionExit (a >> b)
(ActionIO a) `mappend` (ActionIO b) = ActionIO (a >> b)
instance Monoid a => Monoid (Event a) where
mempty = Event mempty
NoEvent `mappend` b' = b'
Event a `mappend` b' = Event (a `mappend` f b') where
f NoEvent = mempty
f (Event b) = b
instance Monoid b => Monoid (SF a b) where
mempty = arr mempty
sfX `mappend` sfY = (sfX &&& sfY) >>^ uncurry mappend