{-# LANGUAGE RankNTypes #-}

module Brillo.Internals.Interface.Simulate (simulateWithBackendIO)
where

import Brillo.Data.Color
import Brillo.Data.Display
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.Simulate.Idle
import Brillo.Internals.Interface.Simulate.State qualified as SM
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 Data.IORef
import System.Mem


simulateWithBackendIO
  :: forall model a
   . (Backend a)
  => a
  -- ^ Initial state of the backend
  -> Display
  -- ^ Display mode.
  -> Color
  -- ^ Background color.
  -> Int
  -- ^ Number of simulation steps to take for each second of real time.
  -> model
  -- ^ The initial model.
  -> (model -> IO Picture)
  -- ^ A function to convert the model to a picture.
  -> (ViewPort -> Float -> model -> IO model)
  -- ^ A function to step the model one iteration. It is passed the
  --     current viewport and the amount of time for this simulation
  --     step (in seconds).
  -> IO ()
simulateWithBackendIO :: forall model a.
Backend a =>
a
-> Display
-> Color
-> Int
-> model
-> (model -> IO Picture)
-> (ViewPort -> Float -> model -> IO model)
-> IO ()
simulateWithBackendIO
  a
backend
  Display
display
  Color
backgroundColor
  Int
simResolution
  model
worldStart
  model -> IO Picture
worldToPicture
  ViewPort -> Float -> model -> IO model
worldAdvance =
    do
      let singleStepTime :: Float
singleStepTime = Float
1

      -- make the simulation state
      IORef State
stateSR <- State -> IO (IORef State)
forall a. a -> IO (IORef a)
newIORef (State -> IO (IORef State)) -> State -> IO (IORef State)
forall a b. (a -> b) -> a -> b
$ Int -> State
SM.stateInit Int
simResolution

      -- make a reference to the initial world
      IORef model
worldSR <- model -> IO (IORef model)
forall a. a -> IO (IORef a)
newIORef model
worldStart

      -- make the initial GL view and render states
      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
              -- convert the world to a picture
              model
world <- IORef model -> IO model
forall a. IORef a -> IO a
readIORef IORef model
worldSR
              ViewPort
port <- 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
              Picture
picture <- model -> IO Picture
worldToPicture model
world

              -- display the picture in the current view
              State
renderS <- IORef State -> IO State
forall a. IORef a -> IO a
readIORef IORef State
renderSR

              (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
backgroundColor
                State
renderS
                (ViewPort -> Float
viewPortScale ViewPort
port)
                (ViewPort -> Picture -> Picture
applyViewPortToPicture ViewPort
port 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 State
-> IORef State
-> IO ViewPort
-> IORef model
-> (ViewPort -> Float -> model -> IO model)
-> Float
-> DisplayCallback
forall world.
IORef State
-> IORef State
-> IO ViewPort
-> IORef world
-> (ViewPort -> Float -> world -> IO world)
-> Float
-> DisplayCallback
callback_simulate_idle
                    IORef State
stateSR
                    IORef State
animateSR
                    (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)
                    IORef model
worldSR
                    ViewPort -> Float -> model -> IO model
worldAdvance
                    Float
singleStepTime
                )
            , () -> Callback
forall a. a -> Callback
callback_exit ()
            , IORef ViewState -> Callback
callback_viewState_keyMouse IORef ViewState
viewSR
            , IORef ViewState -> Callback
callback_viewState_motion IORef ViewState
viewSR
            , Callback
callback_viewState_reshape
            ]

      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
backgroundColor
        [Callback]
callbacks
        (IO () -> IORef a -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()))