GLFW.hs

{-# LANGUAGE Rank2Types, BangPatterns, ViewPatterns, CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  FreeGame.Backend.GLFW
-- Copyright   :  (C) 2013 Fumiaki Kinoshita
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
----------------------------------------------------------------------------
module FreeGame.Backend.GLFW (Game(..), Frame, runGame) where
import Control.Lens (view)
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Trans.Iter
import Control.Monad.Trans.Resource
import Data.BoundingBox
import Data.Functor.Identity
import Data.IORef
import FreeGame.Class
import FreeGame.Data.Bitmap
import FreeGame.Instances ()
import FreeGame.Types
import FreeGame.UI
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.Rendering.OpenGL.GL as GL
import qualified Graphics.UI.GLFW as GLFW

keyCallback :: IORef (Map.Map Key ButtonState) -> GLFW.Window -> GLFW.Key -> Int -> GLFW.KeyState -> GLFW.ModifierKeys -> IO ()
keyCallback keyBuffer _ key _ GLFW.KeyState'Pressed _ = modifyIORef' keyBuffer $ Map.adjust buttonDown (toEnum $ fromEnum key)
keyCallback keyBuffer _ key _ GLFW.KeyState'Released _ = modifyIORef' keyBuffer $ Map.adjust buttonUp (toEnum $ fromEnum key)
keyCallback _ _ _ _ _ _ = return ()

mouseButtonCallback :: IORef (Map.Map Int ButtonState) -> GLFW.Window -> GLFW.MouseButton -> GLFW.MouseButtonState -> GLFW.ModifierKeys -> IO ()
mouseButtonCallback mouseBuffer _ btn GLFW.MouseButtonState'Pressed _ = modifyIORef' mouseBuffer $ Map.adjust buttonDown (fromEnum btn)
mouseButtonCallback mouseBuffer _ btn GLFW.MouseButtonState'Released _ = modifyIORef' mouseBuffer $ Map.adjust buttonUp (fromEnum btn)

mouseEnterCallback :: IORef Bool -> GLFW.Window -> GLFW.CursorState -> IO ()
mouseEnterCallback ref _ GLFW.CursorState'InWindow = writeIORef ref True
mouseEnterCallback ref _ GLFW.CursorState'NotInWindow = writeIORef ref False

runGame :: WindowMode -> BoundingBox2 -> Game a -> IO (Maybe a)
runGame mode bbox m = G.withGLFW mode bbox (execGame m)

initialKeyBuffer :: Map.Map Key ButtonState
initialKeyBuffer = Map.fromList $ zip [minBound..] (repeat Release)

initialMouseBuffer :: Map.Map Int ButtonState
initialMouseBuffer = Map.fromList $ zip [0..7] (repeat Release)

execGame :: Game a -> G.System -> IO (Maybe a)
execGame m system = do
    textureStorage <- newIORef IM.empty
    keyBuffer <- newIORef initialKeyBuffer
    mouseBuffer <- newIORef initialMouseBuffer
    mouseIn <- newIORef True
    scroll <- newIORef (V2 0 0)
    GLFW.setKeyCallback (G.theWindow system) $ Just $ keyCallback keyBuffer
    GLFW.setMouseButtonCallback (G.theWindow system) $ Just $ mouseButtonCallback mouseBuffer
    GLFW.setCursorEnterCallback (G.theWindow system) $ Just $ mouseEnterCallback mouseIn
    GLFW.setScrollCallback (G.theWindow system) $ Just $ \_ x y -> modifyIORef scroll (+V2 x y)
    let drawLocation = Location id id
    runResourceT $ gameLoop Env{..} m

data Env = Env
    { system :: G.System
    , textureStorage :: IORef (IM.IntMap G.Texture)
    , keyBuffer :: IORef (Map.Map Key ButtonState)
    , mouseBuffer :: IORef (Map.Map Int ButtonState)
    , mouseIn :: IORef Bool
    , scroll :: IORef (V2 Double)
    , drawLocation :: Location ()
    }

newtype Game a = Game { unGame :: IterT Frame a }
    deriving (Functor, Applicative, Monad, MonadIO, Affine, Picture2D, Mouse, Keyboard, FreeGame, Local, MonadFree Identity)

instance MonadResource Game where
    liftResourceT = Game . lift . liftResourceT

newtype Frame a = Frame { unFrame :: ReaderT Env (ResourceT IO) a }
    deriving (Functor, Applicative, Monad, MonadResource, MonadIO, MonadReader Env)

gameLoop :: Env -> Game a -> ResourceT IO (Maybe a)
gameLoop env@Env{..} (Game m0) = flip fix m0 $ \self m -> do
    liftIO $ G.beginFrame system

    r <- runReaderT (unFrame (runIterT m)) env

    b <- liftIO $ do
        modifyIORef' keyBuffer (Map.map buttonStay)
        modifyIORef' mouseBuffer (Map.map buttonStay)
        writeIORef scroll (V2 0 0 :: V2 Double)
        G.endFrame system

    if b
        then return Nothing
        else either (return . Just) self r

withLocation :: (Location () -> Location ()) -> Env -> Env
withLocation f de = de { drawLocation = f $ drawLocation de }

instance FreeGame Frame where
    preloadBitmap (Bitmap bmp h) = Frame $ ReaderT $ \Env{..} -> do
        m <- liftIO $ readIORef textureStorage
        case IM.lookup h m of
            Just _ -> return ()
            Nothing -> do
                t <- liftIO $ G.installTexture bmp
                liftIO $ writeIORef textureStorage $ IM.insert h t m
                void $ register $ G.releaseTexture t >> modifyIORef' textureStorage (IM.delete h)

    takeScreenshot = Frame $ ReaderT $ \Env{..} -> liftIO (G.screenshot system >>= liftBitmapIO)
    clearColor (V4 r g b a) = liftIO $ GL.clearColor GL.$= GL.Color4 r g b a
    setTitle str = Frame $ ReaderT $ \Env{..} -> liftIO $ GLFW.setWindowTitle (G.theWindow system) str
    showCursor = Frame $ ReaderT $ \Env{..} -> liftIO $ GLFW.setCursorInputMode (G.theWindow system) GLFW.CursorInputMode'Normal
    hideCursor = Frame $ ReaderT $ \Env{..} -> liftIO $ GLFW.setCursorInputMode (G.theWindow system) GLFW.CursorInputMode'Hidden
    setFPS n = Frame $ ReaderT $ \Env{..} -> liftIO $ writeIORef (G.theFPS system) n
    getFPS = Frame $ ReaderT $ \Env{..} -> liftIO (readIORef (G.currentFPS system))
    getBoundingBox = Frame $ ReaderT $ \Env{..} -> liftIO (readIORef (G.refRegion system))
    setBoundingBox bbox@(view (size zero)-> V2 w h) = Frame $ ReaderT $ \Env{..} -> do
        liftIO $ GLFW.setWindowSize (G.theWindow system) (floor w) (floor h)
        liftIO $ writeIORef (G.refRegion system) bbox

instance Keyboard Frame where
    keyStates_ = Frame $ ReaderT $ \Env{..} -> liftIO (readIORef keyBuffer)

instance Mouse Frame where
    mouseButtons_ = Frame $ ReaderT $ \Env{..} -> liftIO (readIORef mouseBuffer)
    globalMousePosition = Frame $ ReaderT $ \Env{..} -> do
        (x, y) <- liftIO $ GLFW.getCursorPos (G.theWindow system)
        pure $ V2 x y
    mouseScroll = Frame $ ReaderT $ \Env{..} -> liftIO (readIORef scroll)
    mouseInWindow = Frame $ ReaderT $ \Env{..} -> liftIO (readIORef mouseIn)

mapReaderWith :: (Env -> Env) -> (IO a -> IO a) -> Frame a -> Frame a
mapReaderWith f g m = Frame $ ReaderT $ \s -> transResourceT g (runReaderT (unFrame m) (f s))
{-# INLINE mapReaderWith #-}

instance Affine Frame where
    translate v = mapReaderWith (withLocation $ translate v) (G.translate v)
    {-# INLINE translate #-}
    rotateD t = mapReaderWith (withLocation $ rotateD t) (G.rotateD t)
    {-# INLINE rotateD #-}
    rotateR t = let t' = t / pi * 180 in mapReaderWith (withLocation $ rotateR t) (G.rotateD t')
    {-# INLINE rotateR #-}
    scale v = mapReaderWith (withLocation $ scale v) (G.scale v)
    {-# INLINE scale #-}

instance Picture2D Frame where
    bitmap (Bitmap bmp h) = Frame $ ReaderT $ \Env{..} -> do
        m <- liftIO $ readIORef textureStorage
        case IM.lookup h m of
            Just t -> liftIO $ G.drawTexture t
            Nothing -> do
                t <- liftIO $ G.installTexture bmp
                liftIO $ writeIORef textureStorage $ IM.insert h t m
                _ <- register $ modifyIORef' textureStorage $ IM.delete h
                liftIO $ G.drawTexture t
    bitmapOnce (Bitmap bmp _) = liftIO $ do
        t <- G.installTexture bmp
        G.drawTexture t
        G.releaseTexture t

    circle r = liftIO (G.circle r)
    {-# INLINE circle #-}
    circleOutline r = liftIO (G.circleOutline r)
    {-# INLINE circleOutline #-}
    polygon vs = liftIO (G.polygon vs)
    {-# INLINE polygon #-}
    polygonOutline vs = liftIO (G.polygonOutline vs)
    {-# INLINE polygonOutline #-}
    line vs = liftIO (G.line vs)
    {-# INLINE line #-}
    thickness t = mapReaderWith id (G.thickness t)
    {-# INLINE thickness #-}
    color c = mapReaderWith id (G.color c)
    {-# INLINE color #-}
    blendMode m = mapReaderWith id (G.blendMode m)
    {-# INLINE blendMode #-}

instance Local Frame where
    getLocation = asks $ coerceLocation . drawLocation