experimental multiplier for framesync
[maximus:graphgrow.git] / Fractal / GraphGrow / UI / FrameSync.hs
1 module Fractal.GraphGrow.UI.FrameSync
2   ( FrameSyncOptions(..)
3   , defaultFrameSyncOptions
4   , newFrameSync
5   , FrameSync
6   , Deadline(..)
7   , Statistics(..)
8   ) where
9
10 import Prelude hiding ((++))
11
12 import Control.Monad (replicateM_)
13 import Data.IORef (newIORef, readIORef, writeIORef)
14 import Data.List (foldl')
15 import Data.Monoid (Monoid(..))
16 import Graphics.UI.GLFW as G
17
18 import Fractal.GraphGrow.Analysis.Statistics hiding (s0)
19
20 data Statistics = Statistics
21   { statFrameTime :: !(StatOrd Double)
22   , statSpareTime :: !(StatOrd Double)
23   , statOk        :: !(StatOrd Double)
24   , statMissed    :: !Int
25   , statCount     :: !Int
26   }
27
28 instance Monoid Statistics where
29   mempty = let e = mempty in Statistics e e e 0 0
30   Statistics a b c d e `mappend` Statistics s t u v w = let (++) = mappend in Statistics (a++s)(b++t)(c++u)(d+v)(e+w)
31   mconcat = foldl' mappend mempty
32
33 data Deadline = Missed | Ok !Double
34   deriving (Read, Show, Eq, Ord)
35
36 type FrameSync = IO (Deadline, Statistics)
37
38 -- expected load average = 1 - (late + early)/2
39 data FrameSyncOptions = FrameSyncOptions
40   { frameSyncMeasure  :: Int
41   , frameSyncMultiple :: Int
42   , frameSyncMissed   :: Double
43   , frameSyncTarget   :: Double
44   }
45
46 defaultFrameSyncOptions :: FrameSyncOptions
47 defaultFrameSyncOptions = FrameSyncOptions
48   { frameSyncMeasure  = 500
49   , frameSyncMultiple = 1
50   , frameSyncMissed   = 1.5
51   , frameSyncTarget   = 0.75
52   }
53
54 newFrameSync :: FrameSyncOptions -> IO (Double, FrameSync)
55 newFrameSync opts = do
56   frameInterval <- measureFrameInterval (frameSyncMeasure opts)
57   statRef <- newIORef mempty
58   frameTimeRef <- newIORef =<< G.getTime
59   let interval = fromIntegral (frameSyncMultiple opts) * frameInterval
60       frameSync = do
61         lastTime <- readIORef frameTimeRef
62         preTime <- G.getTime
63         G.swapBuffers
64         frameTime <- G.getTime
65         writeIORef frameTimeRef frameTime
66         s0 <- readIORef statRef
67         let s = s0{ statFrameTime = statFrameTime s0 `mappend` statOrd (frameTime - lastTime)
68                   , statSpareTime = statSpareTime s0 `mappend` statOrd (frameTime - preTime )
69                   , statCount     = statCount s0 + 1
70                   }
71             missed = frameTime - lastTime > interval * frameSyncMissed opts
72             delta = (frameTime - preTime) / (interval * (1 - frameSyncTarget opts))
73             result@(_, s')
74               | missed    = (Missed,   s{ statMissed = statMissed s + 1 })
75               | otherwise = (Ok delta, s{ statOk = statOk s `mappend` statOrd delta })
76         writeIORef statRef s'
77         return result
78   return (recip interval, frameSync)
79
80 measureFrameInterval :: Int -> IO Double
81 measureFrameInterval count = do
82   G.swapBuffers
83   startTime <- G.getTime
84   replicateM_ count G.swapBuffers
85   endTime <- G.getTime
86   return $ (endTime - startTime) / fromIntegral count