pioneers/src/Render/Misc.hs
Stefan Dresselhaus 1e9c6a24fd
minor
- fixed imports
- cleaned debug-info. now not binary anymore, but readable
2014-06-10 23:15:59 +02:00

155 lines
6.0 KiB
Haskell

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)