module Graphics.UI.FreeGame.GUI.GLFW (runGame) where
import Control.Applicative
import Control.Monad
import Control.Monad.Free.Church
import Control.Monad.IO.Class
import Data.IORef
import Data.Color
import Foreign.ForeignPtr
import Graphics.UI.FreeGame.Base
import Graphics.UI.FreeGame.Data.Bitmap
import Graphics.UI.FreeGame.Internal.Finalizer
import Graphics.UI.FreeGame.Internal.Raindrop
import Graphics.UI.FreeGame.GUI
import Graphics.UI.FreeGame.Types
import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility
import qualified Data.Array.Repa.Repr.ForeignPtr as RF
import qualified Graphics.UI.GLFW as GLFW
import Graphics.Rendering.OpenGL.GL.StateVar
import qualified Data.IntMap as IM
import qualified Graphics.Rendering.OpenGL.GL as GL
import System.Mem
import Unsafe.Coerce
import Control.Bool
import Linear
import Data.Reflection
runGame :: GUIParam -> F GUI a -> IO (Maybe a)
runGame param m = launch param $ runF m (return . Just) runAction
data System = System
{ refTextures :: IORef (IM.IntMap Texture)
, refFrame :: IORef Int
, refFPS :: IORef Int
, theParameter :: GUIParam
}
runAction :: Given System => GUI (FinalizerT IO (Maybe a)) -> FinalizerT IO (Maybe a)
runAction (LiftUI f) = join $ runUI id f
runAction (EmbedIO m) = join (liftIO m)
runAction (Bracket m) = liftIO $ runFinalizerT $ runF m (return.Just) runAction
>>= maybe (return Nothing) id
runAction Quit = return Nothing
runAction (Tick cont) = do
liftIO $ do
GL.matrixMode $= GL.Projection
GLFW.swapBuffers
t <- GLFW.getTime
n <- readIORef (refFrame given)
GLFW.sleep $ fromIntegral n / fromIntegral (_framePerSecond $ theParameter given) t
if t >= 1
then GLFW.resetTime >> writeIORef (refFrame given) 0 >> writeIORef (refFPS given) n
else writeIORef (refFrame given) (succ n)
r <- liftIO $ GLFW.windowIsOpen
if not r then return Nothing else do
liftIO $ do
GL.clear [GL.ColorBuffer]
GL.loadIdentity
let BoundingBox wl wt wr wb = fmap realToFrac $ _windowRegion $ theParameter given
GL.ortho wl wr wb wt 0 (100)
GL.matrixMode $= GL.Modelview 0
cont
runAction (GetFPS cont) = liftIO (readIORef (refFPS given)) >>= cont
type Texture = (GL.TextureObject, Int, Int)
launch :: GUIParam -> (Given System => FinalizerT IO (Maybe a)) -> IO (Maybe a)
launch param m = do
GLFW.initialize >>= bool (fail "Failed to initialize") (return ())
pf <- GLFW.openGLProfile
let V2 ww wh = fmap floor (view _BottomRight (_windowRegion param) view _TopLeft (_windowRegion param))
(>>=bool (fail "Failed to initialize") (return ())) $ GLFW.openWindow $ GLFW.defaultDisplayOptions {
GLFW.displayOptions_width = ww
,GLFW.displayOptions_height = wh
,GLFW.displayOptions_displayMode = if _windowed param then GLFW.Window else GLFW.Fullscreen
,GLFW.displayOptions_windowIsResizable = False
,GLFW.displayOptions_openGLProfile = pf
}
GLFW.setWindowTitle $ _windowTitle param
GL.lineSmooth $= GL.Enabled
GL.blend $= GL.Enabled
GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
GL.shadeModel $= GL.Flat
GL.textureFunction $= GL.Combine
let Color r g b a = _clearColor param in GL.clearColor $= GL.Color4 (gf r) (gf g) (gf b) (gf a)
sys <- System <$> newIORef IM.empty <*> newIORef 0 <*> newIORef 0 <*> pure param
res <- runFinalizerT $ give sys m
GLFW.closeWindow
GLFW.terminate
return res
installTexture :: Bitmap -> FinalizerT IO Texture
installTexture bmp@(BitmapData ar _) = do
[tex] <- liftIO $ GL.genObjectNames 1
liftIO $ GL.textureBinding GL.Texture2D GL.$= Just tex
let (width, height) = bitmapSize bmp
let siz = GL.TextureSize2D (gsizei width) (gsizei height)
liftIO $ withForeignPtr (RF.toForeignPtr ar)
$ GL.texImage2D GL.Texture2D GL.NoProxy 0 GL.RGBA8 siz 0
. GL.PixelData GL.RGBA GL.UnsignedInt8888
finalizer $ GL.deleteObjectNames [tex]
return (tex, width, height)
rot2 :: Floating a => a -> V2 a -> V2 a
rot2 a (V2 x y) = V2 (p * x + q * y) (q * x + p * y) where
d = a * (pi / 180)
p = cos d
q = sin d
runUI :: Given System => (V2 Float -> V2 Float) -> GUIBase a -> FinalizerT IO a
runUI _ (FromBitmap bmp@(BitmapData _ (Just h)) r) = do
m <- liftIO $ readIORef $ refTextures given
case IM.lookup h m of
Just t -> liftIO $ drawTexture t
Nothing -> do
t <- installTexture bmp
liftIO $ writeIORef (refTextures given) $ IM.insert h t m
liftIO $ drawTexture t
finalizer $ modifyIORef (refTextures given) $ IM.delete h
return r
runUI _ (FromBitmap bmp@(BitmapData _ Nothing) r) = do
liftIO $ runFinalizerT $ installTexture bmp >>= liftIO . drawTexture
return r
runUI f (Translate t@(V2 tx ty) inner) = preservingMatrix' $ do
liftIO $ GL.translate (GL.Vector3 (gf tx) (gf ty) 0)
runUI (subtract t . f) inner
runUI f (RotateD theta inner) = preservingMatrix' $ do
liftIO $ GL.rotate (gf (theta)) (GL.Vector3 0 0 1)
runUI (rot2 (theta) . f) inner
runUI f (Scale s@(V2 sx sy) inner) = preservingMatrix' $ do
liftIO $ GL.scale (gf sx) (gf sy) 1
runUI ((/s) . f) inner
runUI _ (FromFinalizer m) = m
runUI f (Colored col inner) = do
oldColor <- liftIO $ get GL.currentColor
liftIO $ GL.currentColor $= unsafeCoerce col
res <- runUI f inner
liftIO $ GL.currentColor $= oldColor
return res
runUI _ (Line path r) = do
liftIO $ GL.renderPrimitive GL.LineStrip $ runVertices path
return r
runUI _ (Polygon path r) = do
liftIO $ GL.renderPrimitive GL.Polygon $ runVertices path
return r
runUI _ (PolygonOutline path r) = do
liftIO $ GL.renderPrimitive GL.LineLoop $ runVertices path
return r
runUI _ (Circle r cont) = do
let s = 2 * pi / r
liftIO $ GL.renderPrimitive GL.Polygon $ runVertices [V2 (cos t * r) (sin t * r) | t <- [0,s..2 * pi]]
return cont
runUI _ (CircleOutline r cont) = do
let s = 2 * pi / r
liftIO $ GL.renderPrimitive GL.LineLoop $ runVertices [V2 (cos t * r) (sin t * r) | t <- [0,s..2 * pi]]
return cont
runUI f (Thickness t inner) = do
oldWidth <- liftIO $ get GL.lineWidth
liftIO $ GL.lineWidth $= gf t
res <- runUI f inner
liftIO $ GL.lineWidth $= oldWidth
return res
runUI _ (KeyChar ch cont) = cont <$> liftIO (GLFW.keyIsPressed (GLFW.CharKey ch))
runUI _ (KeySpecial x cont) = cont <$> liftIO (GLFW.keyIsPressed (mapSpecialKey x))
runUI _ (MouseButtonL cont) = cont <$> liftIO (GLFW.mouseButtonIsPressed GLFW.MouseButton0)
runUI _ (MouseButtonR cont) = cont <$> liftIO (GLFW.mouseButtonIsPressed GLFW.MouseButton1)
runUI _ (MouseButtonM cont) = cont <$> liftIO (GLFW.mouseButtonIsPressed GLFW.MouseButton2)
runUI f (MousePosition cont) = do
(x, y) <- liftIO GLFW.getMousePosition
let pos = f $ V2 (fromIntegral x) (fromIntegral y)
return $ cont pos
runUI _ (MouseWheel cont) = cont <$> liftIO GLFW.getMouseWheel
runVertices :: MonadIO m => [V2 Float] -> m ()
runVertices = liftIO . mapM_ (GL.vertex . mkVertex2)
preservingMatrix' :: MonadIO m => m a -> m a
preservingMatrix' m = do
liftIO $ glPushMatrix
r <- m
liftIO $ glPopMatrix
return r
drawTexture :: Texture -> IO ()
drawTexture (tex, width, height) = do
let (w, h) = (fromIntegral width / 2, fromIntegral height / 2) :: (GL.GLfloat, GL.GLfloat)
GL.texture GL.Texture2D $= GL.Enabled
GL.textureFilter GL.Texture2D $= ((GL.Nearest, Nothing), GL.Nearest)
GL.textureBinding GL.Texture2D $= Just tex
GL.renderPrimitive GL.Polygon $ do
GL.texCoord $ GL.TexCoord2 (0 :: GL.GLfloat) 0
GL.vertex $ GL.Vertex2 (w) (h)
GL.texCoord $ GL.TexCoord2 (1 :: GL.GLfloat) 0
GL.vertex $ GL.Vertex2 w (h)
GL.texCoord $ GL.TexCoord2 (1 :: GL.GLfloat) 1
GL.vertex $ GL.Vertex2 w h
GL.texCoord $ GL.TexCoord2 (0 :: GL.GLfloat) 1
GL.vertex $ GL.Vertex2 (w) h
GL.texture GL.Texture2D $= GL.Disabled
mapSpecialKey :: SpecialKey -> GLFW.Key
mapSpecialKey KeySpace = GLFW.KeySpace
mapSpecialKey KeyEsc = GLFW.KeyEsc
mapSpecialKey KeyLeftShift = GLFW.KeyLeftShift
mapSpecialKey KeyRightShift = GLFW.KeyRightShift
mapSpecialKey KeyLeftControl = GLFW.KeyLeftCtrl
mapSpecialKey KeyRightControl = GLFW.KeyRightCtrl
mapSpecialKey KeyUp = GLFW.KeyUp
mapSpecialKey KeyDown = GLFW.KeyDown
mapSpecialKey KeyLeft = GLFW.KeyLeft
mapSpecialKey KeyRight = GLFW.KeyRight
mapSpecialKey KeyTab = GLFW.KeyTab
mapSpecialKey KeyEnter = GLFW.KeyEnter
mapSpecialKey KeyBackspace = GLFW.KeyBackspace
mapSpecialKey KeyInsert = GLFW.KeyInsert
mapSpecialKey KeyDelete = GLFW.KeyDel
mapSpecialKey KeyPageUp = GLFW.KeyPageup
mapSpecialKey KeyPageDown = GLFW.KeyPagedown
mapSpecialKey KeyHome = GLFW.KeyHome
mapSpecialKey KeyEnd = GLFW.KeyEnd
mapSpecialKey KeyF1 = GLFW.KeyF1
mapSpecialKey KeyF2 = GLFW.KeyF2
mapSpecialKey KeyF3 = GLFW.KeyF3
mapSpecialKey KeyF4 = GLFW.KeyF4
mapSpecialKey KeyF5 = GLFW.KeyF5
mapSpecialKey KeyF6 = GLFW.KeyF6
mapSpecialKey KeyF7 = GLFW.KeyF7
mapSpecialKey KeyF8 = GLFW.KeyF8
mapSpecialKey KeyF9 = GLFW.KeyF9
mapSpecialKey KeyF10 = GLFW.KeyF10
mapSpecialKey KeyF11 = GLFW.KeyF11
mapSpecialKey KeyF12 = GLFW.KeyF12
mapSpecialKey KeyPad0 = GLFW.KeyPad0
mapSpecialKey KeyPad1 = GLFW.KeyPad1
mapSpecialKey KeyPad2 = GLFW.KeyPad2
mapSpecialKey KeyPad3 = GLFW.KeyPad3
mapSpecialKey KeyPad4 = GLFW.KeyPad4
mapSpecialKey KeyPad5 = GLFW.KeyPad5
mapSpecialKey KeyPad6 = GLFW.KeyPad6
mapSpecialKey KeyPad7 = GLFW.KeyPad7
mapSpecialKey KeyPad8 = GLFW.KeyPad8
mapSpecialKey KeyPad9 = GLFW.KeyPad9
mapSpecialKey KeyPadDivide = GLFW.KeyPadDivide
mapSpecialKey KeyPadMultiply = GLFW.KeyPadMultiply
mapSpecialKey KeyPadSubtract = GLFW.KeyPadSubtract
mapSpecialKey KeyPadAdd = GLFW.KeyPadAdd
mapSpecialKey KeyPadDecimal = GLFW.KeyPadDecimal
mapSpecialKey KeyPadEqual = GLFW.KeyPadEqual
mapSpecialKey KeyPadEnter = GLFW.KeyPadEnter
mkVertex2 :: V2 Float -> GL.Vertex2 GL.GLfloat
mkVertex2 = unsafeCoerce
gf :: Float -> GL.GLfloat
gf x = unsafeCoerce x
gsizei :: Int -> GL.GLsizei
gsizei x = unsafeCoerce x