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(..), Sink(..))
import Control.Concurrent.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
glut :: Backend (ProgramToGlut a) (GlutToProgram a)
glut =
Backend b
where
b handler = do
_ <- getArgsAndInitialize
initialDisplayMode $~ (DoubleBuffered:)
createWindow "test"
displayCallback $= return ()
todoVar <- newMVar []
let
consume (DrawImage image) = do
clear [ ColorBuffer ]
runImage image
swapBuffers
flush
consume (SetTimer timeout tag) =
addTimerCallback timeout . handler . TimerEvent $ tag
preHandler event = do
todo <- takeMVar todoVar
putMVar todoVar []
mapM_ consume . reverse $ todo
handler event
setCallbacks = do
idleCallback $= Just (preHandler IdleEvent)
keyboardMouseCallback $=
Just (
(fmap . fmap . fmap . fmap)
preHandler KeyboardMouseEvent)
motionCallback $= Just motion
passiveMotionCallback $= Just motion
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
setCallbacks
return Sink
{ sinkConsume = modifyMVarPure todoVar . (:)
, sinkInit = handler $ MouseMotionEvent 0 0
, sinkMainLoop = Just mainLoop
, sinkQuitLoop = leaveMainLoop
}