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

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.Writer
import Control.Monad.Trans.State.Strict (StateT)

-- 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 :: Display -> Color -> Int -> Bool -> GlossSettings
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 :: forall (m :: * -> *) h. m h -> (h -> m ()) -> Handle m h
Handle
  { create :: IO GlossHandle
create = do
      IORef [Event]
glossEventsRef <- [Event] -> IO (IORef [Event])
forall a. a -> IO (IORef a)
newIORef []
      MVar Float
glossDTimeVar <- IO (MVar Float)
forall a. IO (MVar a)
newEmptyMVar
      IORef Picture
glossPicRef <- Picture -> IO (IORef Picture)
forall a. a -> IO (IORef a)
newIORef Picture
blank
      IORef Bool
glossExitRef <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
      let glossVars :: GlossVars
glossVars = GlossVars :: IORef [Event]
-> IORef Picture -> MVar Float -> IORef Bool -> 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
        (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Display
-> Color
-> Int
-> GlossVars
-> (GlossVars -> IO Picture)
-> (Event -> GlossVars -> IO GlossVars)
-> (Float -> GlossVars -> IO GlossVars)
-> IO ()
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
      GlossHandle -> IO GlossHandle
forall (m :: * -> *) a. Monad m => a -> m a
return GlossHandle :: ThreadId -> GlossVars -> GlossHandle
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
.. } -> IORef Bool -> Bool -> IO ()
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]
.. } = IORef Picture -> IO Picture
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
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugEvents (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Event -> IO ()
forall a. Show a => a -> IO ()
print Event
event
  IORef [Event] -> ([Event] -> [Event]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [Event]
glossEventsRef (Event
event Event -> [Event] -> [Event]
forall a. a -> [a] -> [a]
:)
  GlossVars -> IO GlossVars
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
  MVar Float -> Float -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Float
glossDTimeVar Float
dTime
  Bool
exitNow <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
glossExitRef
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exitNow IO ()
forall a. IO a
exitSuccess
  GlossVars -> IO GlossVars
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 :: 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
.. } <- Handle IO GlossHandle -> Cell (HandlingStateT IO) () GlossHandle
forall h (m :: * -> *) arbitrary.
(Typeable h, Monad m) =>
Handle m h -> Cell (HandlingStateT m) arbitrary h
handling (Handle IO GlossHandle -> Cell (HandlingStateT IO) () GlossHandle)
-> Handle IO GlossHandle -> Cell (HandlingStateT IO) () GlossHandle
forall a b. (a -> b) -> a -> b
$ GlossSettings -> Handle IO GlossHandle
glossHandle GlossSettings
glossSettings -< ()
  Cell IO (GlossVars, a) (Maybe b)
-> Cell (HandlingStateT IO) (GlossVars, a) (Maybe b)
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 <- (MVar Float -> IO (Maybe Float))
-> Cell IO (MVar Float) (Maybe Float)
forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM MVar Float -> IO (Maybe Float)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar                        -< MVar Float
glossDTimeVar
      case Maybe Float
timeMaybe of
        Just Float
_ -> do
          [Event]
events <- (IORef [Event] -> IO [Event]) -> Cell IO (IORef [Event]) [Event]
forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM ((IORef [Event] -> IO [Event]) -> Cell IO (IORef [Event]) [Event])
-> (IORef [Event] -> IO [Event]) -> Cell IO (IORef [Event]) [Event]
forall a b. (a -> b) -> a -> b
$ (IORef [Event] -> ([Event] -> ([Event], [Event])) -> IO [Event])
-> ([Event] -> ([Event], [Event])) -> IORef [Event] -> IO [Event]
forall a b c. (a -> b -> c) -> b -> a -> c
flip IORef [Event] -> ([Event] -> ([Event], [Event])) -> IO [Event]
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef ([], ) -< IORef [Event]
glossEventsRef
          (Picture
picture, b
b) <- Cell PictureM a b -> Cell IO ([Event], a) (Picture, 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)
          ((IORef Picture, Picture) -> IO ())
-> Cell IO (IORef Picture, Picture) ()
forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM ((IORef Picture -> Picture -> IO ())
-> (IORef Picture, Picture) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry IORef Picture -> Picture -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef)                      -< (IORef Picture
glossPicRef, Picture
picture)
          Cell IO (Maybe b) (Maybe b)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA                                        -< b -> Maybe b
forall a. a -> Maybe a
Just b
b
        Maybe Float
Nothing -> do
          (Int -> IO ()) -> Cell IO Int ()
forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM Int -> IO ()
threadDelay       -< Int
1000 -- Prevent too much CPU load
          Cell IO (Maybe b) (Maybe b)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA                -< Maybe b
forall a. Maybe a
Nothing