{-# LANGUAGE FlexibleInstances, RankNTypes #-}
module FRP.MoeGLUT (module FRP.MoeGLUT,
                    module Graphics.UI.GLUT) where

import FRP.Moe.Core
import Control.Arrow
import Data.IORef
import Graphics.UI.GLUT

type Time = Int

type Input = Maybe (Key, KeyState, Modifiers, Position)

type Prog b = SF Input b

type Handle b = IORef (Prog b, Time, b)

timer :: Handle b -> Int -> (b -> IO ()) -> IdleCallback
timer r tick act = do clear [ColorBuffer]
                      (sf, t, y) <- readIORef r
                      t' <- get elapsedTime
                      let deltat = t' - t
                          timeOut = tick * 2
                          deltat' = if deltat < timeOut then deltat else timeOut
                          dt = fromIntegral deltat' / 1000
                          (y, sf') = runSF sf dt Nothing
                      writeIORef r (sf', t', y)
                      print deltat'
                      addTimerCallback tick (timer r tick act)                      
                      act y
                      swapBuffers

                
keyMouse :: Handle b -> KeyboardMouseCallback
keyMouse r k ks mod pos = do (sf, t, _) <- readIORef r
                             t' <- get elapsedTime
                             let (y, sf') = runSF sf (fromIntegral (t' - t) / 1000) (Just (k, ks, mod, pos))
                             y `seq` writeIORef r (sf', t', y)
                             
defaultReshape :: ReshapeCallback
defaultReshape size@(Size w h) = do
   viewport $= (Position 0 0, size)
   matrixMode $= Projection
   loadIdentity
   ortho2D 0 (fromIntegral w) 0 (fromIntegral h)
   matrixMode $= Modelview 0

data DisplaySetup = DisplaySetup {displayTitle :: String,
                                  displayMode :: [DisplayMode],
                                  displaySize :: Size,
                                  displayPosition :: Position,
                                  displayColor :: Color4 GLclampf,
                                  displayReshape :: ReshapeCallback,
                                  displayInit :: (String, [String]) -> IO ()
                                  }

defaultDisplaySetup = DisplaySetup {displayTitle = "moeDefault",
                                    displayMode = [DoubleBuffered, RGBAMode],
                                    displaySize = Size 800 600,
                                    displayPosition = Position 0 0,
                                    displayColor = Color4 0 0 0 0,
                                    displayReshape = defaultReshape,
                                    displayInit = const $ return ()
                                    }                                   

startProg :: DisplaySetup -> Int -> Prog b -> b -> (b -> IO ()) -> IO ()
startProg ds tick sf y0 act =  let title = displayTitle ds
                                   mode = displayMode ds
                                   size = displaySize ds
                                   position = displayPosition ds
                                   color = displayColor ds
                                   reshape = displayReshape ds
                                   init = displayInit ds
                                in do nameAndArgs <- getArgsAndInitialize
                                      initialDisplayMode $= mode
                                      initialWindowSize $= size
                                      initialWindowPosition $= position
                                      createWindow title
                                      clearColor $= color
                                      init nameAndArgs
                                      t0 <- get elapsedTime
                                      r <- newIORef (sf, t0, y0)
                                      reshapeCallback $= Just reshape
                                      keyboardMouseCallback $= Just (keyMouse r)
                                      addTimerCallback tick (timer r tick act)
                                      displayCallback $= return ()
                                      mainLoop                                   

start = startProg defaultDisplaySetup