merged .. but colors broken..
This commit is contained in:
Stefan Dresselhaus
@@ -26,5 +26,8 @@ executable Pioneers
|
||||
transformers >=0.3.0 && <0.4,
|
||||
mtl >=2.1.2,
|
||||
stm >=2.4.2,
|
||||
vector >=0.10.9 && <0.11
|
||||
vector >=0.10.9 && <0.11,
|
||||
distributive >=0.3.2 && <0.4,
|
||||
linear >=1.3.1 && <1.4,
|
||||
lens >=3.10.1 && <3.11
|
||||
|
||||
|
||||
@@ -2,19 +2,31 @@
|
||||
|
||||
//constant projection matrix
|
||||
uniform mat4 fg_ProjectionMatrix;
|
||||
uniform mat4 fg_ViewMatrix;
|
||||
uniform mat3 fg_NormalMatrix;
|
||||
|
||||
//vertex-data
|
||||
in vec4 fg_Color;
|
||||
in vec3 fg_VertexIn;
|
||||
in vec3 fg_Normal;
|
||||
in vec3 fg_NormalIn;
|
||||
|
||||
//output-data for later stages
|
||||
out vec4 fg_SmoothColor;
|
||||
|
||||
void main()
|
||||
{
|
||||
vec3 fg_Normal = fg_NormalIn; //vec3(0,1,0);
|
||||
//transform vec3 into vec4, setting w to 1
|
||||
vec4 fg_Vertex = vec4(fg_VertexIn.x, fg_VertexIn.y+0.1, fg_VertexIn.z, 1.0);
|
||||
fg_SmoothColor = fg_Color + 0.001* fg_Normal.xyzx;
|
||||
gl_Position = fg_ProjectionMatrix * fg_Vertex;
|
||||
vec4 fg_Vertex = vec4(fg_VertexIn, 1.0);
|
||||
vec4 light = vec4(1.0,1.0,1.0,1.0);
|
||||
vec4 dark = vec4(0.0,0.0,0.0,1.0);
|
||||
//direction to sun from origin
|
||||
vec3 lightDir = normalize(vec3(5.0,5.0,1.0));
|
||||
|
||||
|
||||
float costheta = dot(normalize(fg_Normal), lightDir);
|
||||
float a = costheta * 0.5 + 0.5;
|
||||
|
||||
fg_SmoothColor = fg_Color * mix(dark, light, a);// + 0.001* fg_Normal.xyzx;
|
||||
gl_Position = fg_ProjectionMatrix * fg_ViewMatrix * fg_Vertex;
|
||||
}
|
||||
103
src/Main.hs
103
src/Main.hs
@@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
module Main (main) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
@@ -9,15 +10,18 @@ import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
|
||||
import Data.List (intercalate)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Text.PrettyPrint
|
||||
import Data.Distributive (distribute)
|
||||
import Foreign (Ptr, castPtr, with)
|
||||
import Foreign.C (CFloat)
|
||||
import Linear as L
|
||||
|
||||
import qualified Graphics.Rendering.OpenGL.GL as GL
|
||||
import qualified Graphics.Rendering.OpenGL.Raw.Core31 as GLRaw
|
||||
import Graphics.Rendering.OpenGL.Raw.Core31
|
||||
import qualified Graphics.UI.GLFW as GLFW
|
||||
import qualified Data.Vector.Storable as V
|
||||
|
||||
import Map.Map
|
||||
import Render.Render (initShader)
|
||||
import Render.Misc (up, lookAtUniformMatrix4fv, createFrustum, checkError)
|
||||
import Render.Render (initShader, initRendering)
|
||||
import Render.Misc (up, createFrustum, checkError, lookAt)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
@@ -43,13 +47,15 @@ data State = State
|
||||
, stateDragStartY :: !Double
|
||||
, stateDragStartXAngle :: !Double
|
||||
, stateDragStartYAngle :: !Double
|
||||
, stateFrustum :: [GL.GLfloat]
|
||||
, stateFrustum :: !(M44 CFloat)
|
||||
-- pointer to bindings for locations inside the compiled shader
|
||||
-- mutable because shaders may be changed in the future.
|
||||
, shdrVertexIndex :: !GL.AttribLocation
|
||||
, shdrColorIndex :: !GL.AttribLocation
|
||||
, shdrNormalIndex :: !GL.AttribLocation
|
||||
, shdrVertexIndex :: !GL.AttribLocation
|
||||
, shdrProjMatIndex :: !GL.UniformLocation
|
||||
, shdrViewMatIndex :: !GL.UniformLocation
|
||||
, shdrModelMatIndex :: !GL.UniformLocation
|
||||
-- the map
|
||||
, stateMap :: !GL.BufferObject
|
||||
, mapVert :: !GL.NumArrayIndices
|
||||
@@ -105,13 +111,13 @@ main = do
|
||||
|
||||
(fbWidth, fbHeight) <- GLFW.getFramebufferSize win
|
||||
|
||||
initRendering
|
||||
--generate map vertices
|
||||
(mapBuffer, vert) <- getMapBufferObject
|
||||
(ci, ni, vi, pi) <- initShader
|
||||
(ci, ni, vi, pri, vii, mi) <- initShader
|
||||
|
||||
let zDistClosest = 10
|
||||
zDistFarthest = zDistClosest + 20
|
||||
zDist = zDistClosest + ((zDistFarthest - zDistClosest) / 2)
|
||||
fov = 90 --field of view
|
||||
near = 1 --near plane
|
||||
far = 100 --far plane
|
||||
@@ -126,8 +132,8 @@ main = do
|
||||
state = State
|
||||
{ stateWindowWidth = fbWidth
|
||||
, stateWindowHeight = fbHeight
|
||||
, stateXAngle = 0
|
||||
, stateYAngle = 0
|
||||
, stateXAngle = pi/6
|
||||
, stateYAngle = pi/2
|
||||
, stateZAngle = 0
|
||||
, stateZDist = 10
|
||||
, stateMouseDown = False
|
||||
@@ -136,10 +142,12 @@ main = do
|
||||
, stateDragStartY = 0
|
||||
, stateDragStartXAngle = 0
|
||||
, stateDragStartYAngle = 0
|
||||
, shdrColorIndex = ci
|
||||
, shdrNormalIndex = ni
|
||||
, shdrVertexIndex = vi
|
||||
, shdrProjMatIndex = pi
|
||||
, shdrNormalIndex = ni
|
||||
, shdrColorIndex = ci
|
||||
, shdrProjMatIndex = pri
|
||||
, shdrViewMatIndex = vii
|
||||
, shdrModelMatIndex = mi
|
||||
, stateMap = mapBuffer
|
||||
, mapVert = vert
|
||||
, stateFrustum = frust
|
||||
@@ -210,8 +218,7 @@ charCallback tc win c = atomically $ writeTQueue tc $ EventC
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
runDemo :: Env -> State -> IO ()
|
||||
runDemo env state = do
|
||||
void $ evalRWST (adjustWindow >> run) env state
|
||||
runDemo env state = void $ evalRWST (adjustWindow >> run) env state
|
||||
|
||||
run :: Pioneer ()
|
||||
run = do
|
||||
@@ -221,13 +228,12 @@ run = do
|
||||
draw
|
||||
liftIO $ do
|
||||
GLFW.swapBuffers win
|
||||
GL.flush -- not necessary, but someone recommended it
|
||||
GLFW.pollEvents
|
||||
GL.finish
|
||||
-- getEvents & process
|
||||
processEvents
|
||||
|
||||
-- update State
|
||||
|
||||
state <- get
|
||||
if stateDragging state
|
||||
then do
|
||||
@@ -238,10 +244,21 @@ run = do
|
||||
(x, y) <- liftIO $ GLFW.getCursorPos win
|
||||
let myrot = (x - sodx) / 2
|
||||
mxrot = (y - sody) / 2
|
||||
-- newXAngle = if newXAngle' > 2*pi then 2*pi else
|
||||
newXAngle = if newXAngle' > 0.45*pi then 0.45*pi else
|
||||
-- if newXAngle' < -2*pi then -2*pi else
|
||||
if newXAngle' < 0 then 0 else
|
||||
newXAngle'
|
||||
newXAngle' = sodxa + mxrot/100
|
||||
newYAngle = if newYAngle' > pi then newYAngle'-2*pi else
|
||||
if newYAngle' < -pi then newYAngle'+2*pi else
|
||||
newYAngle'
|
||||
newYAngle' = sodya + myrot/100
|
||||
put $ state
|
||||
{ stateXAngle = sodxa + mxrot
|
||||
, stateYAngle = sodya + myrot
|
||||
{ stateXAngle = newXAngle
|
||||
, stateYAngle = newYAngle
|
||||
}
|
||||
-- liftIO $ putStrLn $ unwords $ map show $ [newXAngle, newYAngle]
|
||||
else do
|
||||
(kxrot, kyrot) <- liftIO $ getCursorKeyDirections win
|
||||
(jxrot, jyrot) <- liftIO $ getJoystickDirections GLFW.Joystick'1
|
||||
@@ -249,6 +266,7 @@ run = do
|
||||
{ stateXAngle = stateXAngle state + (2 * kxrot) + (2 * jxrot)
|
||||
, stateYAngle = stateYAngle state + (2 * kyrot) + (2 * jyrot)
|
||||
}
|
||||
|
||||
{-
|
||||
--modify the state with all that happened in mt time.
|
||||
mt <- liftIO GLFW.getTime
|
||||
@@ -376,37 +394,44 @@ draw :: Pioneer ()
|
||||
draw = do
|
||||
env <- ask
|
||||
state <- get
|
||||
let xa = stateXAngle state
|
||||
ya = stateYAngle state
|
||||
let xa = fromRational $ toRational $ stateXAngle state
|
||||
ya = fromRational $ toRational $ stateYAngle state
|
||||
za = stateZAngle state
|
||||
(GL.UniformLocation proj) = shdrProjMatIndex state
|
||||
ci = shdrColorIndex state
|
||||
ni = shdrNormalIndex state
|
||||
(GL.UniformLocation vmat) = shdrViewMatIndex state
|
||||
vi = shdrVertexIndex state
|
||||
ni = shdrNormalIndex state
|
||||
ci = shdrColorIndex state
|
||||
numVert = mapVert state
|
||||
map' = stateMap state
|
||||
frust = stateFrustum state
|
||||
liftIO $ do
|
||||
GLRaw.glClearDepth 1.0
|
||||
GLRaw.glDisable GLRaw.gl_CULL_FACE
|
||||
--lookAtUniformMatrix4fv (0.0,0.0,0.0) (0, 15, 0) up frust proj 1
|
||||
--(vi,GL.UniformLocation proj) <- initShader
|
||||
GL.clearColor GL.$= GL.Color4 0.5 0.1 1 1
|
||||
GL.clear [GL.ColorBuffer, GL.DepthBuffer]
|
||||
--set up projection (= copy from state)
|
||||
with (distribute $ frust) $ \ptr ->
|
||||
glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
|
||||
|
||||
-------------
|
||||
--set up camera
|
||||
|
||||
let fov = 90
|
||||
s = recip (tan $ fov * 0.5 * pi / 180)
|
||||
f = 1000
|
||||
n = 1
|
||||
let ! cam = lookAt (cpos ^+^ at') at' up
|
||||
|
||||
let perspective = V.fromList [ s, 0, 0, 0
|
||||
, 0, s, 0, 0
|
||||
, 0, 0, -(f/(f - n)), -1
|
||||
, 0, 0, -((f*n)/(f-n)), 0
|
||||
]
|
||||
at' = V3 5 0 5
|
||||
upmap = (fromQuaternion $
|
||||
axisAngle (V3 0 1 0) (ya::CFloat) :: M33 CFloat)
|
||||
!* (V3 1 0 0)
|
||||
crot' = (
|
||||
(fromQuaternion $
|
||||
axisAngle upmap (xa::CFloat))
|
||||
!*!
|
||||
(fromQuaternion $
|
||||
axisAngle (V3 0 1 0) (ya::CFloat))
|
||||
) :: M33 CFloat
|
||||
cpos = crot' !* (V3 0 0 (-10))
|
||||
|
||||
V.unsafeWith perspective $ \ptr -> GLRaw.glUniformMatrix4fv proj 1 0 ptr
|
||||
|
||||
---------------
|
||||
with (distribute $ cam) $ \ptr ->
|
||||
glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
|
||||
|
||||
GL.bindBuffer GL.ArrayBuffer GL.$= Just map'
|
||||
GL.vertexAttribPointer ci GL.$= fgColorIndex
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverloadedStrings, BangPatterns #-}
|
||||
module Map.Map
|
||||
|
||||
(
|
||||
@@ -47,40 +47,38 @@ lineHeight :: GLfloat
|
||||
lineHeight = 0.8660254
|
||||
|
||||
numComponents :: Int
|
||||
numComponents = 4 --color
|
||||
+3 --normal
|
||||
+3 --vertex
|
||||
numComponents = 10
|
||||
|
||||
mapStride :: Stride
|
||||
mapStride = fromIntegral (sizeOf (0.0 :: GLfloat)) * fromIntegral numComponents
|
||||
mapStride = fromIntegral (sizeOf (0.0 :: GLfloat) * numComponents)
|
||||
|
||||
bufferObjectPtr :: Integral a => a -> Ptr b
|
||||
bufferObjectPtr = plusPtr (nullPtr :: Ptr GLchar) . fromIntegral
|
||||
bufferObjectPtr :: Integral a => a -> Ptr GLfloat
|
||||
bufferObjectPtr = plusPtr (nullPtr :: Ptr GLfloat) . fromIntegral
|
||||
|
||||
mapVertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor a
|
||||
mapVertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor GLfloat
|
||||
mapVertexArrayDescriptor count' offset =
|
||||
VertexArrayDescriptor count' Float mapStride (bufferObjectPtr (fromIntegral numComponents * offset))
|
||||
VertexArrayDescriptor count' Float mapStride (bufferObjectPtr ((fromIntegral offset)*sizeOf (0 :: GLfloat)) ) --(fromIntegral numComponents * offset))
|
||||
|
||||
fgColorIndex :: (IntegerHandling, VertexArrayDescriptor a)
|
||||
fgColorIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
|
||||
fgColorIndex = (ToFloat, mapVertexArrayDescriptor 4 0) --color first
|
||||
|
||||
fgNormalIndex :: (IntegerHandling, VertexArrayDescriptor a)
|
||||
fgNormalIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
|
||||
fgNormalIndex = (ToFloat, mapVertexArrayDescriptor 3 4) --normal after color
|
||||
|
||||
fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor a)
|
||||
fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
|
||||
fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal
|
||||
|
||||
getMapBufferObject :: IO (BufferObject, NumArrayIndices)
|
||||
getMapBufferObject = do
|
||||
map' <- testmap
|
||||
map' <- return $ generateTriangles map'
|
||||
! map' <- return $ P.map (*1) (generateTriangles map')
|
||||
putStrLn $ P.unlines $ P.map show (prettyMap map')
|
||||
len <- return $ fromIntegral $ P.length map' `div` numComponents
|
||||
putStrLn $ P.unwords ["num verts",show len]
|
||||
bo <- genObjectName -- create a new buffer
|
||||
bindBuffer ArrayBuffer $= Just bo -- bind buffer
|
||||
withArray map' $ \buffer ->
|
||||
bufferData ArrayBuffer $= (fromIntegral $ sizeOf (0 :: Float)*P.length map',
|
||||
bufferData ArrayBuffer $= (fromIntegral $ sizeOf (0 :: GLfloat)*P.length map',
|
||||
buffer,
|
||||
StaticDraw)
|
||||
checkError "initBuffer"
|
||||
@@ -90,6 +88,51 @@ prettyMap :: [GLfloat] -> [(GLfloat,GLfloat,GLfloat,GLfloat,GLfloat,GLfloat,GLfl
|
||||
prettyMap (a:b:c:d:x:y:z:u:v:w:ms) = (a,b,c,d,x,y,z,u,v,w):(prettyMap ms)
|
||||
prettyMap _ = []
|
||||
|
||||
generateCube :: [GLfloat]
|
||||
generateCube = [ -- lower plane
|
||||
-3.0,-3.0,-3.0,
|
||||
3.0,-3.0,3.0,
|
||||
3.0,-3.0,-3.0,
|
||||
-3.0,-3.0,-3.0,
|
||||
-3.0,-3.0,3.0,
|
||||
3.0,-3.0,3.0,
|
||||
-- upper plane
|
||||
-3.0,3.0,-3.0,
|
||||
3.0,3.0,3.0,
|
||||
3.0,3.0,-3.0,
|
||||
-3.0,3.0,-3.0,
|
||||
-3.0,3.0,3.0,
|
||||
3.0,3.0,3.0,
|
||||
-- left plane
|
||||
-3.0,-3.0,-3.0,
|
||||
-3.0,3.0,3.0,
|
||||
-3.0,-3.0,3.0,
|
||||
-3.0,-3.0,-3.0,
|
||||
-3.0,3.0,3.0,
|
||||
-3.0,3.0,-3.0,
|
||||
-- right plane
|
||||
3.0,-3.0,-3.0,
|
||||
3.0,3.0,3.0,
|
||||
3.0,-3.0,3.0,
|
||||
3.0,-3.0,-3.0,
|
||||
3.0,3.0,3.0,
|
||||
3.0,3.0,-3.0,
|
||||
-- front plane
|
||||
-3.0,-3.0,-3.0,
|
||||
3.0,3.0,-3.0,
|
||||
3.0,-3.0,-3.0,
|
||||
-3.0,-3.0,-3.0,
|
||||
3.0,3.0,-3.0,
|
||||
-3.0,3.0,-3.0,
|
||||
-- back plane
|
||||
-3.0,-3.0,3.0,
|
||||
3.0,3.0,3.0,
|
||||
3.0,-3.0,3.0,
|
||||
-3.0,-3.0,3.0,
|
||||
3.0,3.0,3.0,
|
||||
-3.0,3.0,3.0
|
||||
]
|
||||
|
||||
generateTriangles :: PlayMap -> [GLfloat]
|
||||
generateTriangles map' =
|
||||
let ((xl,yl),(xh,yh)) = bounds map' in
|
||||
@@ -161,7 +204,7 @@ coordLookup (x,z) y =
|
||||
if even x then
|
||||
(fromIntegral $ x `div` 2, y, fromIntegral (2 * z) * lineHeight)
|
||||
else
|
||||
(fromIntegral (x `div` 2) / 2.0, y, fromIntegral (2 * z + 1) * lineHeight)
|
||||
(fromIntegral (x `div` 2) + 0.5, y, fromIntegral (2 * z + 1) * lineHeight)
|
||||
|
||||
|
||||
-- if writing in ASCII-Format transpose so i,j -> y,x
|
||||
@@ -192,14 +235,20 @@ testMapTemplate = T.transpose [
|
||||
|
||||
testMapTemplate2 :: [Text]
|
||||
testMapTemplate2 = T.transpose [
|
||||
"~~~~~~"
|
||||
"~~~~~~~~~~~~"
|
||||
]
|
||||
|
||||
testmap :: IO PlayMap
|
||||
testmap = do
|
||||
g <- getStdGen
|
||||
rawMap <- return $ parseTemplate (randoms g) (T.concat testMapTemplate)
|
||||
return $ listArray ((0,0),(19,19)) rawMap
|
||||
|
||||
testmap2 :: IO PlayMap
|
||||
testmap2 = do
|
||||
g <- getStdGen
|
||||
rawMap <- return $ parseTemplate (randoms g) (T.concat testMapTemplate2)
|
||||
return $ listArray ((0,0),(5,0)) rawMap
|
||||
return $ listArray ((0,0),(9,0)) rawMap
|
||||
|
||||
|
||||
parseTemplate :: [Int] -> Text -> [MapEntry]
|
||||
|
||||
@@ -4,16 +4,17 @@ import Control.Monad
|
||||
import qualified Data.ByteString as B (ByteString)
|
||||
import Foreign.Marshal.Array (allocaArray,
|
||||
pokeArray)
|
||||
import Foreign.C (CFloat)
|
||||
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.Raw.Core31
|
||||
import System.IO (hPutStrLn, stderr)
|
||||
import Linear
|
||||
|
||||
|
||||
up :: (Double, Double, Double)
|
||||
up = (0.0, 1.0, 1.0)
|
||||
up :: V3 CFloat
|
||||
up = V3 0 1 0
|
||||
|
||||
checkError :: String -> IO ()
|
||||
checkError functionName = get errors >>= mapM_ reportError
|
||||
@@ -58,16 +59,21 @@ createProgramUsing shaders = do
|
||||
linkAndCheck program
|
||||
return program
|
||||
|
||||
createFrustum :: Float -> Float -> Float -> Float -> [GLfloat]
|
||||
createFrustum fov n f rat =
|
||||
let s = recip (tan $ fov*0.5 * pi / 180) in
|
||||
|
||||
map (fromRational . toRational) [
|
||||
rat*s,0,0,0,
|
||||
0,rat*s,0,0,
|
||||
0,0,-(f/(f-n)), -1,
|
||||
0,0,-((f*n)/(f-n)), 1
|
||||
]
|
||||
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)
|
||||
|
||||
lookAtUniformMatrix4fv :: (Double, Double, Double) --origin
|
||||
-> (Double, Double, Double) --camera-pos
|
||||
@@ -126,9 +132,23 @@ infixl 5 ><
|
||||
]
|
||||
_ >< _ = error "non-conformat matrix-multiplication"
|
||||
|
||||
|
||||
-- from vmath.h
|
||||
lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat
|
||||
lookAt eye@(V3 ex ey ez) 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)
|
||||
|
||||
-- generates 4x4-Projection-Matrix
|
||||
lookAt :: (Double, Double, Double) -> (Double, Double, Double) -> (Double, Double, Double) -> [GLfloat]
|
||||
lookAt at eye up =
|
||||
lookAt_ :: (Double, Double, Double) -> (Double, Double, Double) -> (Double, Double, Double) -> [GLfloat]
|
||||
lookAt_ at eye up =
|
||||
map (fromRational . toRational) [
|
||||
xx, yx, zx, 0,
|
||||
xy, yy, zy, 0,
|
||||
|
||||
@@ -7,12 +7,13 @@ import Foreign.Storable (sizeOf)
|
||||
import Graphics.Rendering.OpenGL.GL.BufferObjects
|
||||
import Graphics.Rendering.OpenGL.GL.Framebuffer (clearColor)
|
||||
import Graphics.Rendering.OpenGL.GL.ObjectName
|
||||
import Graphics.Rendering.OpenGL.GL.PerFragment
|
||||
import Graphics.Rendering.OpenGL.GL.Shaders
|
||||
import Graphics.Rendering.OpenGL.GL.StateVar
|
||||
import Graphics.Rendering.OpenGL.GL.VertexArrays (Capability (..),
|
||||
vertexAttribArray)
|
||||
import Graphics.Rendering.OpenGL.GL.VertexSpec
|
||||
import Graphics.Rendering.OpenGL.Raw.Core31.Types (GLfloat)
|
||||
import Graphics.Rendering.OpenGL.Raw.Core31
|
||||
import Render.Misc
|
||||
|
||||
vertexShaderFile :: String
|
||||
@@ -33,7 +34,7 @@ initBuffer varray =
|
||||
checkError "initBuffer"
|
||||
return bufferObject
|
||||
|
||||
initShader :: IO (AttribLocation, AttribLocation, AttribLocation, UniformLocation)
|
||||
initShader :: IO (AttribLocation, AttribLocation, AttribLocation, UniformLocation, UniformLocation, UniformLocation)
|
||||
initShader = do
|
||||
! vertexSource <- B.readFile vertexShaderFile
|
||||
! fragmentSource <- B.readFile fragmentShaderFile
|
||||
@@ -49,22 +50,35 @@ initShader = do
|
||||
projectionMatrixIndex <- get (uniformLocation program "fg_ProjectionMatrix")
|
||||
checkError "projMat"
|
||||
|
||||
colorIndex <- get (attribLocation program "fg_Color")
|
||||
vertexAttribArray colorIndex $= Enabled
|
||||
checkError "colorInd"
|
||||
viewMatrixIndex <- get (uniformLocation program "fg_ViewMatrix")
|
||||
checkError "viewMat"
|
||||
|
||||
normalIndex <- get (attribLocation program "fg_Normal")
|
||||
vertexAttribArray normalIndex $= Enabled
|
||||
checkError "normalInd"
|
||||
modelMatrixIndex <- get (uniformLocation program "fg_ModelMatrix")
|
||||
checkError "modelMat"
|
||||
|
||||
vertexIndex <- get (attribLocation program "fg_VertexIn")
|
||||
vertexAttribArray vertexIndex $= Enabled
|
||||
checkError "vertexInd"
|
||||
|
||||
normalIndex <- get (attribLocation program "fg_NormalIn")
|
||||
vertexAttribArray normalIndex $= Enabled
|
||||
checkError "normalInd"
|
||||
|
||||
colorIndex <- get (attribLocation program "fg_Color")
|
||||
vertexAttribArray colorIndex $= Enabled
|
||||
checkError "colorInd"
|
||||
|
||||
att <- get (activeAttribs program)
|
||||
|
||||
putStrLn $ unlines $ "Attributes: ":map show att
|
||||
putStrLn $ unlines $ ["Indices: ", show (colorIndex, normalIndex, vertexIndex)]
|
||||
|
||||
checkError "initShader"
|
||||
return (colorIndex, normalIndex, vertexIndex, projectionMatrixIndex)
|
||||
return (colorIndex, normalIndex, vertexIndex, projectionMatrixIndex, viewMatrixIndex, modelMatrixIndex)
|
||||
|
||||
initRendering :: IO ()
|
||||
initRendering = do
|
||||
clearColor $= Color4 0 0 0 0
|
||||
depthFunc $= Just Less
|
||||
glCullFace gl_BACK
|
||||
checkError "initRendering"
|
||||
|
||||
660
test2.hs
Normal file
660
test2.hs
Normal file
@@ -0,0 +1,660 @@
|
||||
module Main (main) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Control.Concurrent.STM (TQueue, atomically, newTQueueIO, tryReadTQueue, writeTQueue)
|
||||
import Control.Monad (unless, when, void)
|
||||
import Control.Monad.RWS.Strict (RWST, ask, asks, evalRWST, get, liftIO, modify, put)
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
|
||||
import Data.List (intercalate)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Text.PrettyPrint
|
||||
import Control.Applicative
|
||||
import Control.Lens
|
||||
import Control.Monad (forever)
|
||||
import Data.Distributive (distribute)
|
||||
import Foreign (Ptr, castPtr, nullPtr, sizeOf, with)
|
||||
import Foreign.C (CFloat)
|
||||
|
||||
import Graphics.Rendering.OpenGL (($=))
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
import qualified Graphics.Rendering.OpenGL.Raw as GL
|
||||
import qualified Graphics.UI.GLFW as GLFW
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
import qualified Data.Vector.Storable as V
|
||||
import Linear as L
|
||||
import Linear ((!*!))
|
||||
|
||||
import Data.IORef
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Env = Env
|
||||
{ envEventsChan :: TQueue Event
|
||||
, envWindow :: !GLFW.Window
|
||||
, envGear1 :: !GL.DisplayList
|
||||
, envGear2 :: !GL.DisplayList
|
||||
, envGear3 :: !GL.DisplayList
|
||||
, envZDistClosest :: !Double
|
||||
, envZDistFarthest :: !Double
|
||||
}
|
||||
|
||||
data State = State
|
||||
{ stateWindowWidth :: !Int
|
||||
, stateWindowHeight :: !Int
|
||||
, stateXAngle :: !Double
|
||||
, stateYAngle :: !Double
|
||||
, stateZAngle :: !Double
|
||||
, stateGearZAngle :: !Double
|
||||
, stateZDist :: !Double
|
||||
, stateMouseDown :: !Bool
|
||||
, stateDragging :: !Bool
|
||||
, stateDragStartX :: !Double
|
||||
, stateDragStartY :: !Double
|
||||
, stateDragStartXAngle :: !Double
|
||||
, stateDragStartYAngle :: !Double
|
||||
}
|
||||
|
||||
type Demo = RWST Env () State IO
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Event =
|
||||
EventError !GLFW.Error !String
|
||||
| EventWindowPos !GLFW.Window !Int !Int
|
||||
| EventWindowSize !GLFW.Window !Int !Int
|
||||
| EventWindowClose !GLFW.Window
|
||||
| EventWindowRefresh !GLFW.Window
|
||||
| EventWindowFocus !GLFW.Window !GLFW.FocusState
|
||||
| EventWindowIconify !GLFW.Window !GLFW.IconifyState
|
||||
| EventFramebufferSize !GLFW.Window !Int !Int
|
||||
| EventMouseButton !GLFW.Window !GLFW.MouseButton !GLFW.MouseButtonState !GLFW.ModifierKeys
|
||||
| EventCursorPos !GLFW.Window !Double !Double
|
||||
| EventCursorEnter !GLFW.Window !GLFW.CursorState
|
||||
| EventScroll !GLFW.Window !Double !Double
|
||||
| EventKey !GLFW.Window !GLFW.Key !Int !GLFW.KeyState !GLFW.ModifierKeys
|
||||
| EventChar !GLFW.Window !Char
|
||||
deriving Show
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
triangleTransformation :: (Epsilon a, Floating a) => a -> M44 a
|
||||
triangleTransformation =
|
||||
liftA2 (!*!) triangleTranslation triangleRotation
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
triangleRotation :: (Epsilon a, Floating a) => a -> M44 a
|
||||
triangleRotation t =
|
||||
m33_to_m44 $
|
||||
fromQuaternion $
|
||||
axisAngle (V3 0 1 0) (t * 2)
|
||||
|
||||
triangleTranslation :: Floating a => a -> M44 a
|
||||
triangleTranslation t =
|
||||
eye4 & translation .~ V3 (sin t * 2) 0 (-5)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
let width = 640
|
||||
height = 480
|
||||
|
||||
eventsChan <- newTQueueIO :: IO (TQueue Event)
|
||||
|
||||
withWindow width height "GLFW-b-demo" $ \win -> do
|
||||
let z = 0
|
||||
let vertices = V.fromList [ 0, 1, 0
|
||||
, -1, -1, z
|
||||
, 1, -1, z ] :: V.Vector Float
|
||||
vertexAttribute = GL.AttribLocation 0
|
||||
|
||||
cubeVbo <- GL.genObjectName
|
||||
|
||||
GL.bindBuffer GL.ArrayBuffer $= Just cubeVbo
|
||||
|
||||
V.unsafeWith vertices $ \v -> GL.bufferData GL.ArrayBuffer $=
|
||||
(fromIntegral $ V.length vertices * sizeOf (0 :: Float), v, GL.StaticDraw)
|
||||
|
||||
GL.vertexAttribPointer vertexAttribute $=
|
||||
(GL.ToFloat, GL.VertexArrayDescriptor 3 GL.Float 0 nullPtr)
|
||||
|
||||
GL.vertexAttribArray vertexAttribute $= GL.Enabled
|
||||
GL.bindBuffer GL.ArrayBuffer $= Just cubeVbo
|
||||
|
||||
vertexShader <- GL.createShader GL.VertexShader
|
||||
fragmentShader <- GL.createShader GL.FragmentShader
|
||||
|
||||
GL.shaderSourceBS vertexShader $= Text.encodeUtf8
|
||||
(Text.pack $ unlines
|
||||
[ "#version 130"
|
||||
, "uniform mat4 projection;"
|
||||
, "uniform mat4 model;"
|
||||
, "in vec3 in_Position;"
|
||||
, "void main(void) {"
|
||||
, " gl_Position = projection * model * vec4(in_Position, 1.0);"
|
||||
, "}"
|
||||
])
|
||||
|
||||
GL.shaderSourceBS fragmentShader $= Text.encodeUtf8
|
||||
(Text.pack $ unlines
|
||||
[ "#version 130"
|
||||
, "out vec4 fragColor;"
|
||||
, "void main(void) {"
|
||||
, " fragColor = vec4(1.0,1.0,1.0,1.0);"
|
||||
, "}"
|
||||
])
|
||||
|
||||
GL.compileShader vertexShader
|
||||
GL.compileShader fragmentShader
|
||||
|
||||
shaderProg <- GL.createProgram
|
||||
GL.attachShader shaderProg vertexShader
|
||||
GL.attachShader shaderProg fragmentShader
|
||||
GL.attribLocation shaderProg "in_Position" $= vertexAttribute
|
||||
GL.linkProgram shaderProg
|
||||
GL.currentProgram $= Just shaderProg
|
||||
|
||||
let fov = 90
|
||||
s = recip (tan $ fov * 0.5 * pi / 180)
|
||||
f = 1000
|
||||
n = 1
|
||||
|
||||
let perspective = V.fromList [ s, 0, 0, 0
|
||||
, 0, s, 0, 0
|
||||
, 0, 0, -(f/(f - n)), -1
|
||||
, 0, 0, -((f*n)/(f-n)), 0
|
||||
]
|
||||
|
||||
GL.UniformLocation loc <- GL.get (GL.uniformLocation shaderProg "projection")
|
||||
V.unsafeWith perspective $ \ptr -> GL.glUniformMatrix4fv loc 1 0 ptr
|
||||
|
||||
tr <- newIORef 0
|
||||
forever $ do
|
||||
t <- readIORef tr
|
||||
|
||||
GL.clearColor $= GL.Color4 0.5 0.2 1 1
|
||||
GL.clear [GL.ColorBuffer]
|
||||
|
||||
GL.UniformLocation loc <- GL.get (GL.uniformLocation shaderProg "model")
|
||||
with (distribute $ triangleTransformation t) $ \ptr ->
|
||||
GL.glUniformMatrix4fv loc 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
|
||||
|
||||
GL.drawArrays GL.Triangles 0 3
|
||||
|
||||
GLFW.swapBuffers win
|
||||
writeIORef tr (t + 0.1)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- GLFW-b is made to be very close to the C API, so creating a window is pretty
|
||||
-- clunky by Haskell standards. A higher-level API would have some function
|
||||
-- like withWindow.
|
||||
|
||||
withWindow :: Int -> Int -> String -> (GLFW.Window -> IO ()) -> IO ()
|
||||
withWindow width height title f = do
|
||||
GLFW.setErrorCallback $ Just simpleErrorCallback
|
||||
r <- GLFW.init
|
||||
when r $ do
|
||||
m <- GLFW.createWindow width height title Nothing Nothing
|
||||
case m of
|
||||
(Just win) -> do
|
||||
GLFW.makeContextCurrent m
|
||||
f win
|
||||
GLFW.setErrorCallback $ Just simpleErrorCallback
|
||||
GLFW.destroyWindow win
|
||||
Nothing -> return ()
|
||||
GLFW.terminate
|
||||
where
|
||||
simpleErrorCallback e s =
|
||||
putStrLn $ unwords [show e, show s]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- Each callback does just one thing: write an appropriate Event to the events
|
||||
-- TQueue.
|
||||
|
||||
errorCallback :: TQueue Event -> GLFW.Error -> String -> IO ()
|
||||
windowPosCallback :: TQueue Event -> GLFW.Window -> Int -> Int -> IO ()
|
||||
windowSizeCallback :: TQueue Event -> GLFW.Window -> Int -> Int -> IO ()
|
||||
windowCloseCallback :: TQueue Event -> GLFW.Window -> IO ()
|
||||
windowRefreshCallback :: TQueue Event -> GLFW.Window -> IO ()
|
||||
windowFocusCallback :: TQueue Event -> GLFW.Window -> GLFW.FocusState -> IO ()
|
||||
windowIconifyCallback :: TQueue Event -> GLFW.Window -> GLFW.IconifyState -> IO ()
|
||||
framebufferSizeCallback :: TQueue Event -> GLFW.Window -> Int -> Int -> IO ()
|
||||
mouseButtonCallback :: TQueue Event -> GLFW.Window -> GLFW.MouseButton -> GLFW.MouseButtonState -> GLFW.ModifierKeys -> IO ()
|
||||
cursorPosCallback :: TQueue Event -> GLFW.Window -> Double -> Double -> IO ()
|
||||
cursorEnterCallback :: TQueue Event -> GLFW.Window -> GLFW.CursorState -> IO ()
|
||||
scrollCallback :: TQueue Event -> GLFW.Window -> Double -> Double -> IO ()
|
||||
keyCallback :: TQueue Event -> GLFW.Window -> GLFW.Key -> Int -> GLFW.KeyState -> GLFW.ModifierKeys -> IO ()
|
||||
charCallback :: TQueue Event -> GLFW.Window -> Char -> IO ()
|
||||
|
||||
errorCallback tc e s = atomically $ writeTQueue tc $ EventError e s
|
||||
windowPosCallback tc win x y = atomically $ writeTQueue tc $ EventWindowPos win x y
|
||||
windowSizeCallback tc win w h = atomically $ writeTQueue tc $ EventWindowSize win w h
|
||||
windowCloseCallback tc win = atomically $ writeTQueue tc $ EventWindowClose win
|
||||
windowRefreshCallback tc win = atomically $ writeTQueue tc $ EventWindowRefresh win
|
||||
windowFocusCallback tc win fa = atomically $ writeTQueue tc $ EventWindowFocus win fa
|
||||
windowIconifyCallback tc win ia = atomically $ writeTQueue tc $ EventWindowIconify win ia
|
||||
framebufferSizeCallback tc win w h = atomically $ writeTQueue tc $ EventFramebufferSize win w h
|
||||
mouseButtonCallback tc win mb mba mk = atomically $ writeTQueue tc $ EventMouseButton win mb mba mk
|
||||
cursorPosCallback tc win x y = atomically $ writeTQueue tc $ EventCursorPos win x y
|
||||
cursorEnterCallback tc win ca = atomically $ writeTQueue tc $ EventCursorEnter win ca
|
||||
scrollCallback tc win x y = atomically $ writeTQueue tc $ EventScroll win x y
|
||||
keyCallback tc win k sc ka mk = atomically $ writeTQueue tc $ EventKey win k sc ka mk
|
||||
charCallback tc win c = atomically $ writeTQueue tc $ EventChar win c
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
runDemo :: Env -> State -> IO ()
|
||||
runDemo env state = do
|
||||
printInstructions
|
||||
void $ evalRWST (adjustWindow >> run) env state
|
||||
|
||||
run :: Demo ()
|
||||
run = do
|
||||
win <- asks envWindow
|
||||
|
||||
draw
|
||||
liftIO $ do
|
||||
GLFW.swapBuffers win
|
||||
GL.flush -- not necessary, but someone recommended it
|
||||
GLFW.pollEvents
|
||||
processEvents
|
||||
|
||||
state <- get
|
||||
if stateDragging state
|
||||
then do
|
||||
let sodx = stateDragStartX state
|
||||
sody = stateDragStartY state
|
||||
sodxa = stateDragStartXAngle state
|
||||
sodya = stateDragStartYAngle state
|
||||
(x, y) <- liftIO $ GLFW.getCursorPos win
|
||||
let myrot = (x - sodx) / 2
|
||||
mxrot = (y - sody) / 2
|
||||
put $ state
|
||||
{ stateXAngle = sodxa + mxrot
|
||||
, stateYAngle = sodya + myrot
|
||||
}
|
||||
else do
|
||||
(kxrot, kyrot) <- liftIO $ getCursorKeyDirections win
|
||||
(jxrot, jyrot) <- liftIO $ getJoystickDirections GLFW.Joystick'1
|
||||
put $ state
|
||||
{ stateXAngle = stateXAngle state + (2 * kxrot) + (2 * jxrot)
|
||||
, stateYAngle = stateYAngle state + (2 * kyrot) + (2 * jyrot)
|
||||
}
|
||||
|
||||
mt <- liftIO GLFW.getTime
|
||||
modify $ \s -> s
|
||||
{ stateGearZAngle = maybe 0 (realToFrac . (100*)) mt
|
||||
}
|
||||
|
||||
q <- liftIO $ GLFW.windowShouldClose win
|
||||
unless q run
|
||||
|
||||
processEvents :: Demo ()
|
||||
processEvents = do
|
||||
tc <- asks envEventsChan
|
||||
me <- liftIO $ atomically $ tryReadTQueue tc
|
||||
case me of
|
||||
Just e -> do
|
||||
processEvent e
|
||||
processEvents
|
||||
Nothing -> return ()
|
||||
|
||||
processEvent :: Event -> Demo ()
|
||||
processEvent ev =
|
||||
case ev of
|
||||
(EventError e s) -> do
|
||||
printEvent "error" [show e, show s]
|
||||
win <- asks envWindow
|
||||
liftIO $ GLFW.setWindowShouldClose win True
|
||||
|
||||
(EventWindowPos _ x y) ->
|
||||
printEvent "window pos" [show x, show y]
|
||||
|
||||
(EventWindowSize _ width height) ->
|
||||
printEvent "window size" [show width, show height]
|
||||
|
||||
(EventWindowClose _) ->
|
||||
printEvent "window close" []
|
||||
|
||||
(EventWindowRefresh _) ->
|
||||
printEvent "window refresh" []
|
||||
|
||||
(EventWindowFocus _ fs) ->
|
||||
printEvent "window focus" [show fs]
|
||||
|
||||
(EventWindowIconify _ is) ->
|
||||
printEvent "window iconify" [show is]
|
||||
|
||||
(EventFramebufferSize _ width height) -> do
|
||||
printEvent "framebuffer size" [show width, show height]
|
||||
modify $ \s -> s
|
||||
{ stateWindowWidth = width
|
||||
, stateWindowHeight = height
|
||||
}
|
||||
adjustWindow
|
||||
|
||||
(EventMouseButton _ mb mbs mk) -> do
|
||||
printEvent "mouse button" [show mb, show mbs, showModifierKeys mk]
|
||||
when (mb == GLFW.MouseButton'1) $ do
|
||||
let pressed = mbs == GLFW.MouseButtonState'Pressed
|
||||
modify $ \s -> s
|
||||
{ stateMouseDown = pressed
|
||||
}
|
||||
unless pressed $
|
||||
modify $ \s -> s
|
||||
{ stateDragging = False
|
||||
}
|
||||
|
||||
(EventCursorPos _ x y) -> do
|
||||
let x' = round x :: Int
|
||||
y' = round y :: Int
|
||||
printEvent "cursor pos" [show x', show y']
|
||||
state <- get
|
||||
when (stateMouseDown state && not (stateDragging state)) $
|
||||
put $ state
|
||||
{ stateDragging = True
|
||||
, stateDragStartX = x
|
||||
, stateDragStartY = y
|
||||
, stateDragStartXAngle = stateXAngle state
|
||||
, stateDragStartYAngle = stateYAngle state
|
||||
}
|
||||
|
||||
(EventCursorEnter _ cs) ->
|
||||
printEvent "cursor enter" [show cs]
|
||||
|
||||
(EventScroll _ x y) -> do
|
||||
let x' = round x :: Int
|
||||
y' = round y :: Int
|
||||
printEvent "scroll" [show x', show y']
|
||||
env <- ask
|
||||
modify $ \s -> s
|
||||
{ stateZDist =
|
||||
let zDist' = stateZDist s + realToFrac (negate $ y / 2)
|
||||
in curb (envZDistClosest env) (envZDistFarthest env) zDist'
|
||||
}
|
||||
adjustWindow
|
||||
|
||||
(EventKey win k scancode ks mk) -> do
|
||||
printEvent "key" [show k, show scancode, show ks, showModifierKeys mk]
|
||||
when (ks == GLFW.KeyState'Pressed) $ do
|
||||
-- Q, Esc: exit
|
||||
when (k == GLFW.Key'Q || k == GLFW.Key'Escape) $
|
||||
liftIO $ GLFW.setWindowShouldClose win True
|
||||
-- ?: print instructions
|
||||
when (k == GLFW.Key'Slash && GLFW.modifierKeysShift mk) $
|
||||
liftIO printInstructions
|
||||
-- i: print GLFW information
|
||||
when (k == GLFW.Key'I) $
|
||||
liftIO $ printInformation win
|
||||
|
||||
(EventChar _ c) ->
|
||||
printEvent "char" [show c]
|
||||
|
||||
adjustWindow :: Demo ()
|
||||
adjustWindow = do
|
||||
state <- get
|
||||
let width = stateWindowWidth state
|
||||
height = stateWindowHeight state
|
||||
zDist = stateZDist state
|
||||
|
||||
let pos = GL.Position 0 0
|
||||
size = GL.Size (fromIntegral width) (fromIntegral height)
|
||||
h = fromIntegral height / fromIntegral width :: Double
|
||||
znear = 1 :: Double
|
||||
zfar = 40 :: Double
|
||||
xmax = znear * 0.5 :: Double
|
||||
liftIO $ do
|
||||
GL.viewport GL.$= (pos, size)
|
||||
GL.matrixMode GL.$= GL.Projection
|
||||
GL.loadIdentity
|
||||
GL.frustum (realToFrac $ -xmax)
|
||||
(realToFrac xmax)
|
||||
(realToFrac $ -xmax * realToFrac h)
|
||||
(realToFrac $ xmax * realToFrac h)
|
||||
(realToFrac znear)
|
||||
(realToFrac zfar)
|
||||
GL.matrixMode GL.$= GL.Modelview 0
|
||||
GL.loadIdentity
|
||||
GL.translate (GL.Vector3 0 0 (negate $ realToFrac zDist) :: GL.Vector3 GL.GLfloat)
|
||||
|
||||
draw :: Demo ()
|
||||
draw = do
|
||||
env <- ask
|
||||
state <- get
|
||||
let gear1 = envGear1 env
|
||||
gear2 = envGear2 env
|
||||
gear3 = envGear3 env
|
||||
xa = stateXAngle state
|
||||
ya = stateYAngle state
|
||||
za = stateZAngle state
|
||||
ga = stateGearZAngle state
|
||||
liftIO $ do
|
||||
GL.clear [GL.ColorBuffer, GL.DepthBuffer]
|
||||
GL.preservingMatrix $ do
|
||||
GL.rotate (realToFrac xa) xunit
|
||||
GL.rotate (realToFrac ya) yunit
|
||||
GL.rotate (realToFrac za) zunit
|
||||
GL.preservingMatrix $ do
|
||||
GL.translate gear1vec
|
||||
GL.rotate (realToFrac ga) zunit
|
||||
GL.callList gear1
|
||||
GL.preservingMatrix $ do
|
||||
GL.translate gear2vec
|
||||
GL.rotate (-2 * realToFrac ga - 9) zunit
|
||||
GL.callList gear2
|
||||
GL.preservingMatrix $ do
|
||||
GL.translate gear3vec
|
||||
GL.rotate (-2 * realToFrac ga - 25) zunit
|
||||
GL.callList gear3
|
||||
where
|
||||
gear1vec = GL.Vector3 (-3) (-2) 0 :: GL.Vector3 GL.GLfloat
|
||||
gear2vec = GL.Vector3 3.1 (-2) 0 :: GL.Vector3 GL.GLfloat
|
||||
gear3vec = GL.Vector3 (-3.1) 4.2 0 :: GL.Vector3 GL.GLfloat
|
||||
xunit = GL.Vector3 1 0 0 :: GL.Vector3 GL.GLfloat
|
||||
yunit = GL.Vector3 0 1 0 :: GL.Vector3 GL.GLfloat
|
||||
zunit = GL.Vector3 0 0 1 :: GL.Vector3 GL.GLfloat
|
||||
|
||||
getCursorKeyDirections :: GLFW.Window -> IO (Double, Double)
|
||||
getCursorKeyDirections win = do
|
||||
x0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Up
|
||||
x1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Down
|
||||
y0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Left
|
||||
y1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Right
|
||||
let x0n = if x0 then (-1) else 0
|
||||
x1n = if x1 then 1 else 0
|
||||
y0n = if y0 then (-1) else 0
|
||||
y1n = if y1 then 1 else 0
|
||||
return (x0n + x1n, y0n + y1n)
|
||||
|
||||
getJoystickDirections :: GLFW.Joystick -> IO (Double, Double)
|
||||
getJoystickDirections js = do
|
||||
maxes <- GLFW.getJoystickAxes js
|
||||
return $ case maxes of
|
||||
(Just (x:y:_)) -> (-y, x)
|
||||
_ -> ( 0, 0)
|
||||
|
||||
isPress :: GLFW.KeyState -> Bool
|
||||
isPress GLFW.KeyState'Pressed = True
|
||||
isPress GLFW.KeyState'Repeating = True
|
||||
isPress _ = False
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
printInstructions :: IO ()
|
||||
printInstructions =
|
||||
putStrLn $ render $
|
||||
nest 4 (
|
||||
text "------------------------------------------------------------" $+$
|
||||
text "'?': Print these instructions" $+$
|
||||
text "'i': Print GLFW information" $+$
|
||||
text "" $+$
|
||||
text "* Mouse cursor, keyboard cursor keys, and/or joystick" $+$
|
||||
text " control rotation." $+$
|
||||
text "* Mouse scroll wheel controls distance from scene." $+$
|
||||
text "------------------------------------------------------------"
|
||||
)
|
||||
|
||||
printInformation :: GLFW.Window -> IO ()
|
||||
printInformation win = do
|
||||
version <- GLFW.getVersion
|
||||
versionString <- GLFW.getVersionString
|
||||
monitorInfos <- runMaybeT getMonitorInfos
|
||||
joystickNames <- getJoystickNames
|
||||
clientAPI <- GLFW.getWindowClientAPI win
|
||||
cv0 <- GLFW.getWindowContextVersionMajor win
|
||||
cv1 <- GLFW.getWindowContextVersionMinor win
|
||||
cv2 <- GLFW.getWindowContextVersionRevision win
|
||||
robustness <- GLFW.getWindowContextRobustness win
|
||||
forwardCompat <- GLFW.getWindowOpenGLForwardCompat win
|
||||
debug <- GLFW.getWindowOpenGLDebugContext win
|
||||
profile <- GLFW.getWindowOpenGLProfile win
|
||||
|
||||
putStrLn $ render $
|
||||
nest 4 (
|
||||
text "------------------------------------------------------------" $+$
|
||||
text "GLFW C library:" $+$
|
||||
nest 4 (
|
||||
text "Version:" <+> renderVersion version $+$
|
||||
text "Version string:" <+> renderVersionString versionString
|
||||
) $+$
|
||||
text "Monitors:" $+$
|
||||
nest 4 (
|
||||
renderMonitorInfos monitorInfos
|
||||
) $+$
|
||||
text "Joysticks:" $+$
|
||||
nest 4 (
|
||||
renderJoystickNames joystickNames
|
||||
) $+$
|
||||
text "OpenGL context:" $+$
|
||||
nest 4 (
|
||||
text "Client API:" <+> renderClientAPI clientAPI $+$
|
||||
text "Version:" <+> renderContextVersion cv0 cv1 cv2 $+$
|
||||
text "Robustness:" <+> renderContextRobustness robustness $+$
|
||||
text "Forward compatibility:" <+> renderForwardCompat forwardCompat $+$
|
||||
text "Debug:" <+> renderDebug debug $+$
|
||||
text "Profile:" <+> renderProfile profile
|
||||
) $+$
|
||||
text "------------------------------------------------------------"
|
||||
)
|
||||
where
|
||||
renderVersion (GLFW.Version v0 v1 v2) =
|
||||
text $ intercalate "." $ map show [v0, v1, v2]
|
||||
|
||||
renderVersionString =
|
||||
text . show
|
||||
|
||||
renderMonitorInfos =
|
||||
maybe (text "(error)") (vcat . map renderMonitorInfo)
|
||||
|
||||
renderMonitorInfo (name, (x,y), (w,h), vms) =
|
||||
text (show name) $+$
|
||||
nest 4 (
|
||||
location <+> size $+$
|
||||
fsep (map renderVideoMode vms)
|
||||
)
|
||||
where
|
||||
location = int x <> text "," <> int y
|
||||
size = int w <> text "x" <> int h <> text "mm"
|
||||
|
||||
renderVideoMode (GLFW.VideoMode w h r g b rr) =
|
||||
brackets $ res <+> rgb <+> hz
|
||||
where
|
||||
res = int w <> text "x" <> int h
|
||||
rgb = int r <> text "x" <> int g <> text "x" <> int b
|
||||
hz = int rr <> text "Hz"
|
||||
|
||||
renderJoystickNames pairs =
|
||||
vcat $ map (\(js, name) -> text (show js) <+> text (show name)) pairs
|
||||
|
||||
renderContextVersion v0 v1 v2 =
|
||||
hcat [int v0, text ".", int v1, text ".", int v2]
|
||||
|
||||
renderClientAPI = text . show
|
||||
renderContextRobustness = text . show
|
||||
renderForwardCompat = text . show
|
||||
renderDebug = text . show
|
||||
renderProfile = text . show
|
||||
|
||||
type MonitorInfo = (String, (Int,Int), (Int,Int), [GLFW.VideoMode])
|
||||
|
||||
getMonitorInfos :: MaybeT IO [MonitorInfo]
|
||||
getMonitorInfos =
|
||||
getMonitors >>= mapM getMonitorInfo
|
||||
where
|
||||
getMonitors :: MaybeT IO [GLFW.Monitor]
|
||||
getMonitors = MaybeT GLFW.getMonitors
|
||||
|
||||
getMonitorInfo :: GLFW.Monitor -> MaybeT IO MonitorInfo
|
||||
getMonitorInfo mon = do
|
||||
name <- getMonitorName mon
|
||||
vms <- getVideoModes mon
|
||||
MaybeT $ do
|
||||
pos <- liftIO $ GLFW.getMonitorPos mon
|
||||
size <- liftIO $ GLFW.getMonitorPhysicalSize mon
|
||||
return $ Just (name, pos, size, vms)
|
||||
|
||||
getMonitorName :: GLFW.Monitor -> MaybeT IO String
|
||||
getMonitorName mon = MaybeT $ GLFW.getMonitorName mon
|
||||
|
||||
getVideoModes :: GLFW.Monitor -> MaybeT IO [GLFW.VideoMode]
|
||||
getVideoModes mon = MaybeT $ GLFW.getVideoModes mon
|
||||
|
||||
getJoystickNames :: IO [(GLFW.Joystick, String)]
|
||||
getJoystickNames =
|
||||
catMaybes `fmap` mapM getJoystick joysticks
|
||||
where
|
||||
getJoystick js =
|
||||
fmap (maybe Nothing (\name -> Just (js, name)))
|
||||
(GLFW.getJoystickName js)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
printEvent :: String -> [String] -> Demo ()
|
||||
printEvent cbname fields =
|
||||
liftIO $ putStrLn $ cbname ++ ": " ++ unwords fields
|
||||
|
||||
showModifierKeys :: GLFW.ModifierKeys -> String
|
||||
showModifierKeys mk =
|
||||
"[mod keys: " ++ keys ++ "]"
|
||||
where
|
||||
keys = if null xs then "none" else unwords xs
|
||||
xs = catMaybes ys
|
||||
ys = [ if GLFW.modifierKeysShift mk then Just "shift" else Nothing
|
||||
, if GLFW.modifierKeysControl mk then Just "control" else Nothing
|
||||
, if GLFW.modifierKeysAlt mk then Just "alt" else Nothing
|
||||
, if GLFW.modifierKeysSuper mk then Just "super" else Nothing
|
||||
]
|
||||
|
||||
curb :: Ord a => a -> a -> a -> a
|
||||
curb l h x
|
||||
| x < l = l
|
||||
| x > h = h
|
||||
| otherwise = x
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
joysticks :: [GLFW.Joystick]
|
||||
joysticks =
|
||||
[ GLFW.Joystick'1
|
||||
, GLFW.Joystick'2
|
||||
, GLFW.Joystick'3
|
||||
, GLFW.Joystick'4
|
||||
, GLFW.Joystick'5
|
||||
, GLFW.Joystick'6
|
||||
, GLFW.Joystick'7
|
||||
, GLFW.Joystick'8
|
||||
, GLFW.Joystick'9
|
||||
, GLFW.Joystick'10
|
||||
, GLFW.Joystick'11
|
||||
, GLFW.Joystick'12
|
||||
, GLFW.Joystick'13
|
||||
, GLFW.Joystick'14
|
||||
, GLFW.Joystick'15
|
||||
, GLFW.Joystick'16
|
||||
]
|
||||
|
||||
Reference in New Issue
Block a user