Adapter.hs

{-# OPTIONS -Wall #-}
----------------------------------------------------------------------
-- |
-- Module      :  FRP.Reactive.GLUT.Adapter
-- Copyright   :  (c) Conal Elliott 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Connect Reactive + GLUT
----------------------------------------------------------------------

module FRP.Reactive.GLUT.Adapter
  ( adaptSimple, adapt, simpleInit
  , Action, Sink
  , module FRP.Reactive.GLUT.UI
  ) where

import Control.Applicative ((<$>))
import Control.Monad ((>=>))

import qualified Graphics.UI.GLUT as G

import FRP.Reactive (Behavior,stepper)

import FRP.Reactive.Internal.Misc   (Sink,Action)
import FRP.Reactive.Internal.Clock  (makeClock,cGetTime)
import FRP.Reactive.Internal.TVal   (makeEvent)
import FRP.Reactive.Internal.Timing (mkUpdater)

import FRP.Reactive.GLUT.UI
import FRP.Reactive.GLUT.SimpleGL

-- | Adapter to connect @FRP.Reactive@ with @GLUT@.  Uses given window
-- title and a simple canned initialization.  Or do your own
-- initialization and then invoke 'adapt'.
adaptSimple :: String -> Sink (UI -> Behavior Action)
adaptSimple title snk = simpleInit title >> adapt snk

-- | Adapter to connect @FRP.Reactive@ with @GLUT@.  Assumes that GL/GLUT
-- have been initialized as desired.
adapt :: Sink (UI -> Behavior Action)
adapt f =
  do clock <- makeClock
     let mkE = makeEvent clock
     (mousePosE, mousePosSink ) <- mkE
     (leftDown , leftDownSink ) <- mkE
     (rightDown, rightDownSink) <- mkE
     (keyPress , keyPressSink ) <- mkE
     (tick     , tickSink     ) <- mkE
     -- TODO: let the initial mouse position be its actual position
     let windowPoint' p = do -- putStrLn $ "window point " ++ show p
                             windowPoint p
         mousePosSink' p = do -- putStrLn $ "mouse " ++ show p
                              mousePosSink p
                              -- yield
         mousePos = (0.0,0.0) `stepper` mousePosE
         mouseCB  = Just (windowPoint' >=> mousePosSink')
     -- Callbacks
     G.passiveMotionCallback G.$= mouseCB
     G.motionCallback        G.$= mouseCB
     G.displayCallback       G.$= return ()
     G.keyboardMouseCallback G.$= Just (\k ks _ _ ->
       case (k,ks) of
         (G.MouseButton G.LeftButton ,G.Down) -> leftDownSink  ()
         (G.MouseButton G.RightButton,G.Down) -> rightDownSink ()
         (G.Char c      ,G.Down) -> keyPressSink (Char c)
         (G.SpecialKey s,G.Down) -> keyPressSink (SpecialKey s)
         _ -> return ()
      )
     updater <- mkUpdater
                 (cGetTime clock)
                 (glwrap <$> f (UI mousePos leftDown rightDown keyPress tick))
     schedule (updater >> tickSink ())
     -- putStrLn "mainLoop"
     G.mainLoop

-- TODO: figure out how to exit cleanly. Right now mainLoop never returns
--   killThread programTid
--   exitWith ExitSuccess
-- Better yet, don't kill the process.  Instead leave the GL state such
-- that ghci can continue with more graphical yumminess.


-- Schedule an action for regular execution.  This version uses idle
-- callback.  Could instead use a chain of timer call-backs, which could
-- then limit the update rate.  (On my Windows machine, I'm getting exactly
-- 64fps most of the time for extremely simple graphics.  I guess there's
-- something wired into G.idleCallback. -Conal)

-- Schedule using idle callback.
scheduleIdle :: Sink Action
scheduleIdle act = G.idleCallback G.$= Just act

-- Schedule using the timer callback.  No matter how small an interval I
-- choose, I still get max 64 frames/sec.
scheduleTimer :: Sink Action
scheduleTimer act = G.addTimerCallback ms (act >> scheduleTimer act)
 where
   ms = 10

-- Schedule an action for repeated execution
schedule :: Sink Action
schedule | useIdle   = scheduleIdle
         | otherwise = scheduleTimer

-- Whether to use the 'scheduleIdle' or 'scheduleTimer'.
useIdle :: Bool
useIdle = False

-- Both schedulers seem to work great.