{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Arrows #-}
module LiveCoding.Gloss
( module X
, module LiveCoding.Gloss
) where
import Control.Concurrent
import Control.Monad (when)
import Data.IORef
import System.Exit (exitSuccess)
import Control.Arrow (returnA)
import Control.Monad.Trans.Writer
import Control.Monad.Trans.State.Strict (StateT)
import Graphics.Gloss as X
import Graphics.Gloss.Interface.IO.Game as X
import LiveCoding
import LiveCoding.Gloss.Debugger as X
import LiveCoding.Gloss.PictureM as X
data GlossHandle = GlossHandle
{ glossThread :: ThreadId
, glossVars :: GlossVars
}
data GlossVars = GlossVars
{ glossEventsRef :: IORef [Event]
, glossPicRef :: IORef Picture
, glossDTimeVar :: MVar Float
, glossExitRef :: IORef Bool
}
data GlossSettings = GlossSettings
{ displaySetting :: Display
, backgroundColor :: Color
, stepsPerSecond :: Int
}
defaultSettings :: GlossSettings
defaultSettings = GlossSettings
{ displaySetting = InWindow "Essence of live coding" (600, 800) (20, 20)
, backgroundColor = black
, stepsPerSecond = 30
}
glossHandle :: GlossSettings -> Handle IO GlossHandle
glossHandle GlossSettings { .. } = Handle
{ create = do
glossEventsRef <- newIORef []
glossDTimeVar <- newEmptyMVar
glossPicRef <- newIORef blank
glossExitRef <- newIORef False
let glossVars = GlossVars { .. }
glossThread <- forkIO
$ playIO displaySetting backgroundColor stepsPerSecond glossVars getPicture handleEvent stepGloss
return GlossHandle { .. }
, destroy = \GlossHandle { glossVars = GlossVars { .. }, .. } -> writeIORef glossExitRef True
}
getPicture :: GlossVars -> IO Picture
getPicture GlossVars { .. } = readIORef glossPicRef
handleEvent :: Event -> GlossVars -> IO GlossVars
handleEvent event vars@GlossVars { .. } = do
modifyIORef glossEventsRef (event :)
return vars
stepGloss :: Float -> GlossVars -> IO GlossVars
stepGloss dTime vars@GlossVars { .. } = do
threadDelay $ round $ dTime * 1000
putMVar glossDTimeVar dTime
exitNow <- readIORef glossExitRef
when exitNow exitSuccess
return vars
glossWrapC :: GlossSettings -> Cell PictureM a b -> Cell (StateT (HandlingState IO) IO) a b
glossWrapC glossSettings cell = proc a -> do
GlossHandle { .. } <- handling $ glossHandle glossSettings -< ()
liftCell pump -< (glossVars, a)
where
pump = proc (GlossVars { .. }, a) -> do
_ <- arrM takeMVar -< glossDTimeVar
events <- arrM $ flip atomicModifyIORef ([], ) -< glossEventsRef
(picture, b) <- runPictureT cell -< (events, a)
arrM (uncurry writeIORef) -< (glossPicRef, picture)
arrM threadDelay -< 10000
returnA -< b