module Gamgine.Gfx where
import Graphics.Rendering.OpenGL.Raw
import Control.Monad (forM_)
import Data.Either
import Foreign.Marshal.Utils
import Foreign.Storable
import Data.Array.Storable
import System.IO
import Gamgine.Image.PNG
import qualified Gamgine.Math.Box as B
import Gamgine.Math.Vect
import Gamgine.Math.BoxTree as BT
import Gamgine.Control ((?))
#include "Gamgine/Utils.cpp"
type XY = (Double, Double)
type XYZ = (Double, Double, Double)
type XYZW = (Double, Double, Double, Double)
type RGB = (Double, Double, Double)
type RGBA = (Double, Double, Double, Double)
xy :: Double -> Double -> XY
xy x y = (x, y)
xyz :: Double -> Double -> Double -> XYZ
xyz x y z = (x, y, z)
xyzw :: Double -> Double -> Double -> Double -> XYZW
xyzw x y z w = (x, y, z, w)
rgb :: Double -> Double -> Double -> RGB
rgb r g b = (r, g, b)
rgba :: Double -> Double -> Double -> Double -> RGBA
rgba r g b a = (r, g, b, a)
floatToFloat :: (RealFloat a, RealFloat b) => a -> b
floatToFloat = (uncurry encodeFloat) . decodeFloat
class Tuple4d a where
t4d_first :: a -> Double
t4d_second :: a -> Double
t4d_third :: a -> Double
t4d_forth :: a -> Double
instance Tuple4d (Double, Double, Double, Double) where
t4d_first (f, _, _, _) = f
t4d_second (_, s, _, _) = s
t4d_third (_, _, t, _) = t
t4d_forth (_, _, _, f) = f
instance Tuple4d (Vec4 Double) where
t4d_first (f:._) = f
t4d_second (_:.s:._) = s
t4d_third (_:._:.t:._) = t
t4d_forth (_:._:._:.f:.()) = f
class Tuple3d a where
t3d_first :: a -> Double
t3d_second :: a -> Double
t3d_third :: a -> Double
instance Tuple3d (Double, Double, Double) where
t3d_first (f, _, _) = f
t3d_second (_, s, _) = s
t3d_third (_, _, t) = t
instance Tuple3d (Vec3 Double) where
t3d_first (f:._) = f
t3d_second (_:.s:._) = s
t3d_third (_:._:.t:.()) = t
class Tuple2d a where
t2d_first :: a -> Double
t2d_second :: a -> Double
instance Tuple2d (Double, Double) where
t2d_first (f, _) = f
t2d_second (_, s) = s
instance Tuple2d (Vec2 Double) where
t2d_first (f:._) = f
t2d_second (_:.s:.()) = s
(<<) :: Tuple2d a => (GLfloat -> GLfloat -> IO ()) -> a -> IO ()
f << a = f (floatToFloat $ t2d_first a)
(floatToFloat $ t2d_second a)
infixl 5 <<
(<<<) :: Tuple3d a => (GLfloat -> GLfloat -> GLfloat -> IO ()) -> a -> IO ()
f <<< a = f (floatToFloat $ t3d_first a)
(floatToFloat $ t3d_second a)
(floatToFloat $ t3d_third a)
infixl 5 <<<
(<<<<) :: Tuple4d a => (GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()) -> a -> IO ()
f <<<< a = f (floatToFloat $ t4d_first a)
(floatToFloat $ t4d_second a)
(floatToFloat $ t4d_third a)
(floatToFloat $ t4d_forth a)
infixl 5 <<<<
quad :: (Double,Double) -> (Double,Double) -> [(Double,Double)]
quad (minx, miny) (maxx, maxy) =
[(minx,miny), (maxx,miny), (maxx, maxy), (minx, maxy)]
quadTexCoords :: Double -> Double -> [(Double,Double)]
quadTexCoords maxx maxy = [(0,maxy), (maxx,maxy), (maxx,0), (0,0)]
draw :: Tuple3d a => GLenum -> [a] -> IO ()
draw primType vertices = withPrimitive primType $ mapM_ (glVertex3f <<<) vertices
drawBox :: B.Box -> IO ()
drawBox box = do
drawQuad (B.minPt box) (B.maxPt box)
drawQuad :: Tuple3d a => a -> a -> IO ()
drawQuad min max = do
draw gl_QUADS [(minX, minY, 0 :: Double), (maxX, minY, 0 :: Double),
(maxX, maxY, 0 :: Double), (minX, maxY, 0 :: Double)]
where
minX = t3d_first min
minY = t3d_second min
maxX = t3d_first max
maxY = t3d_second max
drawBoxTree :: BT.BoxTree a -> IO ()
drawBoxTree tree = do
go tree
where
go (Node box ts) = drawBox box >> mapM_ (\t -> go t) ts
go (Leaf box _) = drawBox box
drawPoint :: Tuple3d a => a -> RGB -> IO ()
drawPoint pos color = do
glPointSize 10
glBegin gl_POINTS
glVertex3f <<< pos
glEnd
withPrimitive :: GLenum -> IO () -> IO ()
withPrimitive primType act = do
glBegin primType
act
glEnd
withPushedMatrix :: IO a -> IO a
withPushedMatrix act = do
glPushMatrix
a <- act
glPopMatrix
return a
withPolyMode :: GLenum -> IO () -> IO ()
withPolyMode mode act = do
glPolygonMode gl_FRONT_AND_BACK mode
act
glPolygonMode gl_FRONT_AND_BACK gl_FILL
withEnabled :: GLenum -> IO () -> IO ()
withEnabled mode act = do
glEnable mode
act
glDisable mode
withBlend :: GLenum -> GLenum -> IO () -> IO ()
withBlend srcFactor dstFactor act = do
glBlendFunc srcFactor dstFactor
withEnabled gl_BLEND act
withTexture2d :: GLuint -> IO () -> IO ()
withTexture2d id act = do
glBindTexture gl_TEXTURE_2D id
withEnabled gl_TEXTURE_2D act
makeTexture2d :: FilePath -> GLenum -> IO GLuint
makeTexture2d file wrapMode = do
res <- loadPNGFile file
either (\str -> ERROR str)
(\img -> genTex img)
res
where
genTex img = do
let (width, height) = dimensions img
imgData = imageData img
format = hasAlphaChannel img ? gl_RGBA $ gl_RGB
id <- with 0 (\buf -> glGenTextures 1 buf >> peek buf)
glBindTexture gl_TEXTURE_2D id
glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_S (fromIntegral wrapMode)
glTexParameteri gl_TEXTURE_2D gl_TEXTURE_WRAP_T (fromIntegral wrapMode)
glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER (fromIntegral gl_NEAREST)
glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER (fromIntegral gl_NEAREST)
withStorableArray imgData (\array ->
glTexImage2D gl_TEXTURE_2D 0 (fromIntegral format) (fromIntegral width)
(fromIntegral height) 0 (fromIntegral format) gl_UNSIGNED_BYTE array)
return id
renderTexturedQuad :: (Double,Double) -> GLuint -> IO ()
renderTexturedQuad size texture =
withTexture2d texture $
withBlend gl_SRC_ALPHA gl_ONE_MINUS_SRC_ALPHA $
withPrimitive gl_QUADS $ do
let coords = quadTexCoords 1 1
vertices = quad (0,0) size
glColor3f <<< ((1, 1, 1) :: RGB)
forM_ (zip coords vertices) (\(c,v) -> do
glTexCoord2f << c
glVertex2f << v)