192 lines
7.4 KiB
Haskell
192 lines
7.4 KiB
Haskell
module Render.Misc where
|
|
|
|
import Control.Monad
|
|
import qualified Data.ByteString as B (ByteString)
|
|
import Data.Int (Int8)
|
|
import Data.Word (Word32,Word8)
|
|
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.Rendering.OpenGL.GL.VertexArrayObjects
|
|
import Graphics.Rendering.OpenGL.GL.VertexArrays
|
|
import Graphics.Rendering.OpenGL.GL.VertexSpec
|
|
import Graphics.Rendering.OpenGL.GL.BufferObjects
|
|
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 and chunks.
|
|
printPtrAsFloatArray :: Ptr a -> Int -> Int -> IO ()
|
|
printPtrAsFloatArray pointer num co = do
|
|
a <- peekArray num (castPtr pointer :: Ptr CFloat)
|
|
print $ chunksOf co a
|
|
|
|
-- | Prints any Pointer as UByte-Array with given number of elements and chunks.
|
|
printPtrAsUByteArray :: Ptr a -> Int -> Int -> IO ()
|
|
printPtrAsUByteArray pointer num co = do
|
|
a <- peekArray num (castPtr pointer :: Ptr CUChar)
|
|
print $ chunksOf co a
|
|
|
|
-- | Prints any Pointer as Word32-Array with given number of elements and chunks.
|
|
printPtrAsWord32Array :: Ptr a -> Int -> Int -> IO ()
|
|
printPtrAsWord32Array pointer num co = do
|
|
a <- peekArray num (castPtr pointer :: Ptr Word32)
|
|
print $ chunksOf co 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
|
|
-> [Word8] -- ^ [r,g,b,a], [r,g,b] - whatever should be repeatet.
|
|
-> [Word8]
|
|
genColorData n c = take (length c*n) (cycle c)
|
|
|
|
chunksOf :: Int -> [a] -> [[a]]
|
|
chunksOf _ [] = []
|
|
chunksOf a xs = take a xs : chunksOf a (drop a xs)
|
|
|
|
|
|
withVAO :: VertexArrayObject -> IO a -> IO a
|
|
withVAO v a = do
|
|
bindVertexArrayObject $= Just v
|
|
ret <- a
|
|
bindVertexArrayObject $= Nothing
|
|
return ret
|
|
|
|
withVBO :: BufferObject -> BufferTarget -> IO a -> IO a
|
|
withVBO b t a = do
|
|
bindBuffer t $= Just b
|
|
ret <- a
|
|
bindBuffer t $= Nothing
|
|
return ret
|
|
|
|
withVAA :: [AttribLocation] -> IO a -> IO a
|
|
withVAA atts action = do
|
|
mapM_ (\a -> vertexAttribArray a $= Enabled) atts
|
|
ret <- action
|
|
mapM_ (\a -> vertexAttribArray a $= Disabled) atts
|
|
return ret
|