lambdacube-examples-0.2.1: src/Utils.hs

module Utils where

import Control.Monad
import Control.Monad.Trans
import Data.IORef

import FRP.Elerea.Param
import Graphics.UI.GLFW as GLFW

import Graphics.LambdaCube as LC

-- Reactive helper functions

integral :: (Real p, Fractional t) => t -> Signal t -> SignalGen p (Signal t)
integral v0 s = transfer v0 (\dt v v0 -> v0+v*realToFrac dt) s

driveNetwork :: (MonadIO m) => (p -> IO (m a)) -> IO (Maybe p) -> m ()
driveNetwork network driver = do
    dt <- liftIO driver
    case dt of
        Just dt -> do
            join . liftIO $ network dt
            driveNetwork network driver
        Nothing -> return ()

-- OpenGL/GLFW boilerplate

initCommon :: String -> IO (Signal (Int, Int))
initCommon title = do
    initialize
    openWindow defaultDisplayOptions
        { displayOptions_numRedBits     = 8
        , displayOptions_numGreenBits   = 8
        , displayOptions_numBlueBits    = 8
        , displayOptions_numDepthBits   = 24
        }
    --openWindow (Size 960 600) [DisplayRGBBits 8 8 8, DisplayAlphaBits 8, DisplayDepthBits 24] Window
    setWindowTitle title

    (windowSize,windowSizeSink) <- external (0,0)
    setWindowSizeCallback $ \w h -> do
        windowSizeSink (fromIntegral w, fromIntegral h)

    return windowSize

-- FPS tracking

data State = State { frames :: IORef Int, t0 :: IORef Double }

fpsState :: IO State
fpsState = do
    a <- newIORef 0
    b <- newIORef 0
    return $ State a b

updateFPS :: State -> Double -> IO ()
updateFPS state t1 = do
    let t = 1000*t1
        fR = frames state
        tR = t0 state
    modifyIORef fR (+1)
    --frames state $~! (+1)
    t0' <- readIORef tR
    writeIORef tR $ t0' + t
    --t0' <- get (t0 state)
    --t0 state $= t0' + t
    when (t + t0' >= 5000) $ do
    f <- readIORef fR --get (frames state)
    let seconds = (t + t0') / 1000
        fps = fromIntegral f / seconds
    putStrLn (show f ++ " frames in " ++ show seconds ++ " seconds = "++ show fps ++ " FPS")
    writeIORef tR 0 --t0 state $= 0
    writeIORef fR 0 --frames state $= 0

-- Continuous camera state (rotated with mouse, moved with arrows)

cameraSignal :: Real t => Vec3 -> Signal (FloatType, FloatType)
             -> Signal (Bool, Bool, Bool, Bool, Bool)
             -> SignalGen t (Signal (Vec3, Vec3, Vec3, (FloatType, FloatType)))
cameraSignal p mposs keyss = transfer2 (p,zero,zero,(0,0)) calcCam mposs keyss
  where
    d0 = Vec4 0 0 (-1) 1
    u0 = Vec4 0 1 0 1
    calcCam dt (dmx,dmy) (ka,kw,ks,kd,turbo) (p0,_,_,(mx,my)) = (p',d,u,(mx',my'))
      where
        f0 c n = if c then (&+ n) else id
        p'  = foldr1 (.) [f0 ka (v &* (-t)),f0 kw (d &* t),f0 ks (d &* (-t)),f0 kd (v &* t)] p0
        k   = if turbo then 100 else 30
        t   = k * realToFrac dt
        mx' = dmx + mx
        my' = dmy + my
        rm  = fromProjective $ rotationEuler $ Vec3 (mx' / 100) (my' / 100) 0
        d   = trim $ rm *. d0 :: Vec3 --Vec.take n3 $ rm `multmv` d0
        u   = trim $ rm *. u0 :: Vec3 --Vec.take n3 $ rm `multmv` u0
        v   = LC.normalize $ d &^ u