module FRP.Peakachu.Backend.GLUT
( GlutToProgram(..), Image(..), ProgramToGlut(..), glut
, gIdleEvent, gTimerEvent, gMouseMotionEvent
, gKeyboardMouseEvent
) where
import Control.Concurrent.MVar.YC (modifyMVarPure)
import Data.ADT.Getters (mkADTGetters)
import FRP.Peakachu.Backend (Backend(..))
import FRP.Peakachu.Backend.Internal
(Sink(..), MainLoop(..), ParallelIO(..))
import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar)
import Data.Monoid (Monoid(..))
import Graphics.UI.GLUT
( GLfloat, ($=), ($~), get
, ClearBuffer(..), Key(..), KeyState(..)
, Modifiers, Position(..), Size(..), Timeout
, DisplayMode(..), initialDisplayMode, swapBuffers
, createWindow, getArgsAndInitialize
, displayCallback, idleCallback
, keyboardMouseCallback
, motionCallback, passiveMotionCallback
, windowSize, addTimerCallback
, clear, flush, mainLoop, leaveMainLoop
)
data Image = Image { runImage :: IO ()}
instance Monoid Image where
mempty = Image $ return ()
mappend (Image a) (Image b) = Image $ a >> b
data GlutToProgram a
= IdleEvent
| TimerEvent a
| MouseMotionEvent GLfloat GLfloat
| KeyboardMouseEvent Key KeyState Modifiers Position
$(mkADTGetters ''GlutToProgram)
data ProgramToGlut a
= DrawImage Image
| SetTimer Timeout a
glutConsume :: (GlutToProgram a -> IO ()) -> ProgramToGlut a -> IO ()
glutConsume _ (DrawImage image) = do
clear [ ColorBuffer ]
runImage image
swapBuffers
flush
glutConsume handler (SetTimer timeout tag) =
addTimerCallback timeout . handler . TimerEvent $ tag
setGlutCallbacks :: MVar [ProgramToGlut a] -> (GlutToProgram a -> IO ()) -> IO ()
setGlutCallbacks todoVar handler = do
idleCallback $= Just (preHandler IdleEvent)
keyboardMouseCallback $=
Just (
(fmap . fmap . fmap . fmap)
preHandler KeyboardMouseEvent)
motionCallback $= Just motion
passiveMotionCallback $= Just motion
where
preHandler event = do
todo <- takeMVar todoVar
putMVar todoVar []
mapM_ (glutConsume handler) . reverse $ todo
handler event
motion (Position px py) = do
Size sx sy <- get windowSize
preHandler $ MouseMotionEvent (p2g sx px) ( p2g sy py)
p2g sa pa = 2 * fromIntegral pa / fromIntegral sa 1
glut :: Backend (ProgramToGlut a) (GlutToProgram a)
glut =
Backend b
where
b handler = do
_ <- getArgsAndInitialize
initialDisplayMode $~ (DoubleBuffered:)
_ <- createWindow "test"
displayCallback $= return ()
todoVar <- newMVar []
setGlutCallbacks todoVar handler
return Sink
{ sinkConsume = modifyMVarPure todoVar . (:)
, sinkMainLoop =
MainLoop
{ mlInit = handler $ MouseMotionEvent 0 0
, mlQuit = leaveMainLoop
, mlRun = Just $ ParIO mainLoop
}
}