{- | A pure @gloss@ backend for Rhine,
with separated event and simulation loop.

To run pure Rhine apps with @gloss@,
write a signal network ('SN') in the 'GlossCombinedClock' and use 'flowGlossCombined'.
As an easy starter, you can use the helper function 'buildGlossRhine'.
-}

{-# LANGUAGE Arrows #-}
{-# LANGUAGE RecordWildCards #-}

module FRP.Rhine.Gloss.Pure.Combined where

-- rhine
import FRP.Rhine
import FRP.Rhine.Reactimation.ClockErasure

-- rhine-gloss
import FRP.Rhine.Gloss.Common
import FRP.Rhine.Gloss.Pure

-- | The overall clock of a pure @rhine@ 'SN' that can be run by @gloss@.
--   It is combined of two subsystems, the event part and the simulation part.
--   @a@ is the type of subevents that are selected.
type GlossCombinedClock a
  = SequentialClock GlossM
      (GlossEventClock a)
      GlossSimulationClock

-- | Schedule the subclocks of the 'GlossCombinedClock'.
glossSchedule :: Schedule GlossM (GlossEventClock a) GlossSimulationClock
glossSchedule :: Schedule GlossM (GlossEventClock a) GlossSimulationClock
glossSchedule = Schedule GlossM (GlossEventClock a) GlossSimulationClock
forall (m :: * -> *) cl a b.
(Monad m, Semigroup cl, Clock m cl) =>
Schedule m (SelectClock cl a) (SelectClock cl b)
schedSelectClocks

-- ** Events

-- | The clock that ticks whenever a specific @gloss@ event occurs.
type GlossEventClock a = SelectClock GlossClock a

-- | Select the relevant events by converting them to @Just a@,
--   and the irrelevant ones to 'Nothing'.
glossEventSelectClock
  :: (Event -> Maybe a)
  -> GlossEventClock a
glossEventSelectClock :: (Event -> Maybe a) -> GlossEventClock a
glossEventSelectClock Event -> Maybe a
selector = SelectClock :: forall cl a. cl -> (Tag cl -> Maybe a) -> SelectClock cl a
SelectClock
  { mainClock :: GlossClock
mainClock = GlossClock
GlossClock
  , select :: Tag GlossClock -> Maybe a
select = (Maybe Event -> (Event -> Maybe a) -> Maybe a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Event -> Maybe a
selector)
  }

-- | Tick on every event.
glossEventClock :: GlossEventClock Event
glossEventClock :: GlossEventClock Event
glossEventClock = (Event -> Maybe Event) -> GlossEventClock Event
forall a. (Event -> Maybe a) -> GlossEventClock a
glossEventSelectClock Event -> Maybe Event
forall a. a -> Maybe a
Just

-- ** Simulation

-- | The clock that ticks for every @gloss@ simulation step.
type GlossSimulationClock = SelectClock GlossClock ()

glossSimulationClock :: GlossSimulationClock
glossSimulationClock :: GlossSimulationClock
glossSimulationClock = SelectClock :: forall cl a. cl -> (Tag cl -> Maybe a) -> SelectClock cl a
SelectClock { GlossClock
Tag GlossClock -> Maybe ()
forall a. Maybe a -> Maybe ()
select :: forall a. Maybe a -> Maybe ()
mainClock :: GlossClock
select :: Tag GlossClock -> Maybe ()
mainClock :: GlossClock
.. }
  where
    mainClock :: GlossClock
mainClock = GlossClock
GlossClock
    select :: Maybe a -> Maybe ()
select (Just a
_event) = Maybe ()
forall a. Maybe a
Nothing
    select Maybe a
Nothing        = () -> Maybe ()
forall a. a -> Maybe a
Just ()

-- * Signal networks

{- |
The type of a valid 'Rhine' that can be run by @gloss@,
if you chose to separate events and simulation into two subsystems.
@a@ is the type of subevents that are selected.

All painting has to be done in 'GlossM', e.g. via the 'paint' method.

Typically, such a 'Rhine' is built something like this:

@
-- | Select only key press events
myEventClock :: GlossEventClock Key
myEventClock = glossEventSelectClock selector
  where
    selector (EventKey key _ _ _) = Just key
    selector _ = Nothing

myEventSubsystem :: ClSF GlossM GlossEventClock () MyType
myEventSubsystem = ...

mySim :: ClSF GlossM GlossSimulationClock [MyType] ()
mySim = ...

myGlossRhine :: GlossRhine a
myGlossRhine
  = myEventSubsystem @@ myEventClock >-- collect -@- glossSchedule --> mySim @@ glossSimulationClock
@
-}
type GlossRhine a = Rhine GlossM (GlossCombinedClock a) () ()

{- | For most applications, it is sufficient to implement
a single signal function
that is called with a list of all relevant events
that occurred in the last tick.
-}
buildGlossRhine
  :: (Event -> Maybe a) -- ^ The event selector
  -> ClSF GlossM GlossSimulationClock [a] () -- ^ The 'ClSF' representing the game loop.
  -> GlossRhine a
buildGlossRhine :: (Event -> Maybe a)
-> ClSF GlossM GlossSimulationClock [a] () -> GlossRhine a
buildGlossRhine Event -> Maybe a
selector ClSF GlossM GlossSimulationClock [a] ()
clsfSim
  =   (TimeInfo (GlossEventClock a) -> a)
-> ClSF GlossM (GlossEventClock a) () a
forall (m :: * -> *) cl b a.
Monad m =>
(TimeInfo cl -> b) -> ClSF m cl a b
timeInfoOf TimeInfo (GlossEventClock a) -> a
forall cl. TimeInfo cl -> Tag cl
tag ClSF GlossM (GlossEventClock a) () a
-> GlossEventClock a -> Rhine GlossM (GlossEventClock a) () a
forall cl (m :: * -> *) a b.
(cl ~ In cl, cl ~ Out cl) =>
ClSF m cl a b -> cl -> Rhine m cl a b
@@ (Event -> Maybe a) -> GlossEventClock a
forall a. (Event -> Maybe a) -> GlossEventClock a
glossEventSelectClock Event -> Maybe a
selector
  Rhine GlossM (GlossEventClock a) () a
-> ResamplingPoint
     GlossM (GlossEventClock a) GlossSimulationClock a [a]
-> RhineAndResamplingPoint
     GlossM (GlossEventClock a) GlossSimulationClock () [a]
forall (m :: * -> *) cl1 a b cl2 c.
Rhine m cl1 a b
-> ResamplingPoint m cl1 cl2 b c
-> RhineAndResamplingPoint m cl1 cl2 a c
>-- ResamplingBuffer
  GlossM (Out (GlossEventClock a)) (In GlossSimulationClock) a [a]
forall (m :: * -> *) cl1 cl2 a.
Monad m =>
ResamplingBuffer m cl1 cl2 a [a]
collect       ResamplingBuffer
  GlossM (Out (GlossEventClock a)) (In GlossSimulationClock) a [a]
-> Schedule GlossM (GlossEventClock a) GlossSimulationClock
-> ResamplingPoint
     GlossM (GlossEventClock a) GlossSimulationClock a [a]
forall (m :: * -> *) cl1 cl2 a b.
ResamplingBuffer m (Out cl1) (In cl2) a b
-> Schedule m cl1 cl2 -> ResamplingPoint m cl1 cl2 a b
-@- Schedule GlossM (GlossEventClock a) GlossSimulationClock
forall a. Schedule GlossM (GlossEventClock a) GlossSimulationClock
glossSchedule
  RhineAndResamplingPoint
  GlossM (GlossEventClock a) GlossSimulationClock () [a]
-> Rhine GlossM GlossSimulationClock [a] () -> GlossRhine a
forall (m :: * -> *) cl1 cl2 a b c.
(Clock m cl1, Clock m cl2, Time cl1 ~ Time cl2,
 Time (Out cl1) ~ Time cl1, Time (In cl2) ~ Time cl2,
 Clock m (Out cl1), Clock m (Out cl2), Clock m (In cl1),
 Clock m (In cl2), GetClockProxy cl1, GetClockProxy cl2) =>
RhineAndResamplingPoint m cl1 cl2 a b
-> Rhine m cl2 b c -> Rhine m (SequentialClock m cl1 cl2) a c
--> ClSF GlossM GlossSimulationClock [a] ()
clsfSim        ClSF GlossM GlossSimulationClock [a] ()
-> GlossSimulationClock -> Rhine GlossM GlossSimulationClock [a] ()
forall cl (m :: * -> *) a b.
(cl ~ In cl, cl ~ Out cl) =>
ClSF m cl a b -> cl -> Rhine m cl a b
@@ GlossSimulationClock
glossSimulationClock

-- * Reactimation

-- | The main function that will start the @gloss@ backend and run the 'SN'.
flowGlossCombined
  :: GlossSettings
  -> GlossRhine a -- ^ The @gloss@-compatible 'Rhine'.
  -> IO ()
flowGlossCombined :: GlossSettings -> GlossRhine a -> IO ()
flowGlossCombined GlossSettings
settings Rhine { SN GlossM (GlossCombinedClock a) () ()
GlossCombinedClock a
sn :: forall (m :: * -> *) cl a b. Rhine m cl a b -> SN m cl a b
clock :: forall (m :: * -> *) cl a b. Rhine m cl a b -> cl
clock :: GlossCombinedClock a
sn :: SN GlossM (GlossCombinedClock a) () ()
.. } = GlossSettings
-> GlossCombinedClock a
-> MSF
     GlossM
     (Time (GlossCombinedClock a), Tag (GlossCombinedClock a))
     (Maybe ())
-> IO ()
forall cl b.
Clock GlossM cl =>
GlossSettings -> cl -> MSF GlossM (Time cl, Tag cl) b -> IO ()
flowGlossWithWorldMSF GlossSettings
settings GlossCombinedClock a
clock (MSF
   GlossM
   (Time (GlossCombinedClock a), Tag (GlossCombinedClock a))
   (Maybe ())
 -> IO ())
-> MSF
     GlossM
     (Time (GlossCombinedClock a), Tag (GlossCombinedClock a))
     (Maybe ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ proc (Time (GlossCombinedClock a), Tag (GlossCombinedClock a))
tick -> do
  Time (GlossCombinedClock a)
-> SN GlossM (GlossCombinedClock a) () ()
-> MSF
     GlossM
     (Time (GlossCombinedClock a), Tag (GlossCombinedClock a), Maybe ())
     (Maybe ())
forall (m :: * -> *) cl a b.
(Monad m, Clock m cl, GetClockProxy cl) =>
Time cl
-> SN m cl a b -> MSF m (Time cl, Tag cl, Maybe a) (Maybe b)
eraseClockSN Time (GlossCombinedClock a)
0 SN GlossM (GlossCombinedClock a) () ()
sn -< case (Time (GlossCombinedClock a), Tag (GlossCombinedClock a))
tick of
    (Time (GlossCombinedClock a)
_       , Left event) -> (Float
0       , a -> Either a ()
forall a b. a -> Either a b
Left a
event, () -> Maybe ()
forall a. a -> Maybe a
Just ())
    (Time (GlossCombinedClock a)
diffTime, Right ()  ) -> (Float
Time (GlossCombinedClock a)
diffTime, () -> Either a ()
forall a b. b -> Either a b
Right ()  , Maybe ()
forall a. Maybe a
Nothing)