diff --git a/Main.hs b/Main.hs deleted file mode 100644 index c2e4af9..0000000 --- a/Main.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - -main :: IO () -main = undefined diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..329631c --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Arrows #-} + +module Main where + +import Data.MonadicStreamFunction +import Graphics.Gloss +import Utils + +mainSF :: MSF Drawer () () +mainSF = proc () -> do + draw -< color white $ circleSolid 40 + +main :: IO () +main = playMSF FullScreen black 60 (runDrawerS mainSF) diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 index 0000000..5edac2e --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,42 @@ +module Utils where + +import Control.Monad.Trans.MSF.Reader +import Control.Monad.Trans.MSF.Writer +import Data.IORef +import Data.MonadicStreamFunction +import Data.MonadicStreamFunction.ReactHandle +import Graphics.Gloss +import Graphics.Gloss.Interface.IO.Game + +-- | Display an MSF outputting a picture value as a window using Gloss. +-- Note that the MSF is not passed a real-time clock. +playMSF :: Display -> Color -> Int -> MSF IO (Maybe Event) Picture -> IO () +playMSF display color freq msf = do + -- `react` doesn't allow inputs or outputs, so we have to use IORefs + evRef <- newIORef Nothing + picRef <- newIORef blank + + handle <- reactInit (constM (readIORef evRef) >>> msf >>> arrM (writeIORef picRef)) + + let -- An action to convert the world to a picture. + toPic _ = readIORef picRef + + -- A function to handle input events. + handleInput e _ = do + writeIORef evRef (Just e) + react handle + + -- A function to step the world one iteration. + stepWorld _ _ = do + writeIORef evRef Nothing + react handle + + playIO display color freq () toPic handleInput stepWorld + +type Drawer = WriterT Picture (ReaderT (Maybe Event) IO) + +runDrawerS :: MSF Drawer () () -> MSF IO (Maybe Event) Picture +runDrawerS msf = arr (,()) >>> runReaderS (runWriterS msf) >>> arr fst + +draw :: MSF Drawer Picture () +draw = arrM tell