{-# LANGUAGE Arrows #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
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.State.Strict (StateT)
import Control.Monad.Trans.Writer
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
{ GlossHandle -> ThreadId
glossThread :: ThreadId
, GlossHandle -> GlossVars
glossVars :: GlossVars
}
data GlossVars = GlossVars
{ GlossVars -> IORef [Event]
glossEventsRef :: IORef [Event]
, GlossVars -> IORef Picture
glossPicRef :: IORef Picture
, GlossVars -> MVar Float
glossDTimeVar :: MVar Float
, GlossVars -> IORef Bool
glossExitRef :: IORef Bool
}
data GlossSettings = GlossSettings
{ GlossSettings -> Display
displaySetting :: Display
, GlossSettings -> Color
backgroundColor :: Color
, GlossSettings -> Int
stepsPerSecond :: Int
, GlossSettings -> Bool
debugEvents :: Bool
}
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
}
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
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
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall a. Maybe a
Nothing