module Brillo.Internals.Interface.Animate (animateWithBackendIO)
where

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


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 :: forall a.
Backend a =>
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 IORef a -> IO ()
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
              { 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 = 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 :: forall a r. 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