module FreeGame.Backend.GLFW (runGame) where
import Control.Monad.Free.Church
import Control.Monad.Trans.Iter
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.IORef
import Data.Reflection
import FreeGame.Class
import FreeGame.Data.Bitmap
import FreeGame.Internal.Finalizer
import FreeGame.UI
import FreeGame.Types
import Linear
import qualified Data.IntMap.Strict as IM
import qualified Data.Map.Strict as Map
import qualified FreeGame.Internal.GLFW as G
import qualified Graphics.UI.GLFW as GLFW
import qualified Graphics.Rendering.OpenGL.GL as GL
import Unsafe.Coerce
keyCallback :: IORef (Map.Map Key Bool) -> GLFW.Window -> GLFW.Key -> Int -> GLFW.KeyState -> GLFW.ModifierKeys -> IO ()
keyCallback keyBuffer _ key _ GLFW.KeyState'Pressed _ = modifyIORef' keyBuffer $ Map.insert (toEnum $ fromEnum key) True
keyCallback _ _ _ _ _ _ = return ()
mouseButtonCallback :: IORef (Map.Map Int Bool) -> GLFW.Window -> GLFW.MouseButton -> GLFW.MouseButtonState -> GLFW.ModifierKeys -> IO ()
mouseButtonCallback mouseBuffer _ btn GLFW.MouseButtonState'Pressed _ = modifyIORef' mouseBuffer (Map.insert (fromEnum btn) True)
mouseButtonCallback _ _ _ _ _ = return ()
runGame :: WindowMode -> BoundingBox Double -> IterT (F UI) a -> IO (Maybe a)
runGame mode bbox m = G.withGLFW mode bbox (execGame m)
initialKeyBuffer :: Map.Map Key Bool
initialKeyBuffer = Map.fromList $ zip [minBound..] (repeat False)
initialMouseBuffer :: Map.Map Int Bool
initialMouseBuffer = Map.fromList $ zip [0..7] (repeat False)
execGame :: IterT (F UI) a -> G.System -> IO (Maybe a)
execGame m sys = do
texs <- newIORef IM.empty
keyBuffer <- newIORef initialKeyBuffer
mouseBuffer <- newIORef initialMouseBuffer
keyBuffer' <- newIORef initialKeyBuffer
mouseBuffer' <- newIORef initialMouseBuffer
GLFW.setKeyCallback (G.theWindow sys) $ Just $ keyCallback keyBuffer
GLFW.setMouseButtonCallback (G.theWindow sys) $ Just $ mouseButtonCallback mouseBuffer
execFinalizerT
$ give (RefKeyStates keyBuffer)
$ give (RefMouseButtonStates mouseBuffer)
$ give (Previous (RefKeyStates keyBuffer'))
$ give (Previous (RefMouseButtonStates mouseBuffer'))
$ give (TextureStorage texs)
$ give sys
$ gameLoop m
gameLoop ::
( Given G.System
, Given TextureStorage
, Given KeyStates
, Given MouseButtonStates
, Given (Previous KeyStates)
, Given (Previous MouseButtonStates)
) => IterT (F UI) a -> FinalizerT IO (Maybe a)
gameLoop m = do
liftIO $ G.beginFrame given
r <- iterM runUI $ runIterT m
b <- liftIO $ do
readIORef (getKeyStates given) >>= writeIORef (getKeyStates (getPrevious given))
readIORef (getMouseButtonStates given) >>= writeIORef (getMouseButtonStates (getPrevious given))
writeIORef (getKeyStates given) initialKeyBuffer
writeIORef (getMouseButtonStates given) initialMouseBuffer
G.endFrame given
if b
then return Nothing
else either (return . Just) gameLoop r
newtype TextureStorage = TextureStorage { getTextureStorage :: IORef (IM.IntMap G.Texture) }
type DrawM = ReaderT (Location ()) IO
newtype Previous a = Previous { getPrevious :: a }
newtype KeyStates = RefKeyStates { getKeyStates :: IORef (Map.Map Key Bool) }
newtype MouseButtonStates = RefMouseButtonStates { getMouseButtonStates :: IORef (Map.Map Int Bool) }
runUI :: forall a.
( Given G.System
, Given TextureStorage
, Given KeyStates
, Given MouseButtonStates
, Given (Previous KeyStates)
, Given (Previous MouseButtonStates)
) => UI (FinalizerT IO a) -> FinalizerT IO a
runUI (Draw m) = do
(cont, xs) <- liftIO $ do
cxt <- newIORef []
cont <- give (Context cxt) $ runReaderT (m :: DrawM (FinalizerT IO a)) (Location id id)
xs <- readIORef cxt
return (cont, xs)
unless (null xs) $ finalizer $ forM_ xs $ \(t, h) -> G.releaseTexture t >> modifyIORef' (getTextureStorage given) (IM.delete h)
cont
runUI (FromFinalizer m) = join m
runUI (PreloadBitmap bmp cont) = do
loadTexture given bmp
(\t h -> finalizer $ G.releaseTexture t >> modifyIORef' (getTextureStorage given) (IM.delete h))
(const $ return ())
(const $ return ())
cont
runUI (KeyStates cont) = do
let k = liftIO . readIORef . getKeyStates
s <- k given
t <- k (getPrevious given)
cont s t
runUI (MouseButtons cont) = do
let k = liftIO . readIORef . getMouseButtonStates
s <- k given
t <- k (getPrevious given)
cont s t
runUI (MousePosition cont) = do
(x, y) <- liftIO $ GLFW.getCursorPos (G.theWindow given)
cont $ V2 x y
runUI (Bracket m) = join $ iterM runUI m
runUI (TakeScreenshot cont) = liftIO (G.screenshot given >>= makeStableBitmap) >>= cont
runUI (ClearColor col cont) = do
liftIO $ GL.clearColor GL.$= unsafeCoerce col
cont
runUI (SetTitle str cont) = do
liftIO $ GLFW.setWindowTitle (G.theWindow given) str
cont
runUI (ShowCursor cont) = do
liftIO $ GLFW.setCursorInputMode (G.theWindow given) GLFW.CursorInputMode'Normal
cont
runUI (HideCursor cont) = do
liftIO $ GLFW.setCursorInputMode (G.theWindow given) GLFW.CursorInputMode'Hidden
cont
runUI (SetFPS n cont) = do
liftIO $ writeIORef (G.theFPS given) n
cont
runUI (GetFPS cont) = liftIO (readIORef (G.currentFPS given)) >>= cont
mapReaderWith :: (s -> r) -> (m a -> n b) -> ReaderT r m a -> ReaderT s n b
mapReaderWith f g m = unsafeCoerce $ \s -> g (unsafeCoerce m (f s))
instance Affine DrawM where
translate v = mapReaderWith (translate v) (G.translate v)
rotateD t = mapReaderWith (rotateD t) (G.rotateD t)
rotateR t = let t' = t / pi * 180 in mapReaderWith (rotateR t) (G.rotateD t')
scale v = mapReaderWith (scale v) (G.scale v)
loadTexture :: MonadIO m => TextureStorage -> Bitmap
-> (G.Texture -> Int -> m ())
-> (G.Texture -> m ())
-> (G.Texture -> m ())
-> m ()
loadTexture (TextureStorage st) (BitmapData img (Just h)) hook cont _ = do
m <- liftIO $ readIORef st
case IM.lookup h m of
Just t -> cont t
Nothing -> do
t <- liftIO $ G.installTexture img
liftIO $ writeIORef st $ IM.insert h t m
hook t h
cont t
loadTexture _ (BitmapData img Nothing) _ cont fin = do
t <- liftIO $ G.installTexture img
cont t
fin t
newtype Context = Context { getContext :: IORef [(G.Texture, Int)] }
instance (Given Context, Given TextureStorage) => Picture2D DrawM where
bitmap bmp = liftIO $ loadTexture given bmp
(\t h -> modifyIORef (getContext given) ((t, h) :))
G.drawTexture
G.releaseTexture
circle r = liftIO (G.circle r)
circleOutline r = liftIO (G.circleOutline r)
polygon vs = liftIO (G.polygon vs)
polygonOutline vs = liftIO (G.polygonOutline vs)
line vs = liftIO (G.line vs)
thickness t = mapReaderWith id (G.thickness t)
color c = mapReaderWith id (G.color c)
instance Local DrawM where
getLocation = asks coerceLocation