{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module Gamgine.Gfx where import Graphics.GL 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 :: Double -> Double -> (Double, Double) xy Double x Double y = (Double x, Double y) xyz :: Double -> Double -> Double -> XYZ xyz :: Double -> Double -> Double -> RGB xyz Double x Double y Double z = (Double x, Double y, Double z) xyzw :: Double -> Double -> Double -> Double -> XYZW xyzw :: Double -> Double -> Double -> Double -> XYZW xyzw Double x Double y Double z Double w = (Double x, Double y, Double z, Double w) rgb :: Double -> Double -> Double -> RGB rgb :: Double -> Double -> Double -> RGB rgb Double r Double g Double b = (Double r, Double g, Double b) rgba :: Double -> Double -> Double -> Double -> RGBA rgba :: Double -> Double -> Double -> Double -> XYZW rgba Double r Double g Double b Double a = (Double r, Double g, Double b, Double a) floatToFloat :: (RealFloat a, RealFloat b) => a -> b floatToFloat :: forall a b. (RealFloat a, RealFloat b) => a -> b floatToFloat = ((Integer -> Int -> b) -> (Integer, Int) -> b forall a b c. (a -> b -> c) -> (a, b) -> c uncurry Integer -> Int -> b forall a. RealFloat a => Integer -> Int -> a encodeFloat) ((Integer, Int) -> b) -> (a -> (Integer, Int)) -> a -> b forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> (Integer, Int) forall a. RealFloat a => a -> (Integer, Int) 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 :: XYZW -> Double t4d_first (Double f, Double _, Double _, Double _) = Double f t4d_second :: XYZW -> Double t4d_second (Double _, Double s, Double _, Double _) = Double s t4d_third :: XYZW -> Double t4d_third (Double _, Double _, Double t, Double _) = Double t t4d_forth :: XYZW -> Double t4d_forth (Double _, Double _, Double _, Double f) = Double f instance Tuple4d (Vec4 Double) where t4d_first :: Vec4 Double -> Double t4d_first (Double f:.Vect _) = Double f t4d_second :: Vec4 Double -> Double t4d_second (Double _:.Double s:.Vec2 Double _) = Double s t4d_third :: Vec4 Double -> Double t4d_third (Double _:.Double _:.Double t:.Double :. () _) = Double t t4d_forth :: Vec4 Double -> Double t4d_forth (Double _:.Double _:.Double _:.Double f:.()) = Double 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 :: RGB -> Double t3d_first (Double f, Double _, Double _) = Double f t3d_second :: RGB -> Double t3d_second (Double _, Double s, Double _) = Double s t3d_third :: RGB -> Double t3d_third (Double _, Double _, Double t) = Double t instance Tuple3d (Vec3 Double) where t3d_first :: Vect -> Double t3d_first (Double f:.Vec2 Double _) = Double f t3d_second :: Vect -> Double t3d_second (Double _:.Double s:.Double :. () _) = Double s t3d_third :: Vect -> Double t3d_third (Double _:.Double _:.Double t:.()) = Double t class Tuple2d a where t2d_first :: a -> Double t2d_second :: a -> Double instance Tuple2d (Double, Double) where t2d_first :: (Double, Double) -> Double t2d_first (Double f, Double _) = Double f t2d_second :: (Double, Double) -> Double t2d_second (Double _, Double s) = Double s instance Tuple2d (Vec2 Double) where t2d_first :: Vec2 Double -> Double t2d_first (Double f:.Double :. () _) = Double f t2d_second :: Vec2 Double -> Double t2d_second (Double _:.Double s:.()) = Double s (<<) :: Tuple2d a => (GLfloat -> GLfloat -> IO ()) -> a -> IO () GLfloat -> GLfloat -> IO () f << :: forall a. Tuple2d a => (GLfloat -> GLfloat -> IO ()) -> a -> IO () << a a = GLfloat -> GLfloat -> IO () f (Double -> GLfloat forall a b. (RealFloat a, RealFloat b) => a -> b floatToFloat (Double -> GLfloat) -> Double -> GLfloat forall a b. (a -> b) -> a -> b $ a -> Double forall a. Tuple2d a => a -> Double t2d_first a a) (Double -> GLfloat forall a b. (RealFloat a, RealFloat b) => a -> b floatToFloat (Double -> GLfloat) -> Double -> GLfloat forall a b. (a -> b) -> a -> b $ a -> Double forall a. Tuple2d a => a -> Double t2d_second a a) infixl 5 << (<<<) :: Tuple3d a => (GLfloat -> GLfloat -> GLfloat -> IO ()) -> a -> IO () GLfloat -> GLfloat -> GLfloat -> IO () f <<< :: forall a. Tuple3d a => (GLfloat -> GLfloat -> GLfloat -> IO ()) -> a -> IO () <<< a a = GLfloat -> GLfloat -> GLfloat -> IO () f (Double -> GLfloat forall a b. (RealFloat a, RealFloat b) => a -> b floatToFloat (Double -> GLfloat) -> Double -> GLfloat forall a b. (a -> b) -> a -> b $ a -> Double forall a. Tuple3d a => a -> Double t3d_first a a) (Double -> GLfloat forall a b. (RealFloat a, RealFloat b) => a -> b floatToFloat (Double -> GLfloat) -> Double -> GLfloat forall a b. (a -> b) -> a -> b $ a -> Double forall a. Tuple3d a => a -> Double t3d_second a a) (Double -> GLfloat forall a b. (RealFloat a, RealFloat b) => a -> b floatToFloat (Double -> GLfloat) -> Double -> GLfloat forall a b. (a -> b) -> a -> b $ a -> Double forall a. Tuple3d a => a -> Double t3d_third a a) infixl 5 <<< (<<<<) :: Tuple4d a => (GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()) -> a -> IO () GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO () f <<<< :: forall a. Tuple4d a => (GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()) -> a -> IO () <<<< a a = GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO () f (Double -> GLfloat forall a b. (RealFloat a, RealFloat b) => a -> b floatToFloat (Double -> GLfloat) -> Double -> GLfloat forall a b. (a -> b) -> a -> b $ a -> Double forall a. Tuple4d a => a -> Double t4d_first a a) (Double -> GLfloat forall a b. (RealFloat a, RealFloat b) => a -> b floatToFloat (Double -> GLfloat) -> Double -> GLfloat forall a b. (a -> b) -> a -> b $ a -> Double forall a. Tuple4d a => a -> Double t4d_second a a) (Double -> GLfloat forall a b. (RealFloat a, RealFloat b) => a -> b floatToFloat (Double -> GLfloat) -> Double -> GLfloat forall a b. (a -> b) -> a -> b $ a -> Double forall a. Tuple4d a => a -> Double t4d_third a a) (Double -> GLfloat forall a b. (RealFloat a, RealFloat b) => a -> b floatToFloat (Double -> GLfloat) -> Double -> GLfloat forall a b. (a -> b) -> a -> b $ a -> Double forall a. Tuple4d a => a -> Double t4d_forth a a) infixl 5 <<<< quad :: (Double,Double) -> (Double,Double) -> [(Double,Double)] quad :: (Double, Double) -> (Double, Double) -> [(Double, Double)] quad (Double minx, Double miny) (Double maxx, Double maxy) = [(Double minx,Double miny), (Double maxx,Double miny), (Double maxx, Double maxy), (Double minx, Double maxy)] quadTexCoords :: Double -> Double -> [(Double,Double)] quadTexCoords :: Double -> Double -> [(Double, Double)] quadTexCoords Double maxx Double maxy = [(Double 0,Double maxy), (Double maxx,Double maxy), (Double maxx,Double 0), (Double 0,Double 0)] draw :: Tuple3d a => GLenum -> [a] -> IO () draw :: forall a. Tuple3d a => GLenum -> [a] -> IO () draw GLenum primType [a] vertices = GLenum -> IO () -> IO () withPrimitive GLenum primType (IO () -> IO ()) -> IO () -> IO () forall a b. (a -> b) -> a -> b $ (a -> IO ()) -> [a] -> IO () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (GLfloat -> GLfloat -> GLfloat -> IO () forall (m :: * -> *). MonadIO m => GLfloat -> GLfloat -> GLfloat -> m () glVertex3f (GLfloat -> GLfloat -> GLfloat -> IO ()) -> a -> IO () forall a. Tuple3d a => (GLfloat -> GLfloat -> GLfloat -> IO ()) -> a -> IO () <<<) [a] vertices drawBox :: B.Box -> IO () drawBox :: Box -> IO () drawBox Box box = do Vect -> Vect -> IO () forall a. Tuple3d a => a -> a -> IO () drawQuad (Box -> Vect B.minPt Box box) (Box -> Vect B.maxPt Box box) drawQuad :: Tuple3d a => a -> a -> IO () drawQuad :: forall a. Tuple3d a => a -> a -> IO () drawQuad a min a max = do GLenum -> [RGB] -> IO () forall a. Tuple3d a => GLenum -> [a] -> IO () draw GLenum GL_QUADS [(Double minX, Double minY, Double 0 :: Double), (Double maxX, Double minY, Double 0 :: Double), (Double maxX, Double maxY, Double 0 :: Double), (Double minX, Double maxY, Double 0 :: Double)] where minX :: Double minX = a -> Double forall a. Tuple3d a => a -> Double t3d_first a min minY :: Double minY = a -> Double forall a. Tuple3d a => a -> Double t3d_second a min maxX :: Double maxX = a -> Double forall a. Tuple3d a => a -> Double t3d_first a max maxY :: Double maxY = a -> Double forall a. Tuple3d a => a -> Double t3d_second a max drawBoxTree :: BT.BoxTree a -> IO () drawBoxTree :: forall a. BoxTree a -> IO () drawBoxTree BoxTree a tree = do BoxTree a -> IO () forall a. BoxTree a -> IO () go BoxTree a tree where go :: BoxTree a -> IO () go (Node Box box [BoxTree a] ts) = Box -> IO () drawBox Box box IO () -> IO () -> IO () forall a b. IO a -> IO b -> IO b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> (BoxTree a -> IO ()) -> [BoxTree a] -> IO () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (\BoxTree a t -> BoxTree a -> IO () go BoxTree a t) [BoxTree a] ts go (Leaf Box box a _) = Box -> IO () drawBox Box box drawPoint :: Tuple3d a => a -> RGB -> IO () drawPoint :: forall a. Tuple3d a => a -> RGB -> IO () drawPoint a pos RGB color = do GLfloat -> IO () forall (m :: * -> *). MonadIO m => GLfloat -> m () glPointSize GLfloat 10 GLenum -> IO () forall (m :: * -> *). MonadIO m => GLenum -> m () glBegin GLenum GL_POINTS GLfloat -> GLfloat -> GLfloat -> IO () forall (m :: * -> *). MonadIO m => GLfloat -> GLfloat -> GLfloat -> m () glVertex3f (GLfloat -> GLfloat -> GLfloat -> IO ()) -> a -> IO () forall a. Tuple3d a => (GLfloat -> GLfloat -> GLfloat -> IO ()) -> a -> IO () <<< a pos IO () forall (m :: * -> *). MonadIO m => m () glEnd withPrimitive :: GLenum -> IO () -> IO () withPrimitive :: GLenum -> IO () -> IO () withPrimitive GLenum primType IO () act = do GLenum -> IO () forall (m :: * -> *). MonadIO m => GLenum -> m () glBegin GLenum primType IO () act IO () forall (m :: * -> *). MonadIO m => m () glEnd withPushedMatrix :: IO a -> IO a withPushedMatrix :: forall a. IO a -> IO a withPushedMatrix IO a act = do IO () forall (m :: * -> *). MonadIO m => m () glPushMatrix a a <- IO a act IO () forall (m :: * -> *). MonadIO m => m () glPopMatrix a -> IO a forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return a a withPolyMode :: GLenum -> IO () -> IO () withPolyMode :: GLenum -> IO () -> IO () withPolyMode GLenum mode IO () act = do GLenum -> GLenum -> IO () forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> m () glPolygonMode GLenum GL_FRONT_AND_BACK GLenum mode IO () act GLenum -> GLenum -> IO () forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> m () glPolygonMode GLenum GL_FRONT_AND_BACK GLenum GL_FILL withEnabled :: GLenum -> IO () -> IO () withEnabled :: GLenum -> IO () -> IO () withEnabled GLenum mode IO () act = do GLenum -> IO () forall (m :: * -> *). MonadIO m => GLenum -> m () glEnable GLenum mode IO () act GLenum -> IO () forall (m :: * -> *). MonadIO m => GLenum -> m () glDisable GLenum mode withBlend :: GLenum -> GLenum -> IO () -> IO () withBlend :: GLenum -> GLenum -> IO () -> IO () withBlend GLenum srcFactor GLenum dstFactor IO () act = do GLenum -> GLenum -> IO () forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> m () glBlendFunc GLenum srcFactor GLenum dstFactor GLenum -> IO () -> IO () withEnabled GLenum GL_BLEND IO () act withTexture2d :: GLuint -> IO () -> IO () withTexture2d :: GLenum -> IO () -> IO () withTexture2d GLenum id IO () act = do GLenum -> GLenum -> IO () forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> m () glBindTexture GLenum GL_TEXTURE_2D GLenum id GLenum -> IO () -> IO () withEnabled GLenum GL_TEXTURE_2D IO () act makeTexture2d :: FilePath -> GLenum -> IO GLuint makeTexture2d :: FilePath -> GLenum -> IO GLenum makeTexture2d FilePath file GLenum wrapMode = do Either FilePath PNGImage res <- FilePath -> IO (Either FilePath PNGImage) loadPNGFile FilePath file (FilePath -> IO GLenum) -> (PNGImage -> IO GLenum) -> Either FilePath PNGImage -> IO GLenum forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (\FilePath str -> FilePath -> IO GLenum forall a. HasCallStack => FilePath -> a ERROR str) (\PNGImage img -> PNGImage -> IO GLenum genTex PNGImage img) Either FilePath PNGImage res where genTex :: PNGImage -> IO GLenum genTex PNGImage img = do let (GLenum width, GLenum height) = PNGImage -> (GLenum, GLenum) dimensions PNGImage img imgData :: StorableArray (Int, Int) Word8 imgData = PNGImage -> StorableArray (Int, Int) Word8 imageData PNGImage img format :: GLenum format = PNGImage -> Bool hasAlphaChannel PNGImage img Bool -> GLenum -> GLenum -> GLenum forall a. Bool -> a -> a -> a ? GLenum GL_RGBA (GLenum -> GLenum) -> GLenum -> GLenum forall a b. (a -> b) -> a -> b $ GLenum GL_RGB GLenum id <- GLenum -> (Ptr GLenum -> IO GLenum) -> IO GLenum forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b with GLenum 0 (\Ptr GLenum buf -> GLsizei -> Ptr GLenum -> IO () forall (m :: * -> *). MonadIO m => GLsizei -> Ptr GLenum -> m () glGenTextures GLsizei 1 Ptr GLenum buf IO () -> IO GLenum -> IO GLenum forall a b. IO a -> IO b -> IO b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> Ptr GLenum -> IO GLenum forall a. Storable a => Ptr a -> IO a peek Ptr GLenum buf) GLenum -> GLenum -> IO () forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> m () glBindTexture GLenum GL_TEXTURE_2D GLenum id GLenum -> GLenum -> GLsizei -> IO () forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> GLsizei -> m () glTexParameteri GLenum GL_TEXTURE_2D GLenum GL_TEXTURE_WRAP_S (GLenum -> GLsizei forall a b. (Integral a, Num b) => a -> b fromIntegral GLenum wrapMode) GLenum -> GLenum -> GLsizei -> IO () forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> GLsizei -> m () glTexParameteri GLenum GL_TEXTURE_2D GLenum GL_TEXTURE_WRAP_T (GLenum -> GLsizei forall a b. (Integral a, Num b) => a -> b fromIntegral GLenum wrapMode) GLenum -> GLenum -> GLsizei -> IO () forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> GLsizei -> m () glTexParameteri GLenum GL_TEXTURE_2D GLenum GL_TEXTURE_MAG_FILTER (GLenum -> GLsizei forall a b. (Integral a, Num b) => a -> b fromIntegral GLenum GL_NEAREST) GLenum -> GLenum -> GLsizei -> IO () forall (m :: * -> *). MonadIO m => GLenum -> GLenum -> GLsizei -> m () glTexParameteri GLenum GL_TEXTURE_2D GLenum GL_TEXTURE_MIN_FILTER (GLenum -> GLsizei forall a b. (Integral a, Num b) => a -> b fromIntegral GLenum GL_NEAREST) StorableArray (Int, Int) Word8 -> (Ptr Word8 -> IO ()) -> IO () forall i e a. StorableArray i e -> (Ptr e -> IO a) -> IO a withStorableArray StorableArray (Int, Int) Word8 imgData (\Ptr Word8 array -> GLenum -> GLsizei -> GLsizei -> GLsizei -> GLsizei -> GLsizei -> GLenum -> GLenum -> Ptr Word8 -> IO () forall (m :: * -> *) a. MonadIO m => GLenum -> GLsizei -> GLsizei -> GLsizei -> GLsizei -> GLsizei -> GLenum -> GLenum -> Ptr a -> m () glTexImage2D GLenum GL_TEXTURE_2D GLsizei 0 (GLenum -> GLsizei forall a b. (Integral a, Num b) => a -> b fromIntegral GLenum format) (GLenum -> GLsizei forall a b. (Integral a, Num b) => a -> b fromIntegral GLenum width) (GLenum -> GLsizei forall a b. (Integral a, Num b) => a -> b fromIntegral GLenum height) GLsizei 0 (GLenum -> GLenum forall a b. (Integral a, Num b) => a -> b fromIntegral GLenum format) GLenum GL_UNSIGNED_BYTE Ptr Word8 array) GLenum -> IO GLenum forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return GLenum id renderTexturedQuad :: (Double,Double) -> GLuint -> IO () renderTexturedQuad :: (Double, Double) -> GLenum -> IO () renderTexturedQuad (Double, Double) size GLenum texture = GLenum -> IO () -> IO () withTexture2d GLenum texture (IO () -> IO ()) -> IO () -> IO () forall a b. (a -> b) -> a -> b $ GLenum -> GLenum -> IO () -> IO () withBlend GLenum GL_SRC_ALPHA GLenum GL_ONE_MINUS_SRC_ALPHA (IO () -> IO ()) -> IO () -> IO () forall a b. (a -> b) -> a -> b $ GLenum -> IO () -> IO () withPrimitive GLenum GL_QUADS (IO () -> IO ()) -> IO () -> IO () forall a b. (a -> b) -> a -> b $ do let coords :: [(Double, Double)] coords = Double -> Double -> [(Double, Double)] quadTexCoords Double 1 Double 1 vertices :: [(Double, Double)] vertices = (Double, Double) -> (Double, Double) -> [(Double, Double)] quad (Double 0,Double 0) (Double, Double) size GLfloat -> GLfloat -> GLfloat -> IO () forall (m :: * -> *). MonadIO m => GLfloat -> GLfloat -> GLfloat -> m () glColor3f (GLfloat -> GLfloat -> GLfloat -> IO ()) -> RGB -> IO () forall a. Tuple3d a => (GLfloat -> GLfloat -> GLfloat -> IO ()) -> a -> IO () <<< ((Double 1, Double 1, Double 1) :: RGB) [((Double, Double), (Double, Double))] -> (((Double, Double), (Double, Double)) -> IO ()) -> IO () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ ([(Double, Double)] -> [(Double, Double)] -> [((Double, Double), (Double, Double))] forall a b. [a] -> [b] -> [(a, b)] zip [(Double, Double)] coords [(Double, Double)] vertices) (\((Double, Double) c,(Double, Double) v) -> do GLfloat -> GLfloat -> IO () forall (m :: * -> *). MonadIO m => GLfloat -> GLfloat -> m () glTexCoord2f (GLfloat -> GLfloat -> IO ()) -> (Double, Double) -> IO () forall a. Tuple2d a => (GLfloat -> GLfloat -> IO ()) -> a -> IO () << (Double, Double) c GLfloat -> GLfloat -> IO () forall (m :: * -> *). MonadIO m => GLfloat -> GLfloat -> m () glVertex2f (GLfloat -> GLfloat -> IO ()) -> (Double, Double) -> IO () forall a. Tuple2d a => (GLfloat -> GLfloat -> IO ()) -> a -> IO () << (Double, Double) v)