From c4065b4b1b39fe1eafd67f2b188c87261b58ac06 Mon Sep 17 00:00:00 2001
From: Kiana Sheibani <kiana.a.sheibani@gmail.com>
Date: Tue, 24 Jan 2023 13:23:15 -0500
Subject: [PATCH] Write gloss-dunai compatibility layer

---
 Main.hs      |  4 ----
 src/Main.hs  | 14 ++++++++++++++
 src/Utils.hs | 42 ++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 56 insertions(+), 4 deletions(-)
 delete mode 100644 Main.hs
 create mode 100644 src/Main.hs
 create mode 100644 src/Utils.hs

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