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

{- | 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'.
-}
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 :: forall a. Schedule GlossM (GlossEventClock a) GlossSimulationClock
glossSchedule = 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 :: forall a. (Event -> Maybe a) -> GlossEventClock a
glossEventSelectClock Event -> Maybe a
selector =
  SelectClock
    { mainClock :: GlossClock
mainClock = GlossClock
GlossClock
    , select :: Tag GlossClock -> Maybe a
select = (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 = forall a. (Event -> Maybe a) -> GlossEventClock a
glossEventSelectClock 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 {GlossClock
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) = forall a. Maybe a
Nothing
    select Maybe a
Nothing = 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 ::
  -- | The event selector
  (Event -> Maybe a) ->
  -- | The 'ClSF' representing the game loop.
  ClSF GlossM GlossSimulationClock [a] () ->
  GlossRhine a
buildGlossRhine :: forall a.
(Event -> Maybe a)
-> ClSF GlossM GlossSimulationClock [a] () -> GlossRhine a
buildGlossRhine Event -> Maybe a
selector ClSF GlossM GlossSimulationClock [a] ()
clsfSim =
  forall (m :: * -> *) cl b a.
Monad m =>
(TimeInfo cl -> b) -> ClSF m cl a b
timeInfoOf forall cl. TimeInfo cl -> Tag cl
tag forall cl (m :: * -> *) a b.
(cl ~ In cl, cl ~ Out cl) =>
ClSF m cl a b -> cl -> Rhine m cl a b
@@ forall a. (Event -> Maybe a) -> GlossEventClock a
glossEventSelectClock Event -> Maybe a
selector
    forall (m :: * -> *) cl1 a b cl2 c.
Rhine m cl1 a b
-> ResamplingPoint m cl1 cl2 b c
-> RhineAndResamplingPoint m cl1 cl2 a c
>-- forall (m :: * -> *) cl1 cl2 a.
Monad m =>
ResamplingBuffer m cl1 cl2 a [a]
collect forall (m :: * -> *) cl1 cl2 a b.
ResamplingBuffer m (Out cl1) (In cl2) a b
-> Schedule m cl1 cl2 -> ResamplingPoint m cl1 cl2 a b
-@- forall a. Schedule GlossM (GlossEventClock a) GlossSimulationClock
glossSchedule
    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 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 ->
  -- | The @gloss@-compatible 'Rhine'.
  GlossRhine a ->
  IO ()
flowGlossCombined :: forall a. 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) () ()
..} = forall {cl} {b}.
Clock GlossM cl =>
GlossSettings -> cl -> MSF GlossM (Time cl, Tag cl) b -> IO ()
flowGlossWithWorldMSF GlossSettings
settings GlossCombinedClock a
clock forall a b. (a -> b) -> a -> b
$ proc (Time (GlossCombinedClock a), Tag (GlossCombinedClock a))
tick -> do
  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 Float
0 SN GlossM (GlossCombinedClock a) () ()
sn
    -< case (Time (GlossCombinedClock a), Tag (GlossCombinedClock a))
tick of
      (Time (GlossCombinedClock a)
_, Left a
event) -> (Float
0, forall a b. a -> Either a b
Left a
event, forall a. a -> Maybe a
Just ())
      (Time (GlossCombinedClock a)
diffTime, Right ()) -> (Time (GlossCombinedClock a)
diffTime, forall a b. b -> Either a b
Right (), forall a. Maybe a
Nothing)