justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Continue work on shadow rendering

Browse Source
This commit is contained in:
justin
2023-03-14 11:20:38 +00:00
parent 9947979b52
commit 6af041bb8c
20 changed files with 418 additions and 381 deletions
Download Patch File Download Diff File Expand all files Collapse all files
package.yaml
-16
View File
@@ -22,26 +22,18 @@ description: Description text, TODO link to README.md
dependencies: dependencies:
- base >= 4.7 && < 5 - base >= 4.7 && < 5
- containers - containers
#- strict-containers
#- strict-containers-lens
- unordered-containers - unordered-containers
#- bitwise-enum
- graphviz - graphviz
- template-haskell - template-haskell
#- heap
- sdl2 - sdl2
- sdl2-mixer - sdl2-mixer
#- OpenGL
- OpenGLRaw - OpenGLRaw
- text - text
#- raw-strings-qq
- bytestring - bytestring
- lens - lens
- mtl - mtl
- fgl - fgl
- random - random
#- bmp
#- monad-loops
- JuicyPixels - JuicyPixels
- vector - vector
- dlist - dlist
@@ -52,23 +44,15 @@ dependencies:
- aeson - aeson
- aeson-pretty - aeson-pretty
#- store #- store
#- binary
#- flat
#- th-utilities
- directory - directory
- extra - extra
- primitive - primitive
#- streaming
#- repa
- monad-parallel - monad-parallel
- parallel - parallel
- Clipboard - Clipboard
# testing
- tasty - tasty
- tasty-hunit - tasty-hunit
- tasty-quickcheck - tasty-quickcheck
#- QuickCheck
#- HUnit
library: library:
source-dirs: src source-dirs: src
shader/lighting/cap.geom
+3 -3
View File
@@ -9,9 +9,9 @@ vec4 projNear (vec4 pos)
// note we project to a specific height // note we project to a specific height
// this is quite brittle, not ideal // this is quite brittle, not ideal
vec3 dir = pos.xyz - lightPos ; vec3 dir = pos.xyz - lightPos ;
float a = (140 - pos.z) / dir.z ; float a = (100 - pos.z) / dir.z ;
vec2 xy = (pos.xyz + a * dir).xy ; vec2 xy = (pos.xyz + a * dir).xy ;
return vec4 ( xy, 140 , 1) ; return vec4 ( xy, 100 , 1) ;
} }
void main() void main()
{ {
@@ -28,8 +28,8 @@ void main()
// the front cap // the front cap
vec4 v1 = vec4 (0,0,1,0) ; vec4 v1 = vec4 (0,0,1,0) ;
gl_Position = theMat * projNear(p0); EmitVertex(); gl_Position = theMat * projNear(p0); EmitVertex();
gl_Position = theMat * projNear(p1); EmitVertex();
gl_Position = theMat * projNear(p2); EmitVertex(); gl_Position = theMat * projNear(p2); EmitVertex();
gl_Position = theMat * projNear(p1); EmitVertex();
EndPrimitive(); EndPrimitive();
} }
else {} else {}
shader/lighting/lineShadow.geom
+83 -63
View File
@@ -1,71 +1,91 @@
#version 450 core #version 450 core
layout (lines_adjacency) in; layout(lines_adjacency) in;
layout (triangle_strip, max_vertices = 4) out; layout(triangle_strip, max_vertices = 4) out;
layout (std140, binding = 0) uniform TheMat { mat4 theMat; } ; layout(std140, binding = 0) uniform TheMat { mat4 theMat; };
uniform vec3 lightPos; uniform vec3 lightPos;
uniform float radiusUniform; uniform float radiusUniform;
//vec4 shift (vec4 p) { return (vec4 (p.xyz + (lumRad.a*normalize(p.xyz-lightPos)), 1));} // vec4 shift (vec4 p) { return (vec4 (p.xyz +
vec4 shift (vec4 p) { return (vec4 (p.xyz + (100000*(p.xyz-lightPos)), 1));} // (lumRad.a*normalize(p.xyz-lightPos)), 1));}
vec4 shiftBy (float x,vec4 p) { return (vec4 (lightPos + (x*normalize(p.xyz-lightPos)), 1));} float closestPointOnLineParam3 (vec3 a, vec3 b, vec3 p) {
//vec4 shift (vec4 p) { return (vec4 (lightPos + (lumRad.a*normalize(p.xyz-lightPos)), 1));} return dot(p - a,b-a) / dot(b-a,b-a);
}
vec3 closestPointOnSeg3 (vec3 a,vec3 b, vec3 p) {
float x = closestPointOnLineParam3(a,b,p);
if (x < 0) {
return a;
} else{ if (x > 1) { return b; }
{ return a + (x * (b- a));}
}
}
//vec3 closepoint =
vec4 shift(vec4 p) { return (vec4(p.xyz + (100000 * (p.xyz - lightPos)), 1)); }
vec4 shiftBy(float x, vec4 p) {
return (vec4(lightPos + (x * normalize(p.xyz - lightPos)), 1));
}
// vec4 shift (vec4 p) { return (vec4 (lightPos +
// (lumRad.a*normalize(p.xyz-lightPos)), 1));}
// copied from lighting/cap.geom, should not be changed on its own // copied from lighting/cap.geom, should not be changed on its own
vec4 projNear (vec4 pos) vec4 projNear(vec4 pos) {
{ // note we project to a specific height
// note we project to a specific height // this is quite brittle, not ideal
// this is quite brittle, not ideal vec3 dir = pos.xyz - lightPos;
vec3 dir = pos.xyz - lightPos ; float a = (100 - pos.z) / dir.z;
float a = (140 - pos.z) / dir.z ; vec2 xy = (pos.xyz + a * dir).xy;
vec2 xy = (pos.xyz + a * dir).xy ; return vec4(xy, 100, 1);
return vec4 ( xy, 140 , 1) ;
} }
vec4 shiftNear (vec4 pos) vec4 shiftNear(vec4 pos)
//{ vec4 sp = shiftBy(radiusUniform,pos); //{ vec4 sp = shiftBy(radiusUniform,pos);
{ vec4 sp = shift(pos);
if (sp.z > 140)
{ return projNear(pos) ; }
else
{ return sp ; }
}
vec4 f (vec4 p) {return (theMat * p);}
void main()
{ {
float ru2 = radiusUniform * radiusUniform ; vec4 sp = shift(pos);
vec4 p0 = gl_in[0].gl_Position; if (sp.z > 100) {
vec4 p1 = gl_in[1].gl_Position; return projNear(pos);
vec4 mid = 0.5*(p0 + p1); } else {
vec3 n0a = gl_in[2].gl_Position.xyz; return sp;
vec3 n1a = gl_in[3].gl_Position.xyz; }
vec3 n0 = cross(p1.xyz - p0.xyz, n0a - p0.xyz) ; }
vec3 n1 = cross(p0.xyz - p1.xyz, n1a - p1.xyz) ; vec4 f(vec4 p) { return (theMat * p); }
void main() {
//vec3 n2 = n0 + n1; // assumes the summands are normalized vec4 p0 = gl_in[0].gl_Position;
vec3 lightDir = p0.xyz - lightPos.xyz; vec4 p1 = gl_in[1].gl_Position;
vec3 lightDir2 = p1.xyz - lightPos.xyz; vec3 closepoint = closestPointOnSeg3(p0.xyz,p1.xyz,lightPos);
// first test if the edge is part of the silhouette float ru2 = radiusUniform * radiusUniform;
// that is, if the normals of the faces connected by the edge point are in vec4 mid = 0.5 * (p0 + p1);
// "different directions" wrt the light direction vec3 n0a = gl_in[2].gl_Position.xyz;
if ( dot(n0 , lightDir) * dot(n1 , lightDir) <= 0 && vec3 n1a = gl_in[3].gl_Position.xyz;
(dot(lightDir,lightDir) < ru2 || dot(lightDir2,lightDir2) < ru2) ) vec3 n0 = cross(p1.xyz - p0.xyz, n0a - p0.xyz);
// using <= rather than < seems to get rid of overlapping shadow vec3 n1 = cross(p0.xyz - p1.xyz, n1a - p1.xyz);
// artefacts
{ // vec3 n2 = n0 + n1; // assumes the summands are normalized
vec4 p2 = shiftNear(p0); vec3 lightDir = p0.xyz - lightPos.xyz;
vec4 p3 = shiftNear(p1); vec3 lightDir2 = p1.xyz - lightPos.xyz;
if ( dot(n0 , lightDir) > 0) // first test if the edge is part of the silhouette
{ // that is, if the normals of the faces connected by the edge point are in
gl_Position = f(p0); EmitVertex(); // "different directions" wrt the light direction
gl_Position = f(p1); EmitVertex(); if (dot(n0, lightDir) * dot(n1, lightDir) <= 0 &&
gl_Position = f(p2); EmitVertex(); (dot(lightDir, lightDir) < ru2 || dot(lightDir2, lightDir2) < ru2))
gl_Position = f(p3); EmitVertex(); // using <= rather than < seems to get rid of overlapping shadow
} // artefacts
else {
{ //vec4 p2 = shiftNear(p0);
gl_Position = f(p1); EmitVertex(); //vec4 p3 = shiftNear(p1);
gl_Position = f(p0); EmitVertex(); vec4 p2 = shiftNear(p0);
gl_Position = f(p3); EmitVertex(); vec4 p3 = shiftNear(p1);
gl_Position = f(p2); EmitVertex(); gl_Position = f(p0);
} EmitVertex();
EndPrimitive(); if (dot(n0, lightDir) > 0) {
} gl_Position = f(p2);
else { } EmitVertex();
gl_Position = f(p1);
EmitVertex();
} else {
gl_Position = f(p1);
EmitVertex();
gl_Position = f(p2);
EmitVertex();
}
gl_Position = f(p3);
EmitVertex();
EndPrimitive();
} else {
}
} }
shader/lighting/texture.frag
+10 -8
View File
@@ -4,12 +4,14 @@ uniform vec4 lumRad;
uniform sampler2D screenTexture; uniform sampler2D screenTexture;
in vec2 vTexPos; in vec2 vTexPos;
out vec4 fColor; out vec4 fColor;
void main() float rad = lumRad.a;
{ void main() {
vec3 distVec = texture(screenTexture,vTexPos).xyz - lightPos; vec3 distVec = texture(screenTexture, vTexPos).xyz - lightPos;
float dist = dot(distVec,distVec); float dist = dot(distVec, distVec);
if (dist > lumRad.a) {discard;} if (dist > rad) {
float x = 1 - dist / lumRad.a ; discard;
vec3 c = (x * x * x) * lumRad.rgb ; }
fColor = vec4(c,0); float x = 1 - dist / rad;
vec3 c = (x * x * x) * lumRad.rgb;
fColor = vec4(c, 0);
} }
shader/lighting/wallShadow.geom
+60 -60
View File
@@ -1,68 +1,68 @@
#version 450 core #version 450 core
layout (points) in; layout(points) in;
layout (triangle_strip, max_vertices = 8) out; layout(triangle_strip, max_vertices = 18) out;
layout (std140, binding = 0) uniform TheMat { mat4 theMat; } ; layout(std140, binding = 0) uniform TheMat { mat4 theMat; };
uniform vec3 lightPos; uniform vec3 lightPos;
vec4 shift (vec4 p) uniform float rad;
{ return vec4 (p.xy + (200 * (p.xy-lightPos.xy)), 0 , 1); float rad2 = rad;
// Preprocessed to include ../functions.glsl
float closestPointOnLineParam (vec2 a, vec2 b, vec2 p) {
return dot(p - a,b-a) / dot(b-a,b-a);
} }
float isLHS (vec2 startV, vec2 testV) vec2 closestPointOnSeg (vec2 a,vec2 b, vec2 p) {
{ float x = closestPointOnLineParam(a,b,p);
return sign( -startV.x * testV.y + startV.y * testV.x); if (x < 0) {
return a;
} else{ if (x > 1) { return b; }
{ return a + (x * (b- a));}
}
}
// End include 2023-03-13 15:33:44.438312149 UTC
vec2 shift(vec2 p) {
return vec2(lightPos.xy + (rad2 * normalize(p - lightPos.xy)));
}
float isLHS(vec2 startV, vec2 testV) {
return sign(-startV.x * testV.y + startV.y * testV.x);
} }
// construct a box with openings on bottom face and face away from wall // construct a box with openings on bottom face and face away from wall
void main() void main() {
{ vec2 p1 = gl_in[0].gl_Position.xy;
vec4 p1 = vec4 (gl_in[0].gl_Position.xy,0,1); vec2 p2 = gl_in[0].gl_Position.zw;
vec4 p2 = vec4 (gl_in[0].gl_Position.zw,0,1); vec2 closepoint = closestPointOnSeg(p1,p2,lightPos.xy);
if (isLHS (p1.xy - lightPos.xy, p2.xy - lightPos.xy) < 0) if (isLHS(p1 - lightPos.xy, p2 - lightPos.xy) < 0 && distance(closepoint,lightPos.xy) < rad2) {
{ vec2 closeshift = (rad2 * normalize(closepoint - lightPos.xy)) + lightPos.xy - closepoint;
vec4 p3 = vec4 (p1.xy,100,1); vec2 p1cs = p1 + closeshift;
vec4 p4 = vec4 (p2.xy,100,1); vec2 p1o = vec2( distance(p1,lightPos.xy) > rad2 ? p1cs : shift(p1) );
vec4 p5 = shift(p1); vec2 p2cs = p2 + closeshift;
vec4 p6 = shift(p2); vec2 p2o = vec2( distance(p2,lightPos.xy) > rad2 ? p2cs : shift(p2) );
vec4 p7 = vec4 (p6.xy,100,1);
vec4 p8 = vec4 (p5.xy,100,1);
vec4 a1 = theMat * p1; gl_Position = theMat * vec4(p1o,0,1); EmitVertex();
vec4 a2 = theMat * p2; gl_Position = theMat * vec4(p1,0,1); EmitVertex();
vec4 a3 = theMat * p3; gl_Position = theMat * vec4(p1o,100,1); EmitVertex();
vec4 a4 = theMat * p4; gl_Position = theMat * vec4(p1,100,1); EmitVertex();
vec4 a5 = theMat * p5; gl_Position = theMat * vec4(p1cs,100,1); EmitVertex();
vec4 a6 = theMat * p6; gl_Position = theMat * vec4(p2,100,1); EmitVertex();
vec4 a7 = theMat * p7; gl_Position = theMat * vec4(p2cs,100,1); EmitVertex();
vec4 a8 = theMat * p8; gl_Position = theMat * vec4(p2o,100,1); EmitVertex();
EndPrimitive();
//gl_Position = a4; EmitVertex(); // gl_Position = theMat * vec4(p2o,100,1); EmitVertex();
//gl_Position = a3; EmitVertex(); // gl_Position = theMat * vec4(p2,100,1); EmitVertex();
//gl_Position = a7; EmitVertex(); // gl_Position = theMat * vec4(p2o,0,1); EmitVertex();
//gl_Position = a8; EmitVertex(); // gl_Position = theMat * vec4(p2,0,1); EmitVertex();
//gl_Position = a5; EmitVertex();
//gl_Position = a3; EmitVertex(); gl_Position = theMat * vec4(p2,100,1); EmitVertex();
//gl_Position = a1; EmitVertex(); gl_Position = theMat * vec4(p2,0,1); EmitVertex();
//gl_Position = a4; EmitVertex(); gl_Position = theMat * vec4(p2o,100,1); EmitVertex();
//gl_Position = a2; EmitVertex(); gl_Position = theMat * vec4(p2o,0,1); EmitVertex();
//gl_Position = a7; EmitVertex(); gl_Position = theMat * vec4(p2cs,100,1); EmitVertex();
//gl_Position = a6; EmitVertex(); gl_Position = theMat * vec4(p2cs,0,1); EmitVertex();
gl_Position = theMat * vec4(p1cs,100,1); EmitVertex();
gl_Position = a1; EmitVertex(); gl_Position = theMat * vec4(p1cs,0,1); EmitVertex();
gl_Position = a5; EmitVertex(); gl_Position = theMat * vec4(p1o,100,1); EmitVertex();
gl_Position = a3; EmitVertex(); gl_Position = theMat * vec4(p1o,0,1); EmitVertex();
gl_Position = a8; EmitVertex();
gl_Position = a4; EmitVertex(); EndPrimitive();
gl_Position = a7; EmitVertex(); } else {
gl_Position = a2; EmitVertex(); }
gl_Position = a6; EmitVertex();
//gl_Position = a5; EmitVertex();
//gl_Position = a1; EmitVertex();
//gl_Position = a8; EmitVertex();
//gl_Position = a3; EmitVertex();
//gl_Position = a7; EmitVertex();
//gl_Position = a4; EmitVertex();
//gl_Position = a6; EmitVertex();
//gl_Position = a2; EmitVertex();
EndPrimitive();
} else {}
} }
shader/shadow/wallShadow.geom
+13
View File
@@ -13,6 +13,19 @@ vec4 shift(vec4 p) { return vec4(p.xy + (200 * (p.xy - lightPos.xy)), 0, 1); }
float isLHS(vec2 startV, vec2 testV) { float isLHS(vec2 startV, vec2 testV) {
return sign(-startV.x * testV.y + startV.y * testV.x); return sign(-startV.x * testV.y + startV.y * testV.x);
} }
// Preprocessed to include ../functions.glsl
float closestPointOnLineParam (vec2 a, vec2 b, vec2 p) {
return dot(p - a,b-a) / dot(b-a,b-a);
}
vec2 closestPointOnSeg (vec2 a,vec2 b, vec2 p) {
float x = closestPointOnLineParam(a,b,p);
if (x < 0) {
return a;
} else{ if (x > 1) { return b; }
{ return a + (x * (b- a));}
}
}
// End include 2023-03-13 15:33:44.454374887 UTC
// construct a box with openings on bottom face and face away from wall // construct a box with openings on bottom face and face away from wall
void main() { void main() {
vec4 p1 = vec4(gl_in[0].gl_Position.xy, 0, 1); vec4 p1 = vec4(gl_in[0].gl_Position.xy, 0, 1);
src/Dodge/Default/LightSource.hs
+1 -1
View File
@@ -10,7 +10,7 @@ defaultLS =
, _lsParam = , _lsParam =
LSParam LSParam
{ _lsPos = V3 0 0 50 { _lsPos = V3 0 0 50
, _lsRad = 700 , _lsRad = 450
, _lsCol = 0.6 , _lsCol = 0.6
} }
, _lsDir = 0 , _lsDir = 0
src/Dodge/LightSource.hs
+7 -14
View File
@@ -2,9 +2,7 @@ module Dodge.LightSource (
tlsTimeRadFunPos, tlsTimeRadFunPos,
tlsTimeRadColPos, tlsTimeRadColPos,
lsRadCol, lsRadCol,
lsPosRadCol,
lsColPosRad, lsColPosRad,
lsPosColRad,
lsColPos, lsColPos,
lsPosCol, lsPosCol,
lsPosRad, lsPosRad,
@@ -46,27 +44,22 @@ tlsTimeRadFunPos t rmax intensityF p =
-- & tlsParam . lsCol .~ f (intensityF (_tlsTime tls) ) -- & tlsParam . lsCol .~ f (intensityF (_tlsTime tls) )
-- f x' = V3 x' x' x' -- f x' = V3 x' x' x'
lsPosColRad :: Point3 -> Point3 -> Float -> LightSource
lsPosColRad p col = lsColPosRad col p
lsPosRadCol :: Point3 -> Float -> Point3 -> LightSource
lsPosRadCol p r col =
defaultLS
& lsParam . lsPos .~ p
& lsParam . lsRad .~ r
& lsParam . lsCol .~ col
lsColPosID :: Point3 -> Point3 -> Int -> LightSource lsColPosID :: Point3 -> Point3 -> Int -> LightSource
lsColPosID col p i = lsColPos col p & lsID .~ i lsColPosID col p i = lsColPos col p & lsID .~ i
lsColPos :: Point3 -> Point3 -> LightSource lsColPos :: Point3 -> Point3 -> LightSource
lsColPos col pos = lsColPosRad col pos 700 lsColPos col pos = lsColPosRad col pos 450
lsPosCol :: Point3 -> Point3 -> LightSource lsPosCol :: Point3 -> Point3 -> LightSource
lsPosCol pos col = lsColPos col pos lsPosCol pos col = lsColPos col pos
lsColPosRad :: Point3 -> Point3 -> Float -> LightSource lsColPosRad :: Point3 -> Point3 -> Float -> LightSource
lsColPosRad col pos r = lsPosRadCol pos r col lsColPosRad col p r =
defaultLS
& lsParam . lsPos .~ p
& lsParam . lsRad .~ r
& lsParam . lsCol .~ col
lsRadCol :: Float -> Point3 -> LightSource lsRadCol :: Float -> Point3 -> LightSource
lsRadCol r col = lsRadCol r col =
src/Dodge/Render.hs
+12 -27
View File
@@ -114,14 +114,18 @@ doDrawing' win pdata u = do
glClear $ sum [GL_COLOR_BUFFER_BIT, GL_DEPTH_BUFFER_BIT] glClear $ sum [GL_COLOR_BUFFER_BIT, GL_DEPTH_BUFFER_BIT]
glDepthFunc GL_LESS glDepthFunc GL_LESS
-- draw wall occlusions from the camera's point of view -- draw wall occlusions from the camera's point of view
glUseProgram (pdata ^. lightingWallShadShader . shadProg') -- glEnable GL_CULL_FACE
-- glCullFace GL_BACK
glUseProgram (pdata ^. lightingWallShadShader . shadName)
glUniform3f (pdata ^?! lightingWallShadShader . shadUnis' . ix 0) vfx vfy 20 glUniform3f (pdata ^?! lightingWallShadShader . shadUnis' . ix 0) vfx vfy 20
glUniform1f (pdata ^?! lightingWallShadShader . shadUnis' . ix 1) 100
glBindVertexArray $ pdata ^. lightingWallShadShader . shadVAO' . vaoName glBindVertexArray $ pdata ^. lightingWallShadShader . shadVAO' . vaoName
unless (debugOn Remove_LOS cfig) $ unless (debugOn Remove_LOS cfig) $
glDrawArrays glDrawArrays
(marshalEPrimitiveMode $ pdata ^. lightingWallShadShader . shadPrim') (marshalEPrimitiveMode $ pdata ^. lightingWallShadShader . shadPrim')
0 0
(fromIntegral nWalls) (fromIntegral nWalls)
-- glDisable GL_CULL_FACE
--draw walls onto base buffer --draw walls onto base buffer
if cfig ^. graphics_wall_textured if cfig ^. graphics_wall_textured
then renderTextureWalls pdata nWalls then renderTextureWalls pdata nWalls
@@ -130,7 +134,7 @@ doDrawing' win pdata u = do
renderLayer BottomLayer shadV layerCounts renderLayer BottomLayer shadV layerCounts
--draw object shapes onto base buffer --draw object shapes onto base buffer
let fs = _shapeShader pdata let fs = _shapeShader pdata
glUseProgram (_shadProg' fs) glUseProgram (_shadName fs)
glBindVertexArray $ fs ^. shadVAO' . vaoName glBindVertexArray $ fs ^. shadVAO' . vaoName
glDrawElements glDrawElements
(marshalEPrimitiveMode $ _shadPrim' fs) (marshalEPrimitiveMode $ _shadPrim' fs)
@@ -140,7 +144,6 @@ doDrawing' win pdata u = do
--draw floor onto base buffer --draw floor onto base buffer
drawShader (_textureArrayShader pdata) nFls drawShader (_textureArrayShader pdata) nFls
--draw lightmap into its own buffer --draw lightmap into its own buffer
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
createLightMap createLightMap
cfig cfig
pdata pdata
@@ -159,6 +162,11 @@ doDrawing' win pdata u = do
glEnable GL_BLEND glEnable GL_BLEND
glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR
drawShader (_fullscreenShader pdata) 4 drawShader (_fullscreenShader pdata) 4
with GL_COLOR_ATTACHMENT0 $ \ptr ->
glInvalidateNamedFramebufferData
(pdata ^. fboLighting . _1 . unFBO)
1
ptr
--draw bloom onto bloom buffer --draw bloom onto bloom buffer
glBindFramebuffer GL_FRAMEBUFFER (pdata ^. fboBloom . _1 . unFBO) glBindFramebuffer GL_FRAMEBUFFER (pdata ^. fboBloom . _1 . unFBO)
glClear GL_COLOR_BUFFER_BIT glClear GL_COLOR_BUFFER_BIT
@@ -168,21 +176,17 @@ doDrawing' win pdata u = do
renderLayer BloomNoZWrite shadV layerCounts renderLayer BloomNoZWrite shadV layerCounts
glDepthMask GL_TRUE glDepthMask GL_TRUE
renderLayer BloomLayer shadV layerCounts renderLayer BloomLayer shadV layerCounts
--glDepthMask GL_TRUE
--setup downscale viewport for blurring bloom --setup downscale viewport for blurring bloom
setViewportSize (round winx `div` (2 * resFact)) (round winy `div` (2 * resFact)) setViewportSize (round winx `div` (2 * resFact)) (round winy `div` (2 * resFact))
--bindFramebuffer Framebuffer $= fst (_fboHalf1 pdata)
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboHalf1 pdata))) glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboHalf1 pdata)))
glDepthFunc GL_ALWAYS glDepthFunc GL_ALWAYS
--textureBinding Texture2D $= pdata ^? fboBloom . _2 -- Just (snd $ _fboBloom pdata) glBindTexture GL_TEXTURE_2D (pdata ^. fboBloom . _2 . unTO)
glBindTexture GL_TEXTURE_2D (pdata ^. fboBloom . _2 . unTO) -- Just (snd $ _fboBloom pdata)
glDisable GL_BLEND glDisable GL_BLEND
drawShader (_bloomBlurShader pdata) 4 drawShader (_bloomBlurShader pdata) 4
replicateM_ 9 $ pingPongBetween (_fboHalf1 pdata) (_fboHalf2 pdata) (_bloomBlurShader pdata) replicateM_ 9 $ pingPongBetween (_fboHalf1 pdata) (_fboHalf2 pdata) (_bloomBlurShader pdata)
glEnable GL_BLEND glEnable GL_BLEND
setViewportSize (round winx `div` resFact) (round winy `div` resFact) setViewportSize (round winx `div` resFact) (round winy `div` resFact)
--draw clouds onto cloud buffer --draw clouds onto cloud buffer
--bindFramebuffer Framebuffer $= fst (_fboCloud pdata)
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata))) glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata)))
glDepthFunc GL_LEQUAL glDepthFunc GL_LEQUAL
glDepthMask GL_FALSE glDepthMask GL_FALSE
@@ -191,24 +195,20 @@ doDrawing' win pdata u = do
--blendColor $= Color4 0.5 0.5 0.5 0.5 --blendColor $= Color4 0.5 0.5 0.5 0.5
--glBlendFuncSeparate GL_SRC_ALPHASaturate,One) , (One,GL_ONE_MINUS_SRC_ALPHA)) --glBlendFuncSeparate GL_SRC_ALPHASaturate,One) , (One,GL_ONE_MINUS_SRC_ALPHA))
glBlendFuncSeparate GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA GL_ONE GL_ONE_MINUS_SRC_ALPHA glBlendFuncSeparate GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA GL_ONE GL_ONE_MINUS_SRC_ALPHA
--drawBuffers $= [FBOColorAttachment 0, NoBuffers]
withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $ \ptr -> glDrawBuffers 2 ptr withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $ \ptr -> glDrawBuffers 2 ptr
glClear GL_COLOR_BUFFER_BIT glClear GL_COLOR_BUFFER_BIT
renderLayer MidLayer shadV layerCounts renderLayer MidLayer shadV layerCounts
--renderWindows pdata windowPoints
drawShader (_windowShader pdata) nWins drawShader (_windowShader pdata) nWins
when (_graphics_cloud_shadows cfig) $ do when (_graphics_cloud_shadows cfig) $ do
----render transparency depths ----render transparency depths
glDepthMask GL_TRUE glDepthMask GL_TRUE
glDisable GL_BLEND glDisable GL_BLEND
withArray [GL_NONE, GL_COLOR_ATTACHMENT1] $ \ptr -> glDrawBuffers 2 ptr withArray [GL_NONE, GL_COLOR_ATTACHMENT1] $ \ptr -> glDrawBuffers 2 ptr
--drawBuffers $= [NoBuffers, FBOColorAttachment 1]
renderLayer MidLayer shadV layerCounts renderLayer MidLayer shadV layerCounts
drawShader (_windowShader pdata) nWins drawShader (_windowShader pdata) nWins
----draw lightmap for cloud buffer ----draw lightmap for cloud buffer
glDepthMask GL_FALSE glDepthMask GL_FALSE
glEnable GL_BLEND glEnable GL_BLEND
--bindFramebuffer Framebuffer $= fst (_fboLighting pdata)
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
createLightMap createLightMap
cfig cfig
@@ -224,31 +224,24 @@ doDrawing' win pdata u = do
glClearColor 0 0 0 0 glClearColor 0 0 0 0
--apply lightmap to cloud buffer --apply lightmap to cloud buffer
glClearColor 0 0 0 0 glClearColor 0 0 0 0
--bindFramebuffer Framebuffer $= fst (_fboCloud pdata)
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata))) glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata)))
glDepthMask GL_FALSE glDepthMask GL_FALSE
--drawBuffers $= [FBOColorAttachment 0, NoBuffers]
withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $ \ptr -> glDrawBuffers 2 ptr withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $ \ptr -> glDrawBuffers 2 ptr
glDepthFunc GL_ALWAYS glDepthFunc GL_ALWAYS
--textureBinding Texture2D $= Just (snd $ _fboLighting pdata)
glBindTexture GL_TEXTURE_2D (_unTO . snd $ _fboLighting pdata) glBindTexture GL_TEXTURE_2D (_unTO . snd $ _fboLighting pdata)
glEnable GL_BLEND glEnable GL_BLEND
--glBlendFunc GL_ZERO, GL_ONE_MINUS_SRC_ALPHA)
glBlendFuncSeparate GL_ZERO GL_ONE_MINUS_SRC_COLOR GL_ZERO GL_ONE glBlendFuncSeparate GL_ZERO GL_ONE_MINUS_SRC_COLOR GL_ZERO GL_ONE
drawShader (_fullscreenShader pdata) 4 drawShader (_fullscreenShader pdata) 4
glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
-- bind base buffer for drawing bloom then clouds -- bind base buffer for drawing bloom then clouds
--bindFramebuffer Framebuffer $= fst (_fboBase pdata)
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboBase pdata))) glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboBase pdata)))
--Draw blurred bloom onto base buffer --Draw blurred bloom onto base buffer
glEnable GL_BLEND glEnable GL_BLEND
glBlendFunc GL_SRC_ALPHA GL_ONE glBlendFunc GL_SRC_ALPHA GL_ONE
--textureBinding Texture2D $= Just (snd $ _fboHalf1 pdata)
glBindTexture GL_TEXTURE_2D (_unTO . snd $ _fboHalf1 pdata) glBindTexture GL_TEXTURE_2D (_unTO . snd $ _fboHalf1 pdata)
drawShader (_fullscreenShader pdata) 4 drawShader (_fullscreenShader pdata) 4
glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
--draw shadowed clouds onto base buffer --draw shadowed clouds onto base buffer
--textureBinding Texture2D $= Just (fst $ snd $ _fboCloud pdata)
glBindTexture GL_TEXTURE_2D (_unTO . fst . snd $ _fboCloud pdata) glBindTexture GL_TEXTURE_2D (_unTO . fst . snd $ _fboCloud pdata)
drawShader (_fullscreenShader pdata) 4 drawShader (_fullscreenShader pdata) 4
--set viewport for radial distortion --set viewport for radial distortion
@@ -260,7 +253,6 @@ doDrawing' win pdata u = do
[] -> do [] -> do
bindTO $ fst $ snd $ _fboBase pdata bindTO $ fst $ snd $ _fboBase pdata
glBindFramebuffer GL_FRAMEBUFFER 0 glBindFramebuffer GL_FRAMEBUFFER 0
--bufferUBO $ perspectiveMatrixb rot camzoom trans wins viewFroms
drawShader (_fullscreenShader pdata) 4 drawShader (_fullscreenShader pdata) 4
rds -> do rds -> do
let bindDrawDist :: Distortion -> IO () let bindDrawDist :: Distortion -> IO ()
@@ -270,14 +262,11 @@ doDrawing' win pdata u = do
drawShader (_barrelShader pdata) 1 drawShader (_barrelShader pdata) 1
fboList = fboList =
take (length rds - 1) (concat (repeat [fst $ _fbo2 pdata, fst $ _fbo3 pdata])) take (length rds - 1) (concat (repeat [fst $ _fbo2 pdata, fst $ _fbo3 pdata]))
-- ++ [defaultFramebufferObject]
++ [FBO 0] ++ [FBO 0]
toList = fst (snd (_fboBase pdata)) : concat (repeat [snd $ _fbo2 pdata, snd $ _fbo3 pdata]) toList = fst (snd (_fboBase pdata)) : concat (repeat [snd $ _fbo2 pdata, snd $ _fbo3 pdata])
bindings = zipWith (>>) (map bindFBO fboList) (map bindTO toList) bindings = zipWith (>>) (map bindFBO fboList) (map bindTO toList)
glActiveTexture GL_TEXTURE1 glActiveTexture GL_TEXTURE1
--activeTexture $= TextureUnit 1
zipWithM_ (>>) bindings $ map bindDrawDist rds zipWithM_ (>>) bindings $ map bindDrawDist rds
--activeTexture $= TextureUnit 0
glActiveTexture GL_TEXTURE1 glActiveTexture GL_TEXTURE1
glDepthFunc GL_ALWAYS glDepthFunc GL_ALWAYS
glEnable GL_BLEND glEnable GL_BLEND
@@ -288,7 +277,6 @@ doDrawing' win pdata u = do
glDepthMask GL_FALSE glDepthMask GL_FALSE
glEnable GL_BLEND glEnable GL_BLEND
glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA
--bufferUBO (pdata ^. matUBO) $ isoMatrix 0 1 (V2 0 0) (V2 2 2)
glBindBufferBase GL_UNIFORM_BUFFER 0 (pdata ^. isoMatUBO) glBindBufferBase GL_UNIFORM_BUFFER 0 (pdata ^. isoMatUBO)
renderLayer FixedCoordLayer shadV layerCounts renderLayer FixedCoordLayer shadV layerCounts
renderFoldable shadV $ fixedCoordPictures u renderFoldable shadV $ fixedCoordPictures u
@@ -303,9 +291,6 @@ doDrawing' win pdata u = do
) )
SDL.glSwapWindow win SDL.glSwapWindow win
-- eTicks <- SDL.ticks
-- return (eTicks - sTicks)
fpsText :: (Show a, Ord a, Num a) => a -> Picture fpsText :: (Show a, Ord a, Num a) => a -> Picture
fpsText x = color col $ text $ "ms/frame " ++ show x fpsText x = color col $ text $ "ms/frame " ++ show x
where where
src/Dodge/Render/Shadow.hs
+1 -1
View File
@@ -26,7 +26,7 @@ drawCPUShadows pdata s pos rad = do
0 0
(fromIntegral $ floatSize * i) (fromIntegral $ floatSize * i)
(theshad ^. shadVAO' . vaoVBO . vboPtr) (theshad ^. shadVAO' . vaoVBO . vboPtr)
glUseProgram (theshad ^. shadProg') glUseProgram (theshad ^. shadName)
glBindVertexArray . _vaoName $ _shadVAO' theshad glBindVertexArray . _vaoName $ _shadVAO' theshad
glDrawArrays glDrawArrays
(marshalEPrimitiveMode $ _shadPrim' theshad) (marshalEPrimitiveMode $ _shadPrim' theshad)
src/Dodge/Room/RezBox.hs
+1 -1
View File
@@ -126,7 +126,7 @@ rezColor = do
col <- takeOne [V3 0.0 0.1 0.5, V3 0.0 0.5 0.1] col <- takeOne [V3 0.0 0.1 0.5, V3 0.0 0.5 0.1]
h <- takeOne [30, 50, 80, 90, 90, 90, 90] h <- takeOne [30, 50, 80, 90, 90, 90, 90]
rad <- takeOne [150, 200, 200, 250, 250, 300, 300, 300] rad <- takeOne [150, 200, 200, 250, 250, 300, 300, 300]
return $ lsPosColRad (V3 0 0 h) col rad return $ lsColPosRad col (V3 0 0 h) rad
rezInvBox :: LightSource -> Room rezInvBox :: LightSource -> Room
rezInvBox = swapInOutLinks . rezBox rezInvBox = swapInOutLinks . rezBox
src/Dodge/Room/RunPast.hs
+1 -1
View File
@@ -26,7 +26,7 @@ roomCritLS = do
col <- takeOne [0.5, 0.6] col <- takeOne [0.5, 0.6]
h <- takeOne [30, 35] h <- takeOne [30, 35]
rad <- takeOne [300] rad <- takeOne [300]
return $ lsPosColRad (V3 0 0 h) col rad return $ lsColPosRad col (V3 0 0 h) rad
smallRoom :: Room smallRoom :: Room
smallRoom = corridorWallN & rmRandPSs .~ [psRandRanges (15, 25) (30, 45) (pi, 2 * pi)] smallRoom = corridorWallN & rmRandPSs .~ [psRandRanges (15, 25) (30, 45) (pi, 2 * pi)]
src/Geometry/Intersect.hs
+193 -149
View File
@@ -1,31 +1,38 @@
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
--{-# LANGUAGE TupleSections #-} --{-# LANGUAGE TupleSections #-}
{- Testing for and finding intersection points. -} {- Testing for and finding intersection points. -}
module Geometry.Intersect where module Geometry.Intersect where
import Geometry.Data
import Geometry.Vector
import Geometry.LHS
import Control.Applicative
import Control.Applicative
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Geometry.Data
import Geometry.LHS
import Geometry.Vector
-- | If two lines intersect, return 'Just' that point. -- | If two lines intersect, return 'Just' that point.
intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectLineLine' #-} {-# INLINE intersectLineLine' #-}
intersectLineLine' (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) intersectLineLine' (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
| den == 0 = Nothing | den == 0 = Nothing
| otherwise = Just $ V2 (x1 + (x2-x1)*t'/den) (y1 + (y2-y1)*t'/den) | otherwise = Just $ V2 (x1 + (x2 - x1) * t' / den) (y1 + (y2 - y1) * t' / den)
where where
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) den = (x1 - x2) * (y3 - y4) - (y1 - y2) * (x3 - x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) t' = (x1 - x3) * (y3 - y4) - (y1 - y3) * (x3 - x4)
intersectSegSegErrorTest :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 intersectSegSegErrorTest :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectSegSegErrorTest #-} {-# INLINE intersectSegSegErrorTest #-}
intersectSegSegErrorTest a b c d = case intersectSegSeg a b c d of intersectSegSegErrorTest a b c d = case intersectSegSeg a b c d of
Nothing | intersectSegSegFullTest a b c d -> Nothing
error $ "intersectSegSeg did not intersect"++show a ++ show b ++ show c++ show d | intersectSegSegFullTest a b c d ->
Just x | not $ intersectSegSegFullTest a b c d -> error $ "intersectSegSeg did not intersect" ++ show a ++ show b ++ show c ++ show d
error $ "intersectSegSeg did intersect"++show a ++ show b ++ show c++ show d Just x
++ " at " ++ show x | not $ intersectSegSegFullTest a b c d ->
error $
"intersectSegSeg did intersect" ++ show a ++ show b ++ show c ++ show d
++ " at "
++ show x
m -> m m -> m
-- | If two segments intersect, return 'Just' that point. -- | If two segments intersect, return 'Just' that point.
@@ -34,146 +41,166 @@ intersectSegSeg :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
intersectSegSeg (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) intersectSegSeg (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
| V2 x1 y1 == V2 x2 y2 || V2 x3 y3 == V2 x4 y4 = Nothing | V2 x1 y1 == V2 x2 y2 || V2 x3 y3 == V2 x4 y4 = Nothing
| den == 0 = Nothing | den == 0 = Nothing
| den > 0 && (t' < 0 || u' < 0 || t' > den || u' > den) | den > 0 && (t' < 0 || u' < 0 || t' > den || u' > den) =
= Nothing Nothing
| den < 0 && (t' > 0 || u' > 0 || t' < den || u' < den) | den < 0 && (t' > 0 || u' > 0 || t' < den || u' < den) =
= Nothing Nothing
| otherwise = Just $ V2 (x1 + (x2-x1)*t'/den) (y1 + (y2-y1)*t'/den) | otherwise = Just $ V2 (x1 + (x2 - x1) * t' / den) (y1 + (y2 - y1) * t' / den)
where where
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) den = (x1 - x2) * (y3 - y4) - (y1 - y2) * (x3 - x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) t' = (x1 - x3) * (y3 - y4) - (y1 - y3) * (x3 - x4)
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) u' = (y1 - y2) * (x1 - x3) - (x1 - x2) * (y1 - y3)
-- | Intended to intersect a segment with a half-line-segment, ie a segment
-- extending infinitely in one direction. {- | Intended to intersect a segment with a half-line-segment, ie a segment
extending infinitely in one direction.
-}
intersectSegLineFrom :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 intersectSegLineFrom :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectSegLineFrom #-} {-# INLINE intersectSegLineFrom #-}
intersectSegLineFrom (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) intersectSegLineFrom (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
| den == 0 = Nothing | den == 0 = Nothing
| den > 0 && ( t' < 0 || u' < 0 || t' > den ) | den > 0 && (t' < 0 || u' < 0 || t' > den) =
= Nothing Nothing
| den < 0 && ( t' > 0 || u' > 0 || t' < den ) | den < 0 && (t' > 0 || u' > 0 || t' < den) =
= Nothing Nothing
| otherwise = Just $ V2 (x1 + (x2-x1)*t'/den) (y1 + (y2-y1)*t'/den) | otherwise = Just $ V2 (x1 + (x2 - x1) * t' / den) (y1 + (y2 - y1) * t' / den)
where where
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) den = (x1 - x2) * (y3 - y4) - (y1 - y2) * (x3 - x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) t' = (x1 - x3) * (y3 - y4) - (y1 - y3) * (x3 - x4)
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) u' = (y1 - y2) * (x1 - x3) - (x1 - x2) * (y1 - y3)
-- | Similar to 'intersectSegLineFrom'', but this version is probably not correct... -- | Similar to 'intersectSegLineFrom'', but this version is probably not correct...
intersectSegLineext :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 intersectSegLineext :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectSegLineext #-} {-# INLINE intersectSegLineext #-}
intersectSegLineext (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) intersectSegLineext (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
| den == 0 = Nothing | den == 0 = Nothing
| den > 0 && ( t' < 0 || u' < den || t' > den ) | den > 0 && (t' < 0 || u' < den || t' > den) =
= Nothing Nothing
| den < 0 && ( t' > 0 || u' > - den || t' < den ) | den < 0 && (t' > 0 || u' > - den || t' < den) =
= Nothing Nothing
| otherwise = Just $ V2 (x1 + (x2-x1)*t'/den) (y1 + (y2-y1)*t'/den) | otherwise = Just $ V2 (x1 + (x2 - x1) * t' / den) (y1 + (y2 - y1) * t' / den)
where where
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) den = (x1 - x2) * (y3 - y4) - (y1 - y2) * (x3 - x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) t' = (x1 - x3) * (y3 - y4) - (y1 - y3) * (x3 - x4)
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) u' = (y1 - y2) * (x1 - x3) - (x1 - x2) * (y1 - y3)
-- | Intersect a segment with a line. -- | Intersect a segment with a line.
intersectSegLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 intersectSegLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectSegLine #-} {-# INLINE intersectSegLine #-}
intersectSegLine (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) intersectSegLine (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
| den == 0 = Nothing | den == 0 = Nothing
| den > 0 && (t' < 0 || t' > den) | den > 0 && (t' < 0 || t' > den) =
= Nothing Nothing
| den < 0 && (t' > 0 || t' < den) | den < 0 && (t' > 0 || t' < den) =
= Nothing Nothing
| otherwise = Just $ V2 (x1 + (x2-x1)*t'/den) ( y1 + (y2-y1)*t'/den) | otherwise = Just $ V2 (x1 + (x2 - x1) * t' / den) (y1 + (y2 - y1) * t' / den)
where where
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) den = (x1 - x2) * (y3 - y4) - (y1 - y2) * (x3 - x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) t' = (x1 - x3) * (y3 - y4) - (y1 - y3) * (x3 - x4)
--u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
--u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
-- | A test that should align with Just values from intersectSegSeg. -- | A test that should align with Just values from intersectSegSeg.
intersectSegSegFullTest intersectSegSegFullTest ::
:: Point2 Point2 ->
-> Point2 Point2 ->
-> Point2 Point2 ->
-> Point2 Point2 ->
-> Bool Bool
{-# INLINE intersectSegSegFullTest #-} {-# INLINE intersectSegSegFullTest #-}
intersectSegSegFullTest x y z w intersectSegSegFullTest x y z w =
= f x y z w && f z w x y && x /= y && z /= w f x y z w && f z w x y && x /= y && z /= w
&& normalizeV (x -.- y) /= normalizeV (z -.- w) && normalizeV (x -.- y) /= normalizeV (z -.- w)
&& normalizeV (y -.- x) /= normalizeV (z -.- w) && normalizeV (y -.- x) /= normalizeV (z -.- w)
where where
f a b c d = ( not (isRHS a b c) && not (isLHS a b d) ) f a b c d =
|| ( not (isLHS a b c) && not (isRHS a b d) ) (not (isRHS a b c) && not (isLHS a b d))
-- | It is not always necessary to find a point of intersection, sometimes a || (not (isLHS a b c) && not (isRHS a b d))
-- test may suffice.
intersectSegSegTest {- | It is not always necessary to find a point of intersection, sometimes a
:: Point2 test may suffice.
-> Point2 -}
-> Point2 intersectSegSegTest ::
-> Point2 Point2 ->
-> Bool Point2 ->
Point2 ->
Point2 ->
Bool
{-# INLINE intersectSegSegTest #-} {-# INLINE intersectSegSegTest #-}
intersectSegSegTest x y z w intersectSegSegTest x y z w =
= f x y z w && f z w x y && x /= y && z /= w f x y z w && f z w x y && x /= y && z /= w
where where
f a b c d = ( not (isRHS a b c) && not (isLHS a b d) ) f a b c d =
|| ( not (isLHS a b c) && not (isRHS a b d) ) (not (isRHS a b c) && not (isLHS a b d))
intersectSegSegPreTest || (not (isLHS a b c) && not (isRHS a b d))
:: Point2
-> Point2 intersectSegSegPreTest ::
-> Point2 Point2 ->
-> Point2 Point2 ->
-> Maybe Point2 Point2 ->
Point2 ->
Maybe Point2
{-# INLINE intersectSegSegPreTest #-} {-# INLINE intersectSegSegPreTest #-}
intersectSegSegPreTest a b c d intersectSegSegPreTest a b c d
| intersectSegSegTest a b c d = myIntersectSegSeg a b c d | intersectSegSegTest a b c d = myIntersectSegSeg a b c d
| otherwise = Nothing | otherwise = Nothing
-- | Due to floating point issues, 'intersectSegSeg'' is not always
-- accurate---'myIntersectSegSeg' {- | Due to floating point issues, 'intersectSegSeg'' is not always
-- fixes at least some of accurate---'myIntersectSegSeg'
-- the problem cases by transforming the points into rationals and then doing the fixes at least some of
-- intersection. the problem cases by transforming the points into rationals and then doing the
-- This version is, probably, slower---both testing and benchmarking should be intersection.
-- done. This version is, probably, slower---both testing and benchmarking should be
myIntersectSegSeg done.
:: Point2 -}
-> Point2 myIntersectSegSeg ::
-> Point2 Point2 ->
-> Point2 Point2 ->
-> Maybe Point2 Point2 ->
Point2 ->
Maybe Point2
{-# INLINE myIntersectSegSeg #-} {-# INLINE myIntersectSegSeg #-}
myIntersectSegSeg a@(V2 ax ay) b@(V2 bx by) c@(V2 cx cy) d@(V2 dx dy) = case ratIntersectLineLine a b c d of myIntersectSegSeg a@(V2 ax ay) b@(V2 bx by) c@(V2 cx cy) d@(V2 dx dy) = case ratIntersectLineLine a b c d of
Nothing -> Nothing Nothing -> Nothing
Just (V2 x y) -> if inbetween x && inbetween' y Just (V2 x y) ->
then Just (V2 x y) if inbetween x && inbetween' y
else Nothing then Just (V2 x y)
where else Nothing
inbetween x = ((ax <= x && x <= bx) || (bx <= x && x <= ax)) where
&& ((cx <= x && x <= dx) || (dx <= x && x <= cx)) inbetween x =
inbetween' y = ((ay <= y && y <= by) || (by <= y && y <= ay)) ((ax <= x && x <= bx) || (bx <= x && x <= ax))
&& ((cy <= y && y <= dy) || (dy <= y && y <= cy)) && ((cx <= x && x <= dx) || (dx <= x && x <= cx))
inbetween' y =
((ay <= y && y <= by) || (by <= y && y <= ay))
&& ((cy <= y && y <= dy) || (dy <= y && y <= cy))
-- | Polymorphic intersection of fractional line points. -- | Polymorphic intersection of fractional line points.
myIntersectLineLine :: (Eq a,Fractional a) => V2 a -> V2 a -> V2 a -> V2 a -> Maybe (V2 a) myIntersectLineLine :: (Eq a, Fractional a) => V2 a -> V2 a -> V2 a -> V2 a -> Maybe (V2 a)
{-# INLINE myIntersectLineLine #-} {-# INLINE myIntersectLineLine #-}
myIntersectLineLine a@(V2 ax _) b c@(V2 cx _) d myIntersectLineLine a@(V2 ax _) b c@(V2 cx _) d
| isNothing (linGrad a b) = V2 ax <$> axisInt (c *-* V2 ax 0) (d *-* V2 ax 0) | isNothing (linGrad a b) = V2 ax <$> axisInt (c *-* V2 ax 0) (d *-* V2 ax 0)
| isNothing (linGrad c d) = V2 cx <$> axisInt (a *-* V2 cx 0) (b *-* V2 cx 0) | isNothing (linGrad c d) = V2 cx <$> axisInt (a *-* V2 cx 0) (b *-* V2 cx 0)
| otherwise | otherwise =
= case linGrad a b ^-^ linGrad c d of case linGrad a b ^-^ linGrad c d of
Just 0 -> Nothing Just 0 -> Nothing
_ -> liftA2 V2 newx ((linGrad a b ^*^ newx) ^+^ axisInt a b) _ -> liftA2 V2 newx ((linGrad a b ^*^ newx) ^+^ axisInt a b)
where where
(^-^) = liftA2 (-) (^-^) = liftA2 (-)
(^+^) = liftA2 (+) (^+^) = liftA2 (+)
(^/^) = liftA2 (/) (^/^) = liftA2 (/)
(^*^) = liftA2 (*) (^*^) = liftA2 (*)
newx = (axisInt c d ^-^ axisInt a b) ^/^ (linGrad a b ^-^ linGrad c d) newx = (axisInt c d ^-^ axisInt a b) ^/^ (linGrad a b ^-^ linGrad c d)
(*-*) (V2 ax' ay) (V2 bx by) = V2 (ax'-bx) (ay-by) (*-*) (V2 ax' ay) (V2 bx by) = V2 (ax' - bx) (ay - by)
-- | Transforms floating points to rationals then performs line intersection. -- | Transforms floating points to rationals then performs line intersection.
ratIntersectLineLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 ratIntersectLineLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE ratIntersectLineLine #-} {-# INLINE ratIntersectLineLine #-}
ratIntersectLineLine a b c d = toNumPoint2 ratIntersectLineLine a b c d =
<$> myIntersectLineLine (toRatPoint2 a) (toRatPoint2 b) (toRatPoint2 c) (toRatPoint2 d) toNumPoint2
where <$> myIntersectLineLine (toRatPoint2 a) (toRatPoint2 b) (toRatPoint2 c) (toRatPoint2 d)
toRatPoint2 (V2 x y) = V2 (toRational x) (toRational y) where
toNumPoint2 (V2 x y) = V2 (fromRational x) (fromRational y) toRatPoint2 (V2 x y) = V2 (toRational x) (toRational y)
toNumPoint2 (V2 x y) = V2 (fromRational x) (fromRational y)
{- | Round the floats within a 'Point2' to the nearest integer. {- | Round the floats within a 'Point2' to the nearest integer.
__Examples__ __Examples__
Rounding jumps after intervals of .5: Rounding jumps after intervals of .5:
@@ -188,66 +215,83 @@ but is symmetric around 0:
-} -}
roundPoint2 :: Point2 -> Point2 roundPoint2 :: Point2 -> Point2
roundPoint2 (V2 x y) = V2 (fromIntegral (round x :: Int)) (fromIntegral (round y :: Int)) roundPoint2 (V2 x y) = V2 (fromIntegral (round x :: Int)) (fromIntegral (round y :: Int))
-- | Given two points, finds the linear gradient if it is non-infinite. -- | Given two points, finds the linear gradient if it is non-infinite.
linGrad :: (Eq a,Fractional a) => V2 a -> V2 a -> Maybe a linGrad :: (Eq a, Fractional a) => V2 a -> V2 a -> Maybe a
{-# INLINE linGrad #-} {-# INLINE linGrad #-}
linGrad (V2 x y) (V2 a b) linGrad (V2 x y) (V2 a b)
| x-a == 0 = Nothing | x - a == 0 = Nothing
| otherwise = Just $ (y-b)/(x-a) | otherwise = Just $ (y - b) / (x - a)
-- | Given two points, finds the intersection with the y axis if it exists. -- | Given two points, finds the intersection with the y axis if it exists.
axisInt :: (Eq a,Fractional a) => V2 a -> V2 a -> Maybe a axisInt :: (Eq a, Fractional a) => V2 a -> V2 a -> Maybe a
{-# INLINE axisInt #-} {-# INLINE axisInt #-}
axisInt p (V2 a b) = (\lg -> b - (a*lg)) <$> linGrad p (V2 a b) axisInt p (V2 a b) = (\lg -> b - (a * lg)) <$> linGrad p (V2 a b)
-- | Placeholder, undefined. -- | Placeholder, undefined.
intersectSegsSeg :: [Point2] -> Point2 -> Point2 -> Maybe Point2 intersectSegsSeg :: [Point2] -> Point2 -> Point2 -> Maybe Point2
intersectSegsSeg = undefined intersectSegsSeg = undefined
-- | Placeholder: should intersect a segment with a bezier curve. -- | Placeholder: should intersect a segment with a bezier curve.
intersectSegBezquad :: Point2 -> Point2 -> Point2 -> Point2 -> Point2 -> [Point2] intersectSegBezquad :: Point2 -> Point2 -> Point2 -> Point2 -> Point2 -> [Point2]
intersectSegBezquad = undefined intersectSegBezquad = undefined
-- | finds one (if any) of the points of intersection between a segment and a {- | finds one (if any) of the points of intersection between a segment and a
-- polygon. polygon.
-- Can almost certainly be optimised. Can almost certainly be optimised.
-}
intersectSegPolyFirst :: Point2 -> Point2 -> [Point2] -> Maybe Point2 intersectSegPolyFirst :: Point2 -> Point2 -> [Point2] -> Maybe Point2
intersectSegPolyFirst a b xs = foldr (<|>) Nothing $ zipWith lineColl xs (tail xs ++ [head xs]) intersectSegPolyFirst a b xs = foldr (<|>) Nothing $ zipWith lineColl xs (tail xs ++ [head xs])
where where
lineColl = intersectSegSeg a b lineColl = intersectSegSeg a b
-- | Given a line and a point return the point on the line closest to the {- | Given a line and a point return the point on the line closest to the
-- point. point.
closestPointOnLine -}
:: Point2 -- ^ First line point. closestPointOnLine ::
-> Point2 -- ^ Second line point. -- | First line point.
-> Point2 -- ^ Point not on line. Point2 ->
-> Point2 -- | Second line point.
Point2 ->
-- | Point not on line.
Point2 ->
Point2
{-# INLINE closestPointOnLine #-} {-# INLINE closestPointOnLine #-}
closestPointOnLine !a !b !p = a +.+ u *.* (b -.- a) closestPointOnLine !a !b !p = a +.+ u *.* (b -.- a)
where u = closestPointOnLineParam a b p where
-- | Given a line and a point return a value corresponding to how far along the u = closestPointOnLineParam a b p
-- line the point is.
closestPointOnLineParam
:: Point2 -- ^ First line point.
-> Point2 -- ^ Second line point.
-> Point2 -- ^ Point not on line.
-> Float
{-# INLINE closestPointOnLineParam #-}
closestPointOnLineParam !a !b !p
= (p -.- a) `dotV` (b -.- a) / (b -.- a) `dotV` (b -.- a)
-- | Given a segment and external point, find the closest point on the segment. {- | Given a line and a point return a value corresponding to how far along the
-- clamps to the end of the segment line the point is.
-}
closestPointOnLineParam ::
-- | First line point.
Point2 ->
-- | Second line point.
Point2 ->
-- | Point not on line.
Point2 ->
Float
{-# INLINE closestPointOnLineParam #-}
closestPointOnLineParam !a !b !p =
(p -.- a) `dotV` (b -.- a) / (b -.- a) `dotV` (b -.- a)
{- | Given a segment and external point, find the closest point on the segment.
clamps to the end of the segment
-}
closestPointOnSeg :: Point2 -> Point2 -> Point2 -> Point2 closestPointOnSeg :: Point2 -> Point2 -> Point2 -> Point2
closestPointOnSeg segP1 segP2 p closestPointOnSeg segP1 segP2 p
| closestPointOnLineParam segP1 segP2 p <= 0 = segP1 | closestPointOnLineParam segP1 segP2 p <= 0 = segP1
| closestPointOnLineParam segP1 segP2 p >= 1 = segP2 | closestPointOnLineParam segP1 segP2 p >= 1 = segP2
| otherwise = closestPointOnLine segP1 segP2 p | otherwise = closestPointOnLine segP1 segP2 p
-- | Given a segment and external point, find the closest point on the segment. {- | Given a segment and external point, find the closest point on the segment.
-- does not return closest points beyond the segment does not return closest points beyond the segment
-}
orthogonalPointOnSeg :: Point2 -> Point2 -> Point2 -> Maybe Point2 orthogonalPointOnSeg :: Point2 -> Point2 -> Point2 -> Maybe Point2
orthogonalPointOnSeg a b p orthogonalPointOnSeg a b p
| param < 0 || param > 1 = Nothing | param < 0 || param > 1 = Nothing
| otherwise = Just $ a +.+ param *.* normalizeV (b -.- a) | otherwise = Just $ a +.+ param *.* normalizeV (b -.- a)
where where
param = closestPointOnLineParam a b p param = closestPointOnLineParam a b p
@@ -257,9 +301,9 @@ inSegArea a b c = param >= 0 && param <= dotV (b -.- a) (b -.- a)
param = dotV (b -.- a) (c -.- a) param = dotV (b -.- a) (c -.- a)
intersectCircSeg :: Point2 -> Float -> Point2 -> Point2 -> [Point2] intersectCircSeg :: Point2 -> Float -> Point2 -> Point2 -> [Point2]
intersectCircSeg c r a b intersectCircSeg c r a b
| y < 0 = [] | y < 0 = []
| otherwise = nub $ filter (inSegArea a b) [ d -.- v, d +.+ v ] | otherwise = nub $ filter (inSegArea a b) [d -.- v, d +.+ v]
where where
d = closestPointOnLine a b c d = closestPointOnLine a b c
x = dist d c x = dist d c
src/Loop.hs
+2
View File
@@ -24,6 +24,8 @@ import SDL
import System.Mem import System.Mem
import Data.Foldable import Data.Foldable
-- the following can break if passed a window config not set up for opengl
-- | Create a game loop with an SDL window. -- | Create a game loop with an SDL window.
setupLoop :: setupLoop ::
-- | Target seconds per frame -- | Target seconds per frame
src/Preload/Render.hs
+1 -1
View File
@@ -131,7 +131,7 @@ preloadRender = do
-- lighting shaders -- lighting shaders
lightingWallShadShad <- lightingWallShadShad <-
makeShaderUsingVAO "lighting/wallShadow" [vert, geom, frag] EPoints wpVAO makeShaderUsingVAO "lighting/wallShadow" [vert, geom, frag] EPoints wpVAO
>>= addUniforms ["lightPos"] >>= addUniforms ["lightPos","rad"]
lightingCapShad <- lightingCapShad <-
makeShaderUsingVAO "lighting/cap" [vert, geom] ETriangles shPosVAO makeShaderUsingVAO "lighting/cap" [vert, geom] ETriangles shPosVAO
>>= addUniforms ["lightPos"] >>= addUniforms ["lightPos"]
src/Render.hs
+21 -27
View File
@@ -50,6 +50,7 @@ createLightMap ::
createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype toPos drawCPUShadows = case shadsdrawtype of createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype toPos drawCPUShadows = case shadsdrawtype of
InstancingShads -> instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos InstancingShads -> instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos
NoShadows -> do NoShadows -> do
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
let ltextShad = _lightingTextureShader pdata let ltextShad = _lightingTextureShader pdata
-- we assume that the renderbuffer's depth has been correctly set elsewhere -- we assume that the renderbuffer's depth has been correctly set elsewhere
-- we will not be changing that here -- we will not be changing that here
@@ -64,10 +65,7 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype toPos dra
-- to consider: adding normals/a "material" for each fragment -- to consider: adding normals/a "material" for each fragment
glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR
glEnable GL_STENCIL_TEST glEnable GL_STENCIL_TEST
--stencilTest $= Enabled
glStencilOpSeparate GL_FRONT GL_KEEP GL_KEEP GL_INCR_WRAP glStencilOpSeparate GL_FRONT GL_KEEP GL_KEEP GL_INCR_WRAP
--stencilOpSeparate Front $= (OpKeep, OpKeep, OpIncrWrap)
--stencilOpSeparate Back $= (OpKeep, OpKeep, OpDecrWrap)
glStencilOpSeparate GL_BACK GL_KEEP GL_KEEP GL_DECR_WRAP glStencilOpSeparate GL_BACK GL_KEEP GL_KEEP GL_DECR_WRAP
flip VFSM.mapM_ (VFSM.fromList lightPoints) $ \(V3 x y z, rad, V3 r g b) -> do flip VFSM.mapM_ (VFSM.fromList lightPoints) $ \(V3 x y z, rad, V3 r g b) -> do
glDepthFunc GL_LESS glDepthFunc GL_LESS
@@ -75,7 +73,6 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype toPos dra
glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE
glClear GL_STENCIL_BUFFER_BIT glClear GL_STENCIL_BUFFER_BIT
glDisable GL_CULL_FACE glDisable GL_CULL_FACE
--cullFace $= Nothing
glStencilFunc GL_ALWAYS 0 255 glStencilFunc GL_ALWAYS 0 255
--draw lightmap itself --draw lightmap itself
glDepthFunc GL_ALWAYS glDepthFunc GL_ALWAYS
@@ -83,7 +80,7 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype toPos dra
bindTO toPos bindTO toPos
glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE
glStencilFunc GL_EQUAL 0 255 glStencilFunc GL_EQUAL 0 255
glUseProgram (ltextShad ^. shadProg') --Just (_shadProg ltextShad) glUseProgram (ltextShad ^. shadName) --Just (_shadProg ltextShad)
glUniform3f (_shadUnis' ltextShad V.! 0) x y z glUniform3f (_shadUnis' ltextShad V.! 0) x y z
glUniform4f (_shadUnis' ltextShad V.! 1) r g b rad glUniform4f (_shadUnis' ltextShad V.! 1) r g b rad
--bindVertexArrayObject $= ltextShad ^? shadVAO' . vaoName -- Just (_vao $ _shadVAO ltextShad) --bindVertexArrayObject $= ltextShad ^? shadVAO' . vaoName -- Just (_vao $ _shadVAO ltextShad)
@@ -107,6 +104,7 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype toPos dra
glDepthFunc GL_ALWAYS glDepthFunc GL_ALWAYS
glDepthMask GL_FALSE glDepthMask GL_FALSE
_ -> do _ -> do
glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
let llinesShad = _lightingLineShadowShader pdata let llinesShad = _lightingLineShadowShader pdata
lcapShad = _lightingCapShader pdata lcapShad = _lightingCapShader pdata
lwallShad = _lightingWallShadShader pdata lwallShad = _lightingWallShadShader pdata
@@ -124,10 +122,7 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype toPos dra
-- to consider: adding normals/a "material" for each fragment -- to consider: adding normals/a "material" for each fragment
glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR
glEnable GL_STENCIL_TEST glEnable GL_STENCIL_TEST
--stencilTest $= Enabled
glStencilOpSeparate GL_FRONT GL_KEEP GL_KEEP GL_INCR_WRAP glStencilOpSeparate GL_FRONT GL_KEEP GL_KEEP GL_INCR_WRAP
--stencilOpSeparate Front $= (OpKeep, OpKeep, OpIncrWrap)
--stencilOpSeparate Back $= (OpKeep, OpKeep, OpDecrWrap)
glStencilOpSeparate GL_BACK GL_KEEP GL_KEEP GL_DECR_WRAP glStencilOpSeparate GL_BACK GL_KEEP GL_KEEP GL_DECR_WRAP
flip VFSM.mapM_ (VFSM.fromList lightPoints) $ \(V3 x y z, rad, V3 r g b) -> do flip VFSM.mapM_ (VFSM.fromList lightPoints) $ \(V3 x y z, rad, V3 r g b) -> do
glDepthFunc GL_LESS glDepthFunc GL_LESS
@@ -135,15 +130,11 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype toPos dra
glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE
glClear GL_STENCIL_BUFFER_BIT glClear GL_STENCIL_BUFFER_BIT
glDisable GL_CULL_FACE glDisable GL_CULL_FACE
--cullFace $= Nothing
glStencilFunc GL_ALWAYS 0 255 glStencilFunc GL_ALWAYS 0 255
--draw wall shadows --draw wall shadows
--currentProgram $= Just (_shadProg lwallShad) glUseProgram (_shadName lwallShad)
glUseProgram (_shadProg' lwallShad)
--uniform (_shadUnis lwallShad V.! 0)
-- $= Vector3 x y z
glUniform3f (_shadUnis' lwallShad V.! 0) x y z glUniform3f (_shadUnis' lwallShad V.! 0) x y z
--bindVertexArrayObject $= lwallShad ^? shadVAO' . vaoName -- Just (_vao $ _shadVAO lwallShad) glUniform1f (_shadUnis' lwallShad V.! 1) rad
glBindVertexArray $ lwallShad ^. shadVAO' . vaoName -- Just (_vao $ _shadVAO lwallShad) glBindVertexArray $ lwallShad ^. shadVAO' . vaoName -- Just (_vao $ _shadVAO lwallShad)
glDrawArrays glDrawArrays
(marshalEPrimitiveMode $ _shadPrim' lwallShad) (marshalEPrimitiveMode $ _shadPrim' lwallShad)
@@ -152,7 +143,8 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype toPos dra
case shadsdrawtype of case shadsdrawtype of
GeoObjShads -> do GeoObjShads -> do
--draw silhouette shadows --draw silhouette shadows
glUseProgram (_shadProg' llinesShad) glEnable GL_DEPTH_CLAMP
glUseProgram (_shadName llinesShad)
glUniform3f (_shadUnis' llinesShad V.! 0) x y z glUniform3f (_shadUnis' llinesShad V.! 0) x y z
glUniform1f (_shadUnis' llinesShad V.! 1) rad glUniform1f (_shadUnis' llinesShad V.! 1) rad
glBindVertexArray (_vaoName $ _shadVAO' llinesShad) glBindVertexArray (_vaoName $ _shadVAO' llinesShad)
@@ -164,7 +156,8 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype toPos dra
--draw caps on the near plane as required --draw caps on the near plane as required
glEnable GL_CULL_FACE glEnable GL_CULL_FACE
glCullFace GL_BACK glCullFace GL_BACK
glUseProgram (_shadProg' lcapShad) glCullFace GL_FRONT
glUseProgram (_shadName lcapShad)
glUniform3f (_shadUnis' lcapShad V.! 0) x y z glUniform3f (_shadUnis' lcapShad V.! 0) x y z
glBindVertexArray $ lcapShad ^. shadVAO' . vaoName --Just (_vao $ _shadVAO lcapShad) glBindVertexArray $ lcapShad ^. shadVAO' . vaoName --Just (_vao $ _shadVAO lcapShad)
glDrawElements glDrawElements
@@ -172,15 +165,17 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype toPos dra
(fromIntegral nCaps) (fromIntegral nCaps)
GL_UNSIGNED_SHORT GL_UNSIGNED_SHORT
nullPtr nullPtr
glDisable GL_DEPTH_CLAMP
CPUObjShads -> drawCPUShadows (V3 x y z) rad CPUObjShads -> drawCPUShadows (V3 x y z) rad
NoObjShads -> return () NoObjShads -> return ()
--draw lightmap itself --draw lightmap itself
glDepthFunc GL_ALWAYS glDepthFunc GL_ALWAYS
-- bind world position texture -- bind world position texture
glDisable GL_CULL_FACE
bindTO toPos bindTO toPos
glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE
glStencilFunc GL_EQUAL 0 255 glStencilFunc GL_EQUAL 0 255
glUseProgram (ltextShad ^. shadProg') --Just (_shadProg ltextShad) glUseProgram (ltextShad ^. shadName) --Just (_shadProg ltextShad)
glUniform3f (_shadUnis' ltextShad V.! 0) x y z glUniform3f (_shadUnis' ltextShad V.! 0) x y z
glUniform4f (_shadUnis' ltextShad V.! 1) r g b rad glUniform4f (_shadUnis' ltextShad V.! 1) r g b rad
--bindVertexArrayObject $= ltextShad ^? shadVAO' . vaoName -- Just (_vao $ _shadVAO ltextShad) --bindVertexArrayObject $= ltextShad ^? shadVAO' . vaoName -- Just (_vao $ _shadVAO ltextShad)
@@ -190,7 +185,6 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype toPos dra
0 0
(fromIntegral (4 :: Int)) (fromIntegral (4 :: Int))
--cleanup: may not be necessary, depending on what comes after... --cleanup: may not be necessary, depending on what comes after...
glDisable GL_CULL_FACE
glDisable GL_STENCIL_TEST glDisable GL_STENCIL_TEST
lightsToArray :: [(Point3, Float, Point3)] -> [Float] lightsToArray :: [(Point3, Float, Point3)] -> [Float]
@@ -252,14 +246,14 @@ instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos = do
glDisable GL_CULL_FACE glDisable GL_CULL_FACE
glStencilFunc GL_ALWAYS 0 255 glStencilFunc GL_ALWAYS 0 255
--draw wall shadows --draw wall shadows
glUseProgram $ pdata ^. shadowWallShader . shadProg' glUseProgram $ pdata ^. shadowWallShader . shadName
glBindVertexArray $ pdata ^. shadowWallShader . shadVAO' . vaoName -- Just (_vao $ _shadVAO lwallShad) glBindVertexArray $ pdata ^. shadowWallShader . shadVAO' . vaoName
glDrawArrays glDrawArrays
(marshalEPrimitiveMode $ pdata ^. shadowWallShader . shadPrim') (marshalEPrimitiveMode $ pdata ^. shadowWallShader . shadPrim')
0 0
(fromIntegral nWalls) (fromIntegral nWalls)
--draw silhouette shadows --draw silhouette shadows
glUseProgram $ pdata ^. shadowEdgeShader . shadProg' glUseProgram $ pdata ^. shadowEdgeShader . shadName
glBindVertexArray $ pdata ^. shadowEdgeShader . shadVAO' . vaoName glBindVertexArray $ pdata ^. shadowEdgeShader . shadVAO' . vaoName
glDrawElements glDrawElements
(marshalEPrimitiveMode $ pdata ^. shadowEdgeShader . shadPrim') (marshalEPrimitiveMode $ pdata ^. shadowEdgeShader . shadPrim')
@@ -267,9 +261,10 @@ instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos = do
GL_UNSIGNED_SHORT GL_UNSIGNED_SHORT
nullPtr nullPtr
--draw caps on the near plane as required --draw caps on the near plane as required
glEnable GL_CULL_FACE --glEnable GL_CULL_FACE
glCullFace GL_BACK glCullFace GL_BACK
glUseProgram (_shadProg' lcapShad) --glCullFace GL_FRONT
glUseProgram (_shadName lcapShad)
glBindVertexArray $ lcapShad ^. shadVAO' . vaoName glBindVertexArray $ lcapShad ^. shadVAO' . vaoName
glDrawElements glDrawElements
(marshalEPrimitiveMode $ _shadPrim' lcapShad) (marshalEPrimitiveMode $ _shadPrim' lcapShad)
@@ -280,15 +275,14 @@ instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos = do
glDepthFunc GL_ALWAYS glDepthFunc GL_ALWAYS
glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE
glStencilFunc GL_EQUAL 0 255 glStencilFunc GL_EQUAL 0 255
glUseProgram (pdata ^. shadowLightShader . shadProg') glUseProgram (pdata ^. shadowLightShader . shadName)
-- bind world position texture -- bind world position texture
bindTO toPos bindTO toPos
glBindVertexArray $ pdata ^. shadowLightShader . shadVAO' . vaoName -- glBindVertexArray $ pdata ^. shadowLightShader . shadVAO' . vaoName
glDrawArrays glDrawArrays
(marshalEPrimitiveMode $ pdata ^. shadowLightShader . shadPrim') (marshalEPrimitiveMode $ pdata ^. shadowLightShader . shadPrim')
0 0
1 1
-- this was the end of the loop
glDisable GL_CULL_FACE glDisable GL_CULL_FACE
glDisable GL_STENCIL_TEST glDisable GL_STENCIL_TEST
--draw to the lighting framebuffer here --draw to the lighting framebuffer here
@@ -298,7 +292,7 @@ instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos = do
glBindTexture GL_TEXTURE_2D_ARRAY (pdata ^. fboShadow . _2 . _1 . unTO) glBindTexture GL_TEXTURE_2D_ARRAY (pdata ^. fboShadow . _2 . _1 . unTO)
glEnable GL_BLEND glEnable GL_BLEND
glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR
glUseProgram (pdata ^. shadowCombineShader . shadProg') --Just (_shadProg ltextShad) glUseProgram (pdata ^. shadowCombineShader . shadName)
glDrawArrays glDrawArrays
(marshalEPrimitiveMode EPoints) (marshalEPrimitiveMode EPoints)
0 0
src/Shader.hs
+2 -2
View File
@@ -26,7 +26,7 @@ drawShaderLay :: Int -> UMV.MVector (PrimState IO) Int -> Int -> FullShader -> I
drawShaderLay l countsVector shadIn fs = do drawShaderLay l countsVector shadIn fs = do
i <- UMV.read countsVector shadIn i <- UMV.read countsVector shadIn
--currentProgram $= Just (_shadProg' fs) --currentProgram $= Just (_shadProg' fs)
glUseProgram (_shadProg' fs) glUseProgram (_shadName fs)
glBindVertexArray $ fs ^. shadVAO' . vaoName glBindVertexArray $ fs ^. shadVAO' . vaoName
--bindVertexArrayObject $= Just (_vaoName $ _shadVAO' fs) --bindVertexArrayObject $= Just (_vaoName $ _shadVAO' fs)
case _shadTex' fs of case _shadTex' fs of
@@ -44,7 +44,7 @@ drawShader :: FullShader -> Int -> IO ()
{-# INLINE drawShader #-} {-# INLINE drawShader #-}
drawShader fs i = do drawShader fs i = do
--currentProgram $= Just (_shadProg fs) --currentProgram $= Just (_shadProg fs)
glUseProgram (_shadProg' fs) glUseProgram (_shadName fs)
glBindVertexArray $ fs ^. shadVAO' . vaoName glBindVertexArray $ fs ^. shadVAO' . vaoName
--bindVertexArrayObject $= Just (_vaoName $ _shadVAO' fs) --bindVertexArrayObject $= Just (_vaoName $ _shadVAO' fs)
case _shadTex' fs of case _shadTex' fs of
src/Shader/AuxAddition.hs
+1 -1
View File
@@ -91,5 +91,5 @@ addUniforms uniStrings shad = do foldM addUniform shad uniStrings
addUniform :: FullShader -> String -> IO FullShader addUniform :: FullShader -> String -> IO FullShader
addUniform shad unistr = BS.useAsCString (pack unistr) $ \cstr -> do addUniform shad unistr = BS.useAsCString (pack unistr) $ \cstr -> do
loc <- glGetUniformLocation (_shadProg' shad) cstr loc <- glGetUniformLocation (_shadName shad) cstr
return $ shad & shadUnis' %~ (V.++ V.fromList [loc]) return $ shad & shadUnis' %~ (V.++ V.fromList [loc])
src/Shader/Compile.hs
+4 -4
View File
@@ -35,7 +35,7 @@ makeShader s shaderlist sizes pm = do
vaob <- setupVAO sizes vaob <- setupVAO sizes
return $ return $
FullShader FullShader
{ _shadProg' = prog { _shadName = prog
, _shadVAO' = vaob , _shadVAO' = vaob
, _shadPrim' = pm , _shadPrim' = pm
, _shadTex' = Nothing , _shadTex' = Nothing
@@ -54,7 +54,7 @@ makeByteStringShaderUsingVAO s shaderlist pm vao = do
prog <- makeShaderProgram s shaderlist prog <- makeShaderProgram s shaderlist
return $ return $
FullShader FullShader
{ _shadProg' = prog { _shadName = prog
, _shadVAO' = vao , _shadVAO' = vao
, _shadPrim' = pm , _shadPrim' = pm
, _shadTex' = Nothing , _shadTex' = Nothing
@@ -74,7 +74,7 @@ makeShaderUsingVAO s shaderlist pm theVAO = do
prog <- makeSourcedShader s shaderlist prog <- makeSourcedShader s shaderlist
return $ return $
FullShader FullShader
{ _shadProg' = prog { _shadName = prog
, _shadVAO' = theVAO , _shadVAO' = theVAO
, _shadPrim' = pm , _shadPrim' = pm
, _shadTex' = Nothing , _shadTex' = Nothing
@@ -101,7 +101,7 @@ makeShaderSized s shaderlist sizes ndraw pm = do
vaob <- setupVAOSized ndraw sizes vaob <- setupVAOSized ndraw sizes
return $ return $
FullShader FullShader
{ _shadProg' = prog { _shadName = prog
, _shadVAO' = vaob , _shadVAO' = vaob
, _shadPrim' = pm , _shadPrim' = pm
, _shadTex' = Nothing , _shadTex' = Nothing
src/Shader/Data.hs
+2 -2
View File
@@ -19,7 +19,7 @@ module Shader.Data
, eboName , eboName
, eboPtr , eboPtr
, shadProg' , shadName
, shadVAO' , shadVAO'
, shadPrim' , shadPrim'
, shadTex' , shadTex'
@@ -35,7 +35,7 @@ import Foreign
import Control.Lens import Control.Lens
{- | Datatype containing the necessary information for a single shader. -} {- | Datatype containing the necessary information for a single shader. -}
data FullShader = FullShader data FullShader = FullShader
{ _shadProg' :: GLuint -- should be shaderID { _shadName :: GLuint -- should be shaderID
, _shadVAO' :: VAO , _shadVAO' :: VAO
, _shadPrim' :: EPrimitiveMode , _shadPrim' :: EPrimitiveMode
, _shadTex' :: Maybe ShaderTexture , _shadTex' :: Maybe ShaderTexture