module Render.Misc where import Control.Monad import qualified Data.ByteString as B (ByteString) import Data.Int (Int8) import Graphics.Rendering.OpenGL.GL.Shaders import Graphics.Rendering.OpenGL.GL.StateVar import Graphics.Rendering.OpenGL.GL.StringQueries import Graphics.Rendering.OpenGL.GLU.Errors import Graphics.UI.SDL.Types (Texture) import System.IO (hPutStrLn, stderr) import Linear import Foreign.C (CFloat, CUChar) import Foreign.Marshal.Array (peekArray) import Foreign.Ptr (Ptr, castPtr) up :: V3 CFloat up = V3 0 1 0 checkError :: String -> IO () checkError functionName = get errors >>= mapM_ reportError where reportError e = hPutStrLn stderr (showError e ++ " detected in " ++ functionName) showError (Error category message) = "GL error " ++ show category ++ " (" ++ message ++ ")" dumpInfo :: IO () dumpInfo = do let dump message var = putStrLn . ((message ++ ": ") ++) =<< get var dump "Vendor" vendor dump "Renderer" renderer dump "Version" glVersion dump "GLSL" shadingLanguageVersion checkError "dumpInfo" checked :: (t -> IO ()) -> (t -> GettableStateVar Bool) -> (t -> GettableStateVar String) -> String -> t -> IO () checked action getStatus getInfoLog message object = do action object status <- get (getStatus object) unless status $ hPutStrLn stderr . ((message ++ " log: ") ++) =<< get (getInfoLog object) compileAndCheck :: Shader -> IO () compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile" compileShaderSource :: ShaderType -> B.ByteString -> IO Shader compileShaderSource st source = do shader <- createShader st shaderSourceBS shader $= source compileAndCheck shader return shader linkAndCheck :: Program -> IO () linkAndCheck = checked linkProgram linkStatus programInfoLog "link" createProgramUsing :: [Shader] -> IO Program createProgramUsing shaders = do program <- createProgram attachedShaders program $= shaders linkAndCheck program return program createFrustum :: Float -> Float -> Float -> Float -> M44 CFloat createFrustum fov n' f' rat = let f = realToFrac f' n = realToFrac n' s = realToFrac $ recip (tan $ fov*0.5 * pi / 180) (ratw,rath) = if rat > 1 then (1,1/realToFrac rat) else (realToFrac rat,1) in V4 (V4 (s/ratw) 0 0 0) (V4 0 (s/rath) 0 0) (V4 0 0 (-((f+n)/(f-n))) (-((2*f*n)/(f-n)))) (V4 0 0 (-1) 0) -- | Creates an orthogonal frustum with given width, height, near and far-plane createFrustumOrtho :: Float -> Float -> Float -> Float -> M44 CFloat createFrustumOrtho w' h' n' f' = let [w,h,n,f] = map realToFrac [w',h',n',f'] in V4 (V4 (0.5/w) 0 0 0) (V4 0 (0.5/h) 0 0) (V4 0 0 (-2/(f-n)) ((-f+n)/(f-n))) (V4 0 0 0 1) -- from vmath.h lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat lookAt eye center up' = V4 (V4 xx xy xz (-dot x eye)) (V4 yx yy yz (-dot y eye)) (V4 zx zy zz (-dot z eye)) (V4 0 0 0 1) where z@(V3 zx zy zz) = normalize (eye ^-^ center) x@(V3 xx xy xz) = normalize (cross up' z) y@(V3 yx yy yz) = normalize (cross z x) {-getCam :: (Double, Double) -- ^ Target in x/z-Plane -> Double -- ^ Distance from Target -> Double -- ^ Angle around X-Axis (angle down/up) -> Double -- ^ Angle around Y-Axis (angle left/right) -> M44 CFloat getCam (x',z') dist' xa' ya' = lookAt (cpos ^+^ at') at' up where at' = V3 x 0 z cpos = crot !* (V3 0 0 (-dist)) crot = ( (fromQuaternion $ axisAngle upmap (xa::CFloat)) !*! (fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat)) ) ::M33 CFloat upmap = ((fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat)) :: M33 CFloat) !* (V3 1 0 0) x = realToFrac x' z = realToFrac z' dist = realToFrac dist' xa = realToFrac xa' ya = realToFrac ya'-} -- | Prints any Pointer as Float-Array with given number of elements. printPtrAsFloatArray :: Ptr a -> Int -> IO () printPtrAsFloatArray pointer num = do a <- peekArray num (castPtr pointer :: Ptr CFloat) print a -- | Prints any Pointer as UByte-Array with given number of elements. printPtrAsUByteArray :: Ptr a -> Int -> IO () printPtrAsUByteArray pointer num = do a <- peekArray num (castPtr pointer :: Ptr CUChar) print a curb :: Ord a => a -> a -> a -> a curb l h x | x < l = l | x > h = h | otherwise = x tryWithTexture :: Maybe Texture -> (Texture -> a) -> a -> a tryWithTexture t f fail' = case t of Just tex -> f tex _ -> fail' genColorData :: Int -- ^ Amount -> [Int8] -- ^ [r,g,b,a], [r,g,b] - whatever should be repeatet. -> [Int8] genColorData n c = take (length c*n) (cycle c)