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

module LiveCoding.Gloss (
  module X,
  module LiveCoding.Gloss,
) where

-- base
import Control.Concurrent
import Control.Monad (when)
import Data.IORef
import System.Exit (exitSuccess)

-- transformers
import Control.Arrow (returnA)
import Control.Monad.Trans.State.Strict (StateT)
import Control.Monad.Trans.Writer

-- gloss
import Graphics.Gloss as X
import Graphics.Gloss.Interface.IO.Game as X

-- essence-of-live-coding
import LiveCoding

-- essence-of-live-coding-gloss
import LiveCoding.Gloss.Debugger as X
import LiveCoding.Gloss.PictureM as X

{- | In a 'Handle', store a separate thread where the gloss main loop is executed,
   and several concurrent variables to communicate with it.
-}
data GlossHandle = GlossHandle
  { GlossHandle -> ThreadId
glossThread :: ThreadId
  , GlossHandle -> GlossVars
glossVars :: GlossVars
  }

-- | The concurrent variables needed to communicate with the gloss thread.
data GlossVars = GlossVars
  { GlossVars -> IORef [Event]
glossEventsRef :: IORef [Event]
  -- ^ Stores all 'Event's that arrived since the last tick
  , GlossVars -> IORef Picture
glossPicRef :: IORef Picture
  -- ^ Stores the next 'Picture' to be painted
  , GlossVars -> MVar Float
glossDTimeVar :: MVar Float
  -- ^ Stores the time passed since the last tick
  , GlossVars -> IORef Bool
glossExitRef :: IORef Bool
  -- ^ Write 'True' here to stop the gloss thread
  }

{- | Collect all settings that the @gloss@ backend requires.
   Taken from @rhine-gloss@.
-}
data GlossSettings = GlossSettings
  { GlossSettings -> Display
displaySetting :: Display
  -- ^ Display mode (e.g. 'InWindow' or 'FullScreen').
  , GlossSettings -> Color
backgroundColor :: Color
  -- ^ Background color.
  , GlossSettings -> Int
stepsPerSecond :: Int
  -- ^ Number of simulation steps per second of real time.
  , GlossSettings -> Bool
debugEvents :: Bool
  -- ^ Print all incoming events to the console.
  }

defaultSettings :: GlossSettings
defaultSettings :: GlossSettings
defaultSettings =
  GlossSettings
    { displaySetting :: Display
displaySetting = String -> (Int, Int) -> (Int, Int) -> Display
InWindow String
"Essence of live coding" (Int
600, Int
800) (Int
20, Int
20)
    , backgroundColor :: Color
backgroundColor = Color
black
    , stepsPerSecond :: Int
stepsPerSecond = Int
30
    , debugEvents :: Bool
debugEvents = Bool
False
    }

{- | Will create a handle for communication with the gloss thread,
   and start gloss.
-}
glossHandle :: GlossSettings -> Handle IO GlossHandle
glossHandle :: GlossSettings -> Handle IO GlossHandle
glossHandle GlossSettings {Bool
Int
Display
Color
debugEvents :: Bool
stepsPerSecond :: Int
backgroundColor :: Color
displaySetting :: Display
debugEvents :: GlossSettings -> Bool
stepsPerSecond :: GlossSettings -> Int
backgroundColor :: GlossSettings -> Color
displaySetting :: GlossSettings -> Display
..} =
  Handle
    { create :: IO GlossHandle
create = do
        IORef [Event]
glossEventsRef <- forall a. a -> IO (IORef a)
newIORef []
        MVar Float
glossDTimeVar <- forall a. IO (MVar a)
newEmptyMVar
        IORef Picture
glossPicRef <- forall a. a -> IO (IORef a)
newIORef Picture
blank
        IORef Bool
glossExitRef <- forall a. a -> IO (IORef a)
newIORef Bool
False
        let glossVars :: GlossVars
glossVars = GlossVars {IORef Bool
IORef [Event]
IORef Picture
MVar Float
glossExitRef :: IORef Bool
glossPicRef :: IORef Picture
glossDTimeVar :: MVar Float
glossEventsRef :: IORef [Event]
glossExitRef :: IORef Bool
glossDTimeVar :: MVar Float
glossPicRef :: IORef Picture
glossEventsRef :: IORef [Event]
..}
        ThreadId
glossThread <-
          IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$
            forall world.
Display
-> Color
-> Int
-> world
-> (world -> IO Picture)
-> (Event -> world -> IO world)
-> (Float -> world -> IO world)
-> IO ()
playIO Display
displaySetting Color
backgroundColor Int
stepsPerSecond GlossVars
glossVars GlossVars -> IO Picture
getPicture (Bool -> Event -> GlossVars -> IO GlossVars
handleEvent Bool
debugEvents) Float -> GlossVars -> IO GlossVars
stepGloss
        forall (m :: * -> *) a. Monad m => a -> m a
return GlossHandle {ThreadId
GlossVars
glossThread :: ThreadId
glossVars :: GlossVars
glossVars :: GlossVars
glossThread :: ThreadId
..}
    , destroy :: GlossHandle -> IO ()
destroy = \GlossHandle {glossVars :: GlossHandle -> GlossVars
glossVars = GlossVars {IORef Bool
IORef [Event]
IORef Picture
MVar Float
glossExitRef :: IORef Bool
glossDTimeVar :: MVar Float
glossPicRef :: IORef Picture
glossEventsRef :: IORef [Event]
glossExitRef :: GlossVars -> IORef Bool
glossDTimeVar :: GlossVars -> MVar Float
glossPicRef :: GlossVars -> IORef Picture
glossEventsRef :: GlossVars -> IORef [Event]
..}, ThreadId
glossThread :: ThreadId
glossThread :: GlossHandle -> ThreadId
..} -> forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
glossExitRef Bool
True
    }

getPicture :: GlossVars -> IO Picture
getPicture :: GlossVars -> IO Picture
getPicture GlossVars {IORef Bool
IORef [Event]
IORef Picture
MVar Float
glossExitRef :: IORef Bool
glossDTimeVar :: MVar Float
glossPicRef :: IORef Picture
glossEventsRef :: IORef [Event]
glossExitRef :: GlossVars -> IORef Bool
glossDTimeVar :: GlossVars -> MVar Float
glossPicRef :: GlossVars -> IORef Picture
glossEventsRef :: GlossVars -> IORef [Event]
..} = forall a. IORef a -> IO a
readIORef IORef Picture
glossPicRef

handleEvent :: Bool -> Event -> GlossVars -> IO GlossVars
handleEvent :: Bool -> Event -> GlossVars -> IO GlossVars
handleEvent Bool
debugEvents Event
event vars :: GlossVars
vars@GlossVars {IORef Bool
IORef [Event]
IORef Picture
MVar Float
glossExitRef :: IORef Bool
glossDTimeVar :: MVar Float
glossPicRef :: IORef Picture
glossEventsRef :: IORef [Event]
glossExitRef :: GlossVars -> IORef Bool
glossDTimeVar :: GlossVars -> MVar Float
glossPicRef :: GlossVars -> IORef Picture
glossEventsRef :: GlossVars -> IORef [Event]
..} = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugEvents forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> IO ()
print Event
event
  forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [Event]
glossEventsRef (Event
event forall a. a -> [a] -> [a]
:)
  forall (m :: * -> *) a. Monad m => a -> m a
return GlossVars
vars

stepGloss :: Float -> GlossVars -> IO GlossVars
stepGloss :: Float -> GlossVars -> IO GlossVars
stepGloss Float
dTime vars :: GlossVars
vars@GlossVars {IORef Bool
IORef [Event]
IORef Picture
MVar Float
glossExitRef :: IORef Bool
glossDTimeVar :: MVar Float
glossPicRef :: IORef Picture
glossEventsRef :: IORef [Event]
glossExitRef :: GlossVars -> IORef Bool
glossDTimeVar :: GlossVars -> MVar Float
glossPicRef :: GlossVars -> IORef Picture
glossEventsRef :: GlossVars -> IORef [Event]
..} = do
  forall a. MVar a -> a -> IO ()
putMVar MVar Float
glossDTimeVar Float
dTime
  Bool
exitNow <- forall a. IORef a -> IO a
readIORef IORef Bool
glossExitRef
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exitNow forall a. IO a
exitSuccess
  forall (m :: * -> *) a. Monad m => a -> m a
return GlossVars
vars

{- | Given a cell in the gloss monad 'PictureM',
start the gloss backend and connect the cell to it.

This introduces 'Handle's containing the gloss background thread,
which need to be taken care of by calling 'runHandlingState'
or a similar function.

The resulting cell never blocks,
but returns 'Nothing' if there currently is no gloss tick.
-}
glossWrapC ::
  GlossSettings ->
  Cell PictureM a b ->
  Cell (HandlingStateT IO) a (Maybe b)
glossWrapC :: forall a b.
GlossSettings
-> Cell PictureM a b -> Cell (HandlingStateT IO) a (Maybe b)
glossWrapC GlossSettings
glossSettings Cell PictureM a b
cell = proc a
a -> do
  GlossHandle {ThreadId
GlossVars
glossVars :: GlossVars
glossThread :: ThreadId
glossVars :: GlossHandle -> GlossVars
glossThread :: GlossHandle -> ThreadId
..} <- forall h (m :: * -> *) arbitrary.
(Typeable h, Monad m) =>
Handle m h -> Cell (HandlingStateT m) arbitrary h
handling forall a b. (a -> b) -> a -> b
$ GlossSettings -> Handle IO GlossHandle
glossHandle GlossSettings
glossSettings -< ()
  forall (m :: * -> *) (t :: (* -> *) -> * -> *) a b.
(Monad m, MonadTrans t) =>
Cell m a b -> Cell (t m) a b
liftCell Cell IO (GlossVars, a) (Maybe b)
pump -< (GlossVars
glossVars, a
a)
  where
    pump :: Cell IO (GlossVars, a) (Maybe b)
pump = proc (GlossVars {IORef Bool
IORef [Event]
IORef Picture
MVar Float
glossExitRef :: IORef Bool
glossDTimeVar :: MVar Float
glossPicRef :: IORef Picture
glossEventsRef :: IORef [Event]
glossExitRef :: GlossVars -> IORef Bool
glossDTimeVar :: GlossVars -> MVar Float
glossPicRef :: GlossVars -> IORef Picture
glossEventsRef :: GlossVars -> IORef [Event]
..}, a
a) -> do
      Maybe Float
timeMaybe <- forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM forall a. MVar a -> IO (Maybe a)
tryTakeMVar -< MVar Float
glossDTimeVar
      case Maybe Float
timeMaybe of
        Just Float
_ -> do
          [Event]
events <- forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef ([],) -< IORef [Event]
glossEventsRef
          (Picture
picture, b
b) <- forall (m :: * -> *) a b.
Monad m =>
Cell (PictureT m) a b -> Cell m ([Event], a) (Picture, b)
runPictureT Cell PictureM a b
cell -< ([Event]
events, a
a)
          forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. IORef a -> a -> IO ()
writeIORef) -< (IORef Picture
glossPicRef, Picture
picture)
          forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall a. a -> Maybe a
Just b
b
        Maybe Float
Nothing -> do
          forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM Int -> IO ()
threadDelay -< Int
1000 -- Prevent too much CPU load
          forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall a. Maybe a
Nothing