module FRP.Peakachu.Backend.GLUT (
Image(..), UI(..), run
) where
import Data.Monoid (Monoid(..))
import FRP.Peakachu (ereturn)
import FRP.Peakachu.Internal (Event(..), makeCallbackEvent)
import Graphics.UI.GLUT (
($=), ($~), SettableStateVar, get,
ClearBuffer(..), Key(..), KeyState(..),
Modifiers, Position(..), GLfloat, Size(..),
DisplayMode(..), initialDisplayMode, swapBuffers,
createWindow, getArgsAndInitialize,
displayCallback, keyboardMouseCallback,
motionCallback, passiveMotionCallback,
windowSize,
clear, flush, mainLoop)
import Prelude hiding (repeat)
data Image = Image { runImage :: IO ()}
instance Monoid Image where
mempty = Image $ return ()
mappend (Image a) (Image b) = Image $ a >> b
data UI = UI {
mouseMotionEvent :: Event (GLfloat, GLfloat),
glutKeyboardMouseEvent :: Event (Key, KeyState, Modifiers, Position)
}
makeCallbackEvent' ::
SettableStateVar (Maybe b) ->
((a -> IO ()) -> b) ->
IO (Event a)
makeCallbackEvent' callbackVar trans = do
(event, callback) <- makeCallbackEvent
callbackVar $= Just (trans callback)
return event
createUI :: IO UI
createUI = do
Size sx sy <- get windowSize
glutMotionEvent <- makeCallbackEvent' motionCallback id
glutPassiveMotionEvent <- makeCallbackEvent' passiveMotionCallback id
glutKeyboardMouseE <-
makeCallbackEvent' keyboardMouseCallback $
\cb a b c d -> cb (a,b,c,d)
let
pixel2gl (Position px py) = (p2g sx px, p2g sy py)
p2g sa pa = 2 * fromIntegral pa / fromIntegral sa 1
return UI {
glutKeyboardMouseEvent = glutKeyboardMouseE,
mouseMotionEvent =
mappend (ereturn (0, 0)) .
fmap pixel2gl $
mappend glutMotionEvent glutPassiveMotionEvent
}
draw :: Image -> IO ()
draw image = do
clear [ ColorBuffer ]
runImage image
swapBuffers
flush
run :: (UI -> Event Image) -> IO ()
run programDesc = do
_ <- getArgsAndInitialize
initialDisplayMode $~ (DoubleBuffered:)
createWindow "test"
program <- fmap programDesc createUI
mapM_ draw (initialValues program)
addHandler program draw
displayCallback $= return ()
mainLoop