module Graphics.Gloss.Internals.Interface.Animate
        (animateWithBackendIO)
where
import Graphics.Gloss.Data.Color
import Graphics.Gloss.Data.Controller
import Graphics.Gloss.Data.Picture
import Graphics.Gloss.Data.ViewPort
import Graphics.Gloss.Data.ViewState
import Graphics.Gloss.Rendering
import Graphics.Gloss.Internals.Interface.Backend
import Graphics.Gloss.Internals.Interface.Window
import Graphics.Gloss.Internals.Interface.Common.Exit
import Graphics.Gloss.Internals.Interface.ViewState.KeyMouse
import Graphics.Gloss.Internals.Interface.ViewState.Motion
import Graphics.Gloss.Internals.Interface.ViewState.Reshape
import Graphics.Gloss.Internals.Interface.Animate.Timing
import qualified Graphics.Gloss.Internals.Interface.Animate.State       as AN
import qualified Graphics.Gloss.Internals.Interface.Callback            as Callback
import Data.IORef
import Control.Monad
import System.Mem
import GHC.Float (double2Float)


animateWithBackendIO
        :: Backend a
        => a                     -- ^ Initial State of the backend
        -> Bool                  -- ^ Whether to allow the image to be panned around.
        -> Display               -- ^ Display mode.
        -> Color                 -- ^ Background color.
        -> (Float -> IO Picture) -- ^ Function to produce the next frame of animation.
                                 --     It is passed the time in seconds since the program started.
        -> (Controller -> IO ()) -- ^ Eat the controller.
        -> IO ()

animateWithBackendIO :: a
-> Bool
-> Display
-> Color
-> (Float -> IO Picture)
-> (Controller -> IO ())
-> IO ()
animateWithBackendIO
        a
backend Bool
pannable Display
display Color
backColor
        Float -> IO Picture
frameOp Controller -> IO ()
eatController
 = do
        --
        IORef ViewState
viewSR          <- ViewState -> IO (IORef ViewState)
forall a. a -> IO (IORef a)
newIORef ViewState
viewStateInit
        IORef State
animateSR       <- State -> IO (IORef State)
forall a. a -> IO (IORef a)
newIORef State
AN.stateInit
        State
renderS_        <- IO State
initState
        IORef State
renderSR        <- State -> IO (IORef State)
forall a. a -> IO (IORef a)
newIORef State
renderS_

        let displayFun :: IORef a -> IO ()
displayFun IORef a
backendRef = do
                -- extract the current time from the state
                Double
timeS           <- IORef State
animateSR IORef State -> (State -> Double) -> IO Double
forall a r. IORef a -> (a -> r) -> IO r
`getsIORef` State -> Double
AN.stateAnimateTime

                -- call the user action to get the animation frame
                Picture
picture         <- Float -> IO Picture
frameOp (Double -> Float
double2Float Double
timeS)

                State
renderS         <- IORef State -> IO State
forall a. IORef a -> IO a
readIORef IORef State
renderSR
                ViewPort
portS           <- ViewState -> ViewPort
viewStateViewPort (ViewState -> ViewPort) -> IO ViewState -> IO ViewPort
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef ViewState -> IO ViewState
forall a. IORef a -> IO a
readIORef IORef ViewState
viewSR

                (Int, Int)
windowSize      <- IORef a -> IO (Int, Int)
forall a. Backend a => IORef a -> IO (Int, Int)
getWindowDimensions IORef a
backendRef

                -- render the frame
                (Int, Int) -> Color -> State -> Float -> Picture -> IO ()
displayPicture
                        (Int, Int)
windowSize
                        Color
backColor
                        State
renderS
                        (ViewPort -> Float
viewPortScale ViewPort
portS)
                        (ViewPort -> Picture -> Picture
applyViewPortToPicture ViewPort
portS Picture
picture)

                -- perform GC every frame to try and avoid long pauses
                IO ()
performGC

        let callbacks :: [Callback]
callbacks
             =  [ DisplayCallback -> Callback
Callback.Display      (IORef State -> DisplayCallback
animateBegin IORef State
animateSR)
                , DisplayCallback -> Callback
Callback.Display      DisplayCallback
displayFun
                , DisplayCallback -> Callback
Callback.Display      (IORef State -> DisplayCallback
animateEnd   IORef State
animateSR)
                , DisplayCallback -> Callback
Callback.Idle         (\IORef a
s -> IORef a -> IO ()
DisplayCallback
postRedisplay IORef a
s)
                , () -> Callback
forall a. a -> Callback
callback_exit ()
                , IORef ViewState -> Callback
callback_viewState_motion IORef ViewState
viewSR
                , Callback
callback_viewState_reshape ]

             [Callback] -> [Callback] -> [Callback]
forall a. [a] -> [a] -> [a]
++ (if Bool
pannable
                  then [IORef ViewState -> Callback
callback_viewState_keyMouse IORef ViewState
viewSR]
                  else [])

        a -> Display -> Color -> [Callback] -> (IORef a -> IO ()) -> IO ()
forall a.
Backend a =>
a -> Display -> Color -> [Callback] -> (IORef a -> IO ()) -> IO ()
createWindow a
backend Display
display Color
backColor [Callback]
callbacks
           ((IORef a -> IO ()) -> IO ()) -> (IORef a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ IORef a
backendRef
           ->  Controller -> IO ()
eatController
                (Controller -> IO ()) -> Controller -> IO ()
forall a b. (a -> b) -> a -> b
$ Controller :: IO () -> ((ViewPort -> IO ViewPort) -> IO ()) -> Controller
Controller
                { controllerSetRedraw :: IO ()
controllerSetRedraw
                   = IORef a -> IO ()
DisplayCallback
postRedisplay IORef a
backendRef

                , controllerModifyViewPort :: (ViewPort -> IO ViewPort) -> IO ()
controllerModifyViewPort
                   = \ViewPort -> IO ViewPort
modViewPort
                     -> do ViewState
viewState       <- IORef ViewState -> IO ViewState
forall a. IORef a -> IO a
readIORef IORef ViewState
viewSR
                           ViewPort
port'           <- ViewPort -> IO ViewPort
modViewPort (ViewPort -> IO ViewPort) -> ViewPort -> IO ViewPort
forall a b. (a -> b) -> a -> b
$ ViewState -> ViewPort
viewStateViewPort ViewState
viewState
                           let viewState' :: ViewState
viewState'  =  ViewState
viewState { viewStateViewPort :: ViewPort
viewStateViewPort = ViewPort
port' }
                           IORef ViewState -> ViewState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ViewState
viewSR ViewState
viewState'
                           IORef a -> IO ()
DisplayCallback
postRedisplay IORef a
backendRef
                }





getsIORef :: IORef a -> (a -> r) -> IO r
getsIORef :: IORef a -> (a -> r) -> IO r
getsIORef IORef a
ref a -> r
fun
 = (a -> r) -> IO a -> IO r
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> r
fun (IO a -> IO r) -> IO a -> IO r
forall a b. (a -> b) -> a -> b
$ IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
ref