module FRP.Yampa.GLFW.Adapter
( adaptSimple, adapt, simpleInit
, Action, Reaction
, actionIO, actionExit
, module FRP.Yampa.GLFW.UI
) where
import Control.Arrow
import Control.Monad
import Control.Newtype
import Data.IORef
import Data.Monoid
import qualified "GLFW-b" Graphics.UI.GLFW as GLFW
import qualified Graphics.Rendering.OpenGL as GL
import FRP.Yampa (SF, reactInit, react)
import FRP.Yampa.Event
import FRP.Yampa.GLFW.InternalUI
import FRP.Yampa.GLFW.UI
import Unsafe.Coerce
adaptSimple :: String -> Reaction -> IO ()
adaptSimple title sf = simpleInit title >> adapt sf
adapt :: Reaction -> IO ()
adapt sf = do
timeRef <- newIORef (0.0 :: Double)
closeFlag <- newIORef False
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 <- readIORef timeRef
time' <- GLFW.getTime
writeIORef timeRef time'
let dt = (time' time)
b <- react rh (dt, Just (Event ev))
if b then writeIORef closeFlag True
else return ()
GLFW.setWindowCloseCallback $ do
writeIORef closeFlag True
return True
GLFW.setWindowSizeCallback $ (\ w h -> reactEvent $ GlfwWindowResize $ GL.Size (unsafeCoerce w) (unsafeCoerce h))
GLFW.setMouseButtonCallback $ (\ btn st -> reactEvent $ GlfwMouseButton btn st)
GLFW.setMousePositionCallback $ (\ x y -> reactEvent $ GlfwMousePosition $ GL.Position (unsafeCoerce x) (unsafeCoerce y))
GLFW.setKeyCallback $ (\ ch st -> reactEvent $ GlfwKey ch st)
let loop' = do
reactEvent GlfwRedraw
closep <- readIORef closeFlag
unless closep loop'
loop'
simpleInit :: String -> IO Bool
simpleInit title = do
success <- GLFW.initialize
if success
then do
_ <- GLFW.openWindow GLFW.defaultDisplayOptions
{ GLFW.displayOptions_width = 1024
, GLFW.displayOptions_height = 768
}
GLFW.setWindowTitle title
return True
else return False
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