From 6af041bb8c7d81d92eeb6de913d3c95e83c8dde3 Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 14 Mar 2023 11:20:38 +0000 Subject: [PATCH] Continue work on shadow rendering --- package.yaml | 16 -- shader/lighting/cap.geom | 6 +- shader/lighting/lineShadow.geom | 146 +++++++------ shader/lighting/texture.frag | 18 +- shader/lighting/wallShadow.geom | 120 +++++------ shader/shadow/wallShadow.geom | 13 ++ src/Dodge/Default/LightSource.hs | 2 +- src/Dodge/LightSource.hs | 21 +- src/Dodge/Render.hs | 39 ++-- src/Dodge/Render/Shadow.hs | 2 +- src/Dodge/Room/RezBox.hs | 2 +- src/Dodge/Room/RunPast.hs | 2 +- src/Geometry/Intersect.hs | 342 +++++++++++++++++-------------- src/Loop.hs | 2 + src/Preload/Render.hs | 2 +- src/Render.hs | 48 ++--- src/Shader.hs | 4 +- src/Shader/AuxAddition.hs | 2 +- src/Shader/Compile.hs | 8 +- src/Shader/Data.hs | 4 +- 20 files changed, 418 insertions(+), 381 deletions(-) diff --git a/package.yaml b/package.yaml index 56b5cf395..5429ecffd 100644 --- a/package.yaml +++ b/package.yaml @@ -22,26 +22,18 @@ description: Description text, TODO link to README.md dependencies: - base >= 4.7 && < 5 - containers - #- strict-containers - #- strict-containers-lens - unordered-containers - #- bitwise-enum - graphviz - template-haskell - #- heap - sdl2 - sdl2-mixer - #- OpenGL - OpenGLRaw - text - #- raw-strings-qq - bytestring - lens - mtl - fgl - random - #- bmp - #- monad-loops - JuicyPixels - vector - dlist @@ -52,23 +44,15 @@ dependencies: - aeson - aeson-pretty #- store - #- binary - #- flat - #- th-utilities - directory - extra - primitive - #- streaming - #- repa - monad-parallel - parallel - Clipboard - # testing - tasty - tasty-hunit - tasty-quickcheck - #- QuickCheck - #- HUnit library: source-dirs: src diff --git a/shader/lighting/cap.geom b/shader/lighting/cap.geom index 4280f8e2e..cf52d5585 100644 --- a/shader/lighting/cap.geom +++ b/shader/lighting/cap.geom @@ -9,9 +9,9 @@ vec4 projNear (vec4 pos) // note we project to a specific height // this is quite brittle, not ideal 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 ; - return vec4 ( xy, 140 , 1) ; + return vec4 ( xy, 100 , 1) ; } void main() { @@ -28,8 +28,8 @@ void main() // the front cap vec4 v1 = vec4 (0,0,1,0) ; gl_Position = theMat * projNear(p0); EmitVertex(); - gl_Position = theMat * projNear(p1); EmitVertex(); gl_Position = theMat * projNear(p2); EmitVertex(); + gl_Position = theMat * projNear(p1); EmitVertex(); EndPrimitive(); } else {} diff --git a/shader/lighting/lineShadow.geom b/shader/lighting/lineShadow.geom index 9ac73d296..4eef0cc3c 100644 --- a/shader/lighting/lineShadow.geom +++ b/shader/lighting/lineShadow.geom @@ -1,71 +1,91 @@ #version 450 core -layout (lines_adjacency) in; -layout (triangle_strip, max_vertices = 4) out; -layout (std140, binding = 0) uniform TheMat { mat4 theMat; } ; +layout(lines_adjacency) in; +layout(triangle_strip, max_vertices = 4) out; +layout(std140, binding = 0) uniform TheMat { mat4 theMat; }; uniform vec3 lightPos; 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 + (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));} +// vec4 shift (vec4 p) { return (vec4 (p.xyz + +// (lumRad.a*normalize(p.xyz-lightPos)), 1));} +float closestPointOnLineParam3 (vec3 a, vec3 b, vec3 p) { + 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 -vec4 projNear (vec4 pos) -{ - // note we project to a specific height - // this is quite brittle, not ideal - vec3 dir = pos.xyz - lightPos ; - float a = (140 - pos.z) / dir.z ; - vec2 xy = (pos.xyz + a * dir).xy ; - return vec4 ( xy, 140 , 1) ; +vec4 projNear(vec4 pos) { + // note we project to a specific height + // this is quite brittle, not ideal + vec3 dir = pos.xyz - lightPos; + float a = (100 - pos.z) / dir.z; + vec2 xy = (pos.xyz + a * dir).xy; + return vec4(xy, 100, 1); } -vec4 shiftNear (vec4 pos) +vec4 shiftNear(vec4 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 p0 = gl_in[0].gl_Position; - vec4 p1 = gl_in[1].gl_Position; - vec4 mid = 0.5*(p0 + p1); - vec3 n0a = gl_in[2].gl_Position.xyz; - 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) ; - - //vec3 n2 = n0 + n1; // assumes the summands are normalized - vec3 lightDir = p0.xyz - lightPos.xyz; - vec3 lightDir2 = p1.xyz - lightPos.xyz; - // 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 - // "different directions" wrt the light direction - if ( dot(n0 , lightDir) * dot(n1 , lightDir) <= 0 && - (dot(lightDir,lightDir) < ru2 || dot(lightDir2,lightDir2) < ru2) ) - // using <= rather than < seems to get rid of overlapping shadow - // artefacts - { - vec4 p2 = shiftNear(p0); - vec4 p3 = shiftNear(p1); - if ( dot(n0 , lightDir) > 0) - { - gl_Position = f(p0); EmitVertex(); - gl_Position = f(p1); EmitVertex(); - gl_Position = f(p2); EmitVertex(); - gl_Position = f(p3); EmitVertex(); - } - else - { - gl_Position = f(p1); EmitVertex(); - gl_Position = f(p0); EmitVertex(); - gl_Position = f(p3); EmitVertex(); - gl_Position = f(p2); EmitVertex(); - } - EndPrimitive(); - } - else { } + vec4 sp = shift(pos); + if (sp.z > 100) { + return projNear(pos); + } else { + return sp; + } +} +vec4 f(vec4 p) { return (theMat * p); } +void main() { +vec4 p0 = gl_in[0].gl_Position; +vec4 p1 = gl_in[1].gl_Position; +vec3 closepoint = closestPointOnSeg3(p0.xyz,p1.xyz,lightPos); + float ru2 = radiusUniform * radiusUniform; + vec4 mid = 0.5 * (p0 + p1); + vec3 n0a = gl_in[2].gl_Position.xyz; + 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); + + // vec3 n2 = n0 + n1; // assumes the summands are normalized + vec3 lightDir = p0.xyz - lightPos.xyz; + vec3 lightDir2 = p1.xyz - lightPos.xyz; + // 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 + // "different directions" wrt the light direction + if (dot(n0, lightDir) * dot(n1, lightDir) <= 0 && + (dot(lightDir, lightDir) < ru2 || dot(lightDir2, lightDir2) < ru2)) + // using <= rather than < seems to get rid of overlapping shadow + // artefacts + { + //vec4 p2 = shiftNear(p0); + //vec4 p3 = shiftNear(p1); + vec4 p2 = shiftNear(p0); + vec4 p3 = shiftNear(p1); + gl_Position = f(p0); + EmitVertex(); + if (dot(n0, lightDir) > 0) { + gl_Position = f(p2); + EmitVertex(); + gl_Position = f(p1); + EmitVertex(); + } else { + gl_Position = f(p1); + EmitVertex(); + gl_Position = f(p2); + EmitVertex(); + } + gl_Position = f(p3); + EmitVertex(); + EndPrimitive(); + } else { + } } diff --git a/shader/lighting/texture.frag b/shader/lighting/texture.frag index 02a39c23d..d4998858b 100644 --- a/shader/lighting/texture.frag +++ b/shader/lighting/texture.frag @@ -4,12 +4,14 @@ uniform vec4 lumRad; uniform sampler2D screenTexture; in vec2 vTexPos; out vec4 fColor; -void main() -{ - vec3 distVec = texture(screenTexture,vTexPos).xyz - lightPos; - float dist = dot(distVec,distVec); - if (dist > lumRad.a) {discard;} - float x = 1 - dist / lumRad.a ; - vec3 c = (x * x * x) * lumRad.rgb ; - fColor = vec4(c,0); +float rad = lumRad.a; +void main() { + vec3 distVec = texture(screenTexture, vTexPos).xyz - lightPos; + float dist = dot(distVec, distVec); + if (dist > rad) { + discard; + } + float x = 1 - dist / rad; + vec3 c = (x * x * x) * lumRad.rgb; + fColor = vec4(c, 0); } diff --git a/shader/lighting/wallShadow.geom b/shader/lighting/wallShadow.geom index c1ac9a941..017b549a5 100644 --- a/shader/lighting/wallShadow.geom +++ b/shader/lighting/wallShadow.geom @@ -1,68 +1,68 @@ #version 450 core -layout (points) in; -layout (triangle_strip, max_vertices = 8) out; -layout (std140, binding = 0) uniform TheMat { mat4 theMat; } ; +layout(points) in; +layout(triangle_strip, max_vertices = 18) out; +layout(std140, binding = 0) uniform TheMat { mat4 theMat; }; uniform vec3 lightPos; -vec4 shift (vec4 p) -{ return vec4 (p.xy + (200 * (p.xy-lightPos.xy)), 0 , 1); +uniform float rad; +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) -{ - return sign( -startV.x * testV.y + startV.y * testV.x); +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.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 -void main() -{ -vec4 p1 = vec4 (gl_in[0].gl_Position.xy,0,1); -vec4 p2 = vec4 (gl_in[0].gl_Position.zw,0,1); -if (isLHS (p1.xy - lightPos.xy, p2.xy - lightPos.xy) < 0) -{ -vec4 p3 = vec4 (p1.xy,100,1); -vec4 p4 = vec4 (p2.xy,100,1); -vec4 p5 = shift(p1); -vec4 p6 = shift(p2); -vec4 p7 = vec4 (p6.xy,100,1); -vec4 p8 = vec4 (p5.xy,100,1); +void main() { + vec2 p1 = gl_in[0].gl_Position.xy; + vec2 p2 = gl_in[0].gl_Position.zw; + vec2 closepoint = closestPointOnSeg(p1,p2,lightPos.xy); + if (isLHS(p1 - lightPos.xy, p2 - lightPos.xy) < 0 && distance(closepoint,lightPos.xy) < rad2) { + vec2 closeshift = (rad2 * normalize(closepoint - lightPos.xy)) + lightPos.xy - closepoint; + vec2 p1cs = p1 + closeshift; + vec2 p1o = vec2( distance(p1,lightPos.xy) > rad2 ? p1cs : shift(p1) ); + vec2 p2cs = p2 + closeshift; + vec2 p2o = vec2( distance(p2,lightPos.xy) > rad2 ? p2cs : shift(p2) ); -vec4 a1 = theMat * p1; -vec4 a2 = theMat * p2; -vec4 a3 = theMat * p3; -vec4 a4 = theMat * p4; -vec4 a5 = theMat * p5; -vec4 a6 = theMat * p6; -vec4 a7 = theMat * p7; -vec4 a8 = theMat * p8; + gl_Position = theMat * vec4(p1o,0,1); EmitVertex(); + gl_Position = theMat * vec4(p1,0,1); EmitVertex(); + gl_Position = theMat * vec4(p1o,100,1); EmitVertex(); + gl_Position = theMat * vec4(p1,100,1); EmitVertex(); + gl_Position = theMat * vec4(p1cs,100,1); EmitVertex(); + gl_Position = theMat * vec4(p2,100,1); EmitVertex(); + gl_Position = theMat * vec4(p2cs,100,1); EmitVertex(); + gl_Position = theMat * vec4(p2o,100,1); EmitVertex(); + EndPrimitive(); - //gl_Position = a4; EmitVertex(); - //gl_Position = a3; EmitVertex(); - //gl_Position = a7; EmitVertex(); - //gl_Position = a8; EmitVertex(); - //gl_Position = a5; EmitVertex(); - //gl_Position = a3; EmitVertex(); - //gl_Position = a1; EmitVertex(); - //gl_Position = a4; EmitVertex(); - //gl_Position = a2; EmitVertex(); - //gl_Position = a7; EmitVertex(); - //gl_Position = a6; EmitVertex(); - - gl_Position = a1; EmitVertex(); - gl_Position = a5; EmitVertex(); - gl_Position = a3; EmitVertex(); - gl_Position = a8; EmitVertex(); - gl_Position = a4; EmitVertex(); - gl_Position = a7; EmitVertex(); - 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 {} +// gl_Position = theMat * vec4(p2o,100,1); EmitVertex(); +// gl_Position = theMat * vec4(p2,100,1); EmitVertex(); +// gl_Position = theMat * vec4(p2o,0,1); EmitVertex(); +// gl_Position = theMat * vec4(p2,0,1); EmitVertex(); + + gl_Position = theMat * vec4(p2,100,1); EmitVertex(); + gl_Position = theMat * vec4(p2,0,1); EmitVertex(); + gl_Position = theMat * vec4(p2o,100,1); EmitVertex(); + gl_Position = theMat * vec4(p2o,0,1); EmitVertex(); + gl_Position = theMat * vec4(p2cs,100,1); EmitVertex(); + gl_Position = theMat * vec4(p2cs,0,1); EmitVertex(); + gl_Position = theMat * vec4(p1cs,100,1); EmitVertex(); + gl_Position = theMat * vec4(p1cs,0,1); EmitVertex(); + gl_Position = theMat * vec4(p1o,100,1); EmitVertex(); + gl_Position = theMat * vec4(p1o,0,1); EmitVertex(); + + EndPrimitive(); + } else { + } } diff --git a/shader/shadow/wallShadow.geom b/shader/shadow/wallShadow.geom index bf688fb0f..81f640e8f 100644 --- a/shader/shadow/wallShadow.geom +++ b/shader/shadow/wallShadow.geom @@ -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) { 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 void main() { vec4 p1 = vec4(gl_in[0].gl_Position.xy, 0, 1); diff --git a/src/Dodge/Default/LightSource.hs b/src/Dodge/Default/LightSource.hs index fb6e1adf6..a6ef6aa06 100644 --- a/src/Dodge/Default/LightSource.hs +++ b/src/Dodge/Default/LightSource.hs @@ -10,7 +10,7 @@ defaultLS = , _lsParam = LSParam { _lsPos = V3 0 0 50 - , _lsRad = 700 + , _lsRad = 450 , _lsCol = 0.6 } , _lsDir = 0 diff --git a/src/Dodge/LightSource.hs b/src/Dodge/LightSource.hs index bd9ca1c94..f140cae51 100644 --- a/src/Dodge/LightSource.hs +++ b/src/Dodge/LightSource.hs @@ -2,9 +2,7 @@ module Dodge.LightSource ( tlsTimeRadFunPos, tlsTimeRadColPos, lsRadCol, - lsPosRadCol, lsColPosRad, - lsPosColRad, lsColPos, lsPosCol, lsPosRad, @@ -46,27 +44,22 @@ tlsTimeRadFunPos t rmax intensityF p = -- & tlsParam . lsCol .~ f (intensityF (_tlsTime tls) ) -- 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 col p i = lsColPos col p & lsID .~ i lsColPos :: Point3 -> Point3 -> LightSource -lsColPos col pos = lsColPosRad col pos 700 +lsColPos col pos = lsColPosRad col pos 450 lsPosCol :: Point3 -> Point3 -> LightSource lsPosCol pos col = lsColPos col pos 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 r col = diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 9829caa0e..de6b78d8d 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -114,14 +114,18 @@ doDrawing' win pdata u = do glClear $ sum [GL_COLOR_BUFFER_BIT, GL_DEPTH_BUFFER_BIT] glDepthFunc GL_LESS -- 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 + glUniform1f (pdata ^?! lightingWallShadShader . shadUnis' . ix 1) 100 glBindVertexArray $ pdata ^. lightingWallShadShader . shadVAO' . vaoName unless (debugOn Remove_LOS cfig) $ glDrawArrays (marshalEPrimitiveMode $ pdata ^. lightingWallShadShader . shadPrim') 0 (fromIntegral nWalls) +-- glDisable GL_CULL_FACE --draw walls onto base buffer if cfig ^. graphics_wall_textured then renderTextureWalls pdata nWalls @@ -130,7 +134,7 @@ doDrawing' win pdata u = do renderLayer BottomLayer shadV layerCounts --draw object shapes onto base buffer let fs = _shapeShader pdata - glUseProgram (_shadProg' fs) + glUseProgram (_shadName fs) glBindVertexArray $ fs ^. shadVAO' . vaoName glDrawElements (marshalEPrimitiveMode $ _shadPrim' fs) @@ -140,7 +144,6 @@ doDrawing' win pdata u = do --draw floor onto base buffer drawShader (_textureArrayShader pdata) nFls --draw lightmap into its own buffer - glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) createLightMap cfig pdata @@ -159,6 +162,11 @@ doDrawing' win pdata u = do glEnable GL_BLEND glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR drawShader (_fullscreenShader pdata) 4 + with GL_COLOR_ATTACHMENT0 $ \ptr -> + glInvalidateNamedFramebufferData + (pdata ^. fboLighting . _1 . unFBO) + 1 + ptr --draw bloom onto bloom buffer glBindFramebuffer GL_FRAMEBUFFER (pdata ^. fboBloom . _1 . unFBO) glClear GL_COLOR_BUFFER_BIT @@ -168,21 +176,17 @@ doDrawing' win pdata u = do renderLayer BloomNoZWrite shadV layerCounts glDepthMask GL_TRUE renderLayer BloomLayer shadV layerCounts - --glDepthMask GL_TRUE --setup downscale viewport for blurring bloom setViewportSize (round winx `div` (2 * resFact)) (round winy `div` (2 * resFact)) - --bindFramebuffer Framebuffer $= fst (_fboHalf1 pdata) glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboHalf1 pdata))) glDepthFunc GL_ALWAYS - --textureBinding Texture2D $= pdata ^? fboBloom . _2 -- Just (snd $ _fboBloom pdata) - glBindTexture GL_TEXTURE_2D (pdata ^. fboBloom . _2 . unTO) -- Just (snd $ _fboBloom pdata) + glBindTexture GL_TEXTURE_2D (pdata ^. fboBloom . _2 . unTO) glDisable GL_BLEND drawShader (_bloomBlurShader pdata) 4 replicateM_ 9 $ pingPongBetween (_fboHalf1 pdata) (_fboHalf2 pdata) (_bloomBlurShader pdata) glEnable GL_BLEND setViewportSize (round winx `div` resFact) (round winy `div` resFact) --draw clouds onto cloud buffer - --bindFramebuffer Framebuffer $= fst (_fboCloud pdata) glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata))) glDepthFunc GL_LEQUAL glDepthMask GL_FALSE @@ -191,24 +195,20 @@ doDrawing' win pdata u = do --blendColor $= Color4 0.5 0.5 0.5 0.5 --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 - --drawBuffers $= [FBOColorAttachment 0, NoBuffers] withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $ \ptr -> glDrawBuffers 2 ptr glClear GL_COLOR_BUFFER_BIT renderLayer MidLayer shadV layerCounts - --renderWindows pdata windowPoints drawShader (_windowShader pdata) nWins when (_graphics_cloud_shadows cfig) $ do ----render transparency depths glDepthMask GL_TRUE glDisable GL_BLEND withArray [GL_NONE, GL_COLOR_ATTACHMENT1] $ \ptr -> glDrawBuffers 2 ptr - --drawBuffers $= [NoBuffers, FBOColorAttachment 1] renderLayer MidLayer shadV layerCounts drawShader (_windowShader pdata) nWins ----draw lightmap for cloud buffer glDepthMask GL_FALSE glEnable GL_BLEND - --bindFramebuffer Framebuffer $= fst (_fboLighting pdata) glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) createLightMap cfig @@ -224,31 +224,24 @@ doDrawing' win pdata u = do glClearColor 0 0 0 0 --apply lightmap to cloud buffer glClearColor 0 0 0 0 - --bindFramebuffer Framebuffer $= fst (_fboCloud pdata) glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata))) glDepthMask GL_FALSE - --drawBuffers $= [FBOColorAttachment 0, NoBuffers] withArray [GL_COLOR_ATTACHMENT0, GL_NONE] $ \ptr -> glDrawBuffers 2 ptr glDepthFunc GL_ALWAYS - --textureBinding Texture2D $= Just (snd $ _fboLighting pdata) glBindTexture GL_TEXTURE_2D (_unTO . snd $ _fboLighting pdata) glEnable GL_BLEND - --glBlendFunc GL_ZERO, GL_ONE_MINUS_SRC_ALPHA) glBlendFuncSeparate GL_ZERO GL_ONE_MINUS_SRC_COLOR GL_ZERO GL_ONE drawShader (_fullscreenShader pdata) 4 glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA -- bind base buffer for drawing bloom then clouds - --bindFramebuffer Framebuffer $= fst (_fboBase pdata) glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboBase pdata))) --Draw blurred bloom onto base buffer glEnable GL_BLEND glBlendFunc GL_SRC_ALPHA GL_ONE - --textureBinding Texture2D $= Just (snd $ _fboHalf1 pdata) glBindTexture GL_TEXTURE_2D (_unTO . snd $ _fboHalf1 pdata) drawShader (_fullscreenShader pdata) 4 glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA --draw shadowed clouds onto base buffer - --textureBinding Texture2D $= Just (fst $ snd $ _fboCloud pdata) glBindTexture GL_TEXTURE_2D (_unTO . fst . snd $ _fboCloud pdata) drawShader (_fullscreenShader pdata) 4 --set viewport for radial distortion @@ -260,7 +253,6 @@ doDrawing' win pdata u = do [] -> do bindTO $ fst $ snd $ _fboBase pdata glBindFramebuffer GL_FRAMEBUFFER 0 - --bufferUBO $ perspectiveMatrixb rot camzoom trans wins viewFroms drawShader (_fullscreenShader pdata) 4 rds -> do let bindDrawDist :: Distortion -> IO () @@ -270,14 +262,11 @@ doDrawing' win pdata u = do drawShader (_barrelShader pdata) 1 fboList = take (length rds - 1) (concat (repeat [fst $ _fbo2 pdata, fst $ _fbo3 pdata])) - -- ++ [defaultFramebufferObject] ++ [FBO 0] toList = fst (snd (_fboBase pdata)) : concat (repeat [snd $ _fbo2 pdata, snd $ _fbo3 pdata]) bindings = zipWith (>>) (map bindFBO fboList) (map bindTO toList) glActiveTexture GL_TEXTURE1 - --activeTexture $= TextureUnit 1 zipWithM_ (>>) bindings $ map bindDrawDist rds - --activeTexture $= TextureUnit 0 glActiveTexture GL_TEXTURE1 glDepthFunc GL_ALWAYS glEnable GL_BLEND @@ -288,7 +277,6 @@ doDrawing' win pdata u = do glDepthMask GL_FALSE glEnable GL_BLEND 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) renderLayer FixedCoordLayer shadV layerCounts renderFoldable shadV $ fixedCoordPictures u @@ -303,9 +291,6 @@ doDrawing' win pdata u = do ) SDL.glSwapWindow win --- eTicks <- SDL.ticks --- return (eTicks - sTicks) - fpsText :: (Show a, Ord a, Num a) => a -> Picture fpsText x = color col $ text $ "ms/frame " ++ show x where diff --git a/src/Dodge/Render/Shadow.hs b/src/Dodge/Render/Shadow.hs index 5d320990d..bfd61f2cc 100644 --- a/src/Dodge/Render/Shadow.hs +++ b/src/Dodge/Render/Shadow.hs @@ -26,7 +26,7 @@ drawCPUShadows pdata s pos rad = do 0 (fromIntegral $ floatSize * i) (theshad ^. shadVAO' . vaoVBO . vboPtr) - glUseProgram (theshad ^. shadProg') + glUseProgram (theshad ^. shadName) glBindVertexArray . _vaoName $ _shadVAO' theshad glDrawArrays (marshalEPrimitiveMode $ _shadPrim' theshad) diff --git a/src/Dodge/Room/RezBox.hs b/src/Dodge/Room/RezBox.hs index e536e693a..07609c944 100644 --- a/src/Dodge/Room/RezBox.hs +++ b/src/Dodge/Room/RezBox.hs @@ -126,7 +126,7 @@ rezColor = do 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] 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 = swapInOutLinks . rezBox diff --git a/src/Dodge/Room/RunPast.hs b/src/Dodge/Room/RunPast.hs index 5727adcd8..6b1a31ec8 100644 --- a/src/Dodge/Room/RunPast.hs +++ b/src/Dodge/Room/RunPast.hs @@ -26,7 +26,7 @@ roomCritLS = do col <- takeOne [0.5, 0.6] h <- takeOne [30, 35] rad <- takeOne [300] - return $ lsPosColRad (V3 0 0 h) col rad + return $ lsColPosRad col (V3 0 0 h) rad smallRoom :: Room smallRoom = corridorWallN & rmRandPSs .~ [psRandRanges (15, 25) (30, 45) (pi, 2 * pi)] diff --git a/src/Geometry/Intersect.hs b/src/Geometry/Intersect.hs index 129fba24c..5e056546b 100644 --- a/src/Geometry/Intersect.hs +++ b/src/Geometry/Intersect.hs @@ -1,31 +1,38 @@ {-# LANGUAGE BangPatterns #-} + --{-# LANGUAGE TupleSections #-} {- Testing for and finding intersection points. -} module Geometry.Intersect where -import Geometry.Data -import Geometry.Vector -import Geometry.LHS -import Control.Applicative +import Control.Applicative import Data.List import Data.Maybe +import Geometry.Data +import Geometry.LHS +import Geometry.Vector + -- | If two lines intersect, return 'Just' that point. intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE intersectLineLine' #-} intersectLineLine' (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) | den == 0 = Nothing - | otherwise = Just $ V2 (x1 + (x2-x1)*t'/den) (y1 + (y2-y1)*t'/den) - where - den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) - t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) + | otherwise = Just $ V2 (x1 + (x2 - x1) * t' / den) (y1 + (y2 - y1) * t' / den) + where + den = (x1 - x2) * (y3 - y4) - (y1 - y2) * (x3 - x4) + t' = (x1 - x3) * (y3 - y4) - (y1 - y3) * (x3 - x4) + intersectSegSegErrorTest :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE intersectSegSegErrorTest #-} intersectSegSegErrorTest a b c d = case intersectSegSeg a b c d of - Nothing | intersectSegSegFullTest a b c d -> - error $ "intersectSegSeg did not intersect"++show a ++ show b ++ show c++ show d - Just x | not $ intersectSegSegFullTest a b c d -> - error $ "intersectSegSeg did intersect"++show a ++ show b ++ show c++ show d - ++ " at " ++ show x + Nothing + | intersectSegSegFullTest a b c d -> + error $ "intersectSegSeg did not intersect" ++ show a ++ show b ++ show c ++ show d + Just x + | not $ intersectSegSegFullTest a b c d -> + error $ + "intersectSegSeg did intersect" ++ show a ++ show b ++ show c ++ show d + ++ " at " + ++ show x m -> m -- | 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) | V2 x1 y1 == V2 x2 y2 || V2 x3 y3 == V2 x4 y4 = Nothing | den == 0 = Nothing - | den > 0 && (t' < 0 || u' < 0 || t' > den || u' > den) - = Nothing - | den < 0 && (t' > 0 || u' > 0 || t' < den || u' < den) - = Nothing - | otherwise = Just $ V2 (x1 + (x2-x1)*t'/den) (y1 + (y2-y1)*t'/den) - where - den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) - t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) - 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. + | den > 0 && (t' < 0 || u' < 0 || t' > den || u' > den) = + Nothing + | den < 0 && (t' > 0 || u' > 0 || t' < den || u' < den) = + Nothing + | otherwise = Just $ V2 (x1 + (x2 - x1) * t' / den) (y1 + (y2 - y1) * t' / den) + where + den = (x1 - x2) * (y3 - y4) - (y1 - y2) * (x3 - x4) + t' = (x1 - x3) * (y3 - y4) - (y1 - y3) * (x3 - x4) + 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. +-} intersectSegLineFrom :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE intersectSegLineFrom #-} intersectSegLineFrom (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) | den == 0 = Nothing - | den > 0 && ( t' < 0 || u' < 0 || t' > den ) - = Nothing - | den < 0 && ( t' > 0 || u' > 0 || t' < den ) - = Nothing - | otherwise = Just $ V2 (x1 + (x2-x1)*t'/den) (y1 + (y2-y1)*t'/den) - where - den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) - t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) - u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) + | den > 0 && (t' < 0 || u' < 0 || t' > den) = + Nothing + | den < 0 && (t' > 0 || u' > 0 || t' < den) = + Nothing + | otherwise = Just $ V2 (x1 + (x2 - x1) * t' / den) (y1 + (y2 - y1) * t' / den) + where + den = (x1 - x2) * (y3 - y4) - (y1 - y2) * (x3 - x4) + t' = (x1 - x3) * (y3 - y4) - (y1 - y3) * (x3 - x4) + u' = (y1 - y2) * (x1 - x3) - (x1 - x2) * (y1 - y3) + -- | Similar to 'intersectSegLineFrom'', but this version is probably not correct... intersectSegLineext :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE intersectSegLineext #-} intersectSegLineext (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) | den == 0 = Nothing - | den > 0 && ( t' < 0 || u' < den || t' > den ) - = Nothing - | den < 0 && ( t' > 0 || u' > - den || t' < den ) - = Nothing - | otherwise = Just $ V2 (x1 + (x2-x1)*t'/den) (y1 + (y2-y1)*t'/den) - where - den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) - t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) - u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) + | den > 0 && (t' < 0 || u' < den || t' > den) = + Nothing + | den < 0 && (t' > 0 || u' > - den || t' < den) = + Nothing + | otherwise = Just $ V2 (x1 + (x2 - x1) * t' / den) (y1 + (y2 - y1) * t' / den) + where + den = (x1 - x2) * (y3 - y4) - (y1 - y2) * (x3 - x4) + t' = (x1 - x3) * (y3 - y4) - (y1 - y3) * (x3 - x4) + u' = (y1 - y2) * (x1 - x3) - (x1 - x2) * (y1 - y3) + -- | Intersect a segment with a line. intersectSegLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE intersectSegLine #-} intersectSegLine (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) | den == 0 = Nothing - | den > 0 && (t' < 0 || t' > den) - = Nothing - | den < 0 && (t' > 0 || t' < den) - = Nothing - | otherwise = Just $ V2 (x1 + (x2-x1)*t'/den) ( y1 + (y2-y1)*t'/den) - where - den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) - t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) - --u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) + | den > 0 && (t' < 0 || t' > den) = + Nothing + | den < 0 && (t' > 0 || t' < den) = + Nothing + | otherwise = Just $ V2 (x1 + (x2 - x1) * t' / den) (y1 + (y2 - y1) * t' / den) + where + den = (x1 - x2) * (y3 - y4) - (y1 - y2) * (x3 - x4) + t' = (x1 - x3) * (y3 - y4) - (y1 - y3) * (x3 - x4) + +--u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) + -- | A test that should align with Just values from intersectSegSeg. -intersectSegSegFullTest - :: Point2 - -> Point2 - -> Point2 - -> Point2 - -> Bool +intersectSegSegFullTest :: + Point2 -> + Point2 -> + Point2 -> + Point2 -> + Bool {-# INLINE intersectSegSegFullTest #-} -intersectSegSegFullTest x y z w - = f x y z w && f z w x y && x /= y && z /= w +intersectSegSegFullTest 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 (y -.- x) /= normalizeV (z -.- w) where - f a b c d = ( not (isRHS a b c) && not (isLHS a b d) ) - || ( not (isLHS a b c) && not (isRHS a b d) ) --- | It is not always necessary to find a point of intersection, sometimes a --- test may suffice. -intersectSegSegTest - :: Point2 - -> Point2 - -> Point2 - -> Point2 - -> Bool + f a b c d = + (not (isRHS a b c) && not (isLHS a b d)) + || (not (isLHS a b c) && not (isRHS a b d)) + +{- | It is not always necessary to find a point of intersection, sometimes a + test may suffice. +-} +intersectSegSegTest :: + Point2 -> + Point2 -> + Point2 -> + Point2 -> + Bool {-# INLINE intersectSegSegTest #-} -intersectSegSegTest x y z w - = f x y z w && f z w x y && x /= y && z /= w +intersectSegSegTest x y z w = + f x y z w && f z w x y && x /= y && z /= w where - f a b c d = ( not (isRHS a b c) && not (isLHS a b d) ) - || ( not (isLHS a b c) && not (isRHS a b d) ) -intersectSegSegPreTest - :: Point2 - -> Point2 - -> Point2 - -> Point2 - -> Maybe Point2 + f a b c d = + (not (isRHS a b c) && not (isLHS a b d)) + || (not (isLHS a b c) && not (isRHS a b d)) + +intersectSegSegPreTest :: + Point2 -> + Point2 -> + Point2 -> + Point2 -> + Maybe Point2 {-# INLINE intersectSegSegPreTest #-} intersectSegSegPreTest a b c d | intersectSegSegTest a b c d = myIntersectSegSeg a b c d | otherwise = Nothing --- | Due to floating point issues, 'intersectSegSeg'' is not always --- accurate---'myIntersectSegSeg' --- fixes at least some of --- the problem cases by transforming the points into rationals and then doing the --- intersection. --- This version is, probably, slower---both testing and benchmarking should be --- done. -myIntersectSegSeg - :: Point2 - -> Point2 - -> Point2 - -> Point2 - -> Maybe Point2 + +{- | Due to floating point issues, 'intersectSegSeg'' is not always + accurate---'myIntersectSegSeg' + fixes at least some of + the problem cases by transforming the points into rationals and then doing the + intersection. + This version is, probably, slower---both testing and benchmarking should be + done. +-} +myIntersectSegSeg :: + Point2 -> + Point2 -> + Point2 -> + Point2 -> + Maybe Point2 {-# 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 - Nothing -> Nothing - Just (V2 x y) -> if inbetween x && inbetween' y - then Just (V2 x y) - else Nothing - where - inbetween x = ((ax <= x && x <= bx) || (bx <= x && x <= ax)) - && ((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)) + Nothing -> Nothing + Just (V2 x y) -> + if inbetween x && inbetween' y + then Just (V2 x y) + else Nothing + where + inbetween x = + ((ax <= x && x <= bx) || (bx <= x && x <= ax)) + && ((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. -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 #-} 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 c d) = V2 cx <$> axisInt (a *-* V2 cx 0) (b *-* V2 cx 0) - | otherwise - = case linGrad a b ^-^ linGrad c d of + | otherwise = + case linGrad a b ^-^ linGrad c d of Just 0 -> Nothing - _ -> liftA2 V2 newx ((linGrad a b ^*^ newx) ^+^ axisInt a b) - where + _ -> liftA2 V2 newx ((linGrad a b ^*^ newx) ^+^ axisInt a b) + where (^-^) = liftA2 (-) (^+^) = liftA2 (+) (^/^) = liftA2 (/) (^*^) = liftA2 (*) - newx = (axisInt c d ^-^ axisInt a b) ^/^ (linGrad a b ^-^ linGrad c d) - (*-*) (V2 ax' ay) (V2 bx by) = V2 (ax'-bx) (ay-by) + newx = (axisInt c d ^-^ axisInt a b) ^/^ (linGrad a b ^-^ linGrad c d) + (*-*) (V2 ax' ay) (V2 bx by) = V2 (ax' - bx) (ay - by) + -- | Transforms floating points to rationals then performs line intersection. ratIntersectLineLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE ratIntersectLineLine #-} -ratIntersectLineLine a b c d = toNumPoint2 - <$> myIntersectLineLine (toRatPoint2 a) (toRatPoint2 b) (toRatPoint2 c) (toRatPoint2 d) - where - toRatPoint2 (V2 x y) = V2 (toRational x) (toRational y) - toNumPoint2 (V2 x y) = V2 (fromRational x) (fromRational y) +ratIntersectLineLine a b c d = + toNumPoint2 + <$> myIntersectLineLine (toRatPoint2 a) (toRatPoint2 b) (toRatPoint2 c) (toRatPoint2 d) + where + 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. __Examples__ Rounding jumps after intervals of .5: @@ -188,66 +215,83 @@ but is symmetric around 0: -} roundPoint2 :: Point2 -> Point2 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. -linGrad :: (Eq a,Fractional a) => V2 a -> V2 a -> Maybe a +linGrad :: (Eq a, Fractional a) => V2 a -> V2 a -> Maybe a {-# INLINE linGrad #-} -linGrad (V2 x y) (V2 a b) - | x-a == 0 = Nothing - | otherwise = Just $ (y-b)/(x-a) +linGrad (V2 x y) (V2 a b) + | x - a == 0 = Nothing + | otherwise = Just $ (y - b) / (x - a) + -- | 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 #-} -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. intersectSegsSeg :: [Point2] -> Point2 -> Point2 -> Maybe Point2 intersectSegsSeg = undefined + -- | Placeholder: should intersect a segment with a bezier curve. intersectSegBezquad :: Point2 -> Point2 -> Point2 -> Point2 -> Point2 -> [Point2] intersectSegBezquad = undefined --- | finds one (if any) of the points of intersection between a segment and a --- polygon. --- Can almost certainly be optimised. +{- | finds one (if any) of the points of intersection between a segment and a + polygon. + Can almost certainly be optimised. +-} intersectSegPolyFirst :: Point2 -> Point2 -> [Point2] -> Maybe Point2 intersectSegPolyFirst a b xs = foldr (<|>) Nothing $ zipWith lineColl xs (tail xs ++ [head xs]) where lineColl = intersectSegSeg a b --- | Given a line and a point return the point on the line closest to the --- point. -closestPointOnLine - :: Point2 -- ^ First line point. - -> Point2 -- ^ Second line point. - -> Point2 -- ^ Point not on line. - -> Point2 +{- | Given a line and a point return the point on the line closest to the + point. +-} +closestPointOnLine :: + -- | First line point. + Point2 -> + -- | Second line point. + Point2 -> + -- | Point not on line. + Point2 -> + Point2 {-# INLINE closestPointOnLine #-} -closestPointOnLine !a !b !p = a +.+ u *.* (b -.- a) - where u = closestPointOnLineParam a b p --- | Given a line and a point return a value corresponding to how far along the --- 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) +closestPointOnLine !a !b !p = a +.+ u *.* (b -.- a) + where + u = closestPointOnLineParam a b p --- | Given a segment and external point, find the closest point on the segment. --- clamps to the end of the segment +{- | Given a line and a point return a value corresponding to how far along the + 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 segP1 segP2 p | closestPointOnLineParam segP1 segP2 p <= 0 = segP1 | 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. --- does not return closest points beyond the segment +{- | Given a segment and external point, find the closest point on the segment. + does not return closest points beyond the segment +-} orthogonalPointOnSeg :: Point2 -> Point2 -> Point2 -> Maybe Point2 orthogonalPointOnSeg a b p | param < 0 || param > 1 = Nothing - | otherwise = Just $ a +.+ param *.* normalizeV (b -.- a) + | otherwise = Just $ a +.+ param *.* normalizeV (b -.- a) where 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) intersectCircSeg :: Point2 -> Float -> Point2 -> Point2 -> [Point2] -intersectCircSeg c r a b +intersectCircSeg c r a b | y < 0 = [] - | otherwise = nub $ filter (inSegArea a b) [ d -.- v, d +.+ v ] + | otherwise = nub $ filter (inSegArea a b) [d -.- v, d +.+ v] where d = closestPointOnLine a b c x = dist d c diff --git a/src/Loop.hs b/src/Loop.hs index 31ab908c3..dbbf101d7 100644 --- a/src/Loop.hs +++ b/src/Loop.hs @@ -24,6 +24,8 @@ import SDL import System.Mem 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. setupLoop :: -- | Target seconds per frame diff --git a/src/Preload/Render.hs b/src/Preload/Render.hs index 7d8a9afce..7e17641d2 100644 --- a/src/Preload/Render.hs +++ b/src/Preload/Render.hs @@ -131,7 +131,7 @@ preloadRender = do -- lighting shaders lightingWallShadShad <- makeShaderUsingVAO "lighting/wallShadow" [vert, geom, frag] EPoints wpVAO - >>= addUniforms ["lightPos"] + >>= addUniforms ["lightPos","rad"] lightingCapShad <- makeShaderUsingVAO "lighting/cap" [vert, geom] ETriangles shPosVAO >>= addUniforms ["lightPos"] diff --git a/src/Render.hs b/src/Render.hs index 0f70ef9c1..a113b5566 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -50,6 +50,7 @@ createLightMap :: createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype toPos drawCPUShadows = case shadsdrawtype of InstancingShads -> instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos NoShadows -> do + glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) let ltextShad = _lightingTextureShader pdata -- we assume that the renderbuffer's depth has been correctly set elsewhere -- 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 glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR glEnable GL_STENCIL_TEST - --stencilTest $= Enabled 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 flip VFSM.mapM_ (VFSM.fromList lightPoints) $ \(V3 x y z, rad, V3 r g b) -> do 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 glClear GL_STENCIL_BUFFER_BIT glDisable GL_CULL_FACE - --cullFace $= Nothing glStencilFunc GL_ALWAYS 0 255 --draw lightmap itself glDepthFunc GL_ALWAYS @@ -83,7 +80,7 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype toPos dra bindTO toPos glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE 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 glUniform4f (_shadUnis' ltextShad V.! 1) r g b rad --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 glDepthMask GL_FALSE _ -> do + glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata))) let llinesShad = _lightingLineShadowShader pdata lcapShad = _lightingCapShader 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 glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR glEnable GL_STENCIL_TEST - --stencilTest $= Enabled 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 flip VFSM.mapM_ (VFSM.fromList lightPoints) $ \(V3 x y z, rad, V3 r g b) -> do 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 glClear GL_STENCIL_BUFFER_BIT glDisable GL_CULL_FACE - --cullFace $= Nothing glStencilFunc GL_ALWAYS 0 255 --draw wall shadows - --currentProgram $= Just (_shadProg lwallShad) - glUseProgram (_shadProg' lwallShad) - --uniform (_shadUnis lwallShad V.! 0) - -- $= Vector3 x y z + glUseProgram (_shadName lwallShad) 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) glDrawArrays (marshalEPrimitiveMode $ _shadPrim' lwallShad) @@ -152,7 +143,8 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype toPos dra case shadsdrawtype of GeoObjShads -> do --draw silhouette shadows - glUseProgram (_shadProg' llinesShad) + glEnable GL_DEPTH_CLAMP + glUseProgram (_shadName llinesShad) glUniform3f (_shadUnis' llinesShad V.! 0) x y z glUniform1f (_shadUnis' llinesShad V.! 1) rad 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 glEnable GL_CULL_FACE glCullFace GL_BACK - glUseProgram (_shadProg' lcapShad) + glCullFace GL_FRONT + glUseProgram (_shadName lcapShad) glUniform3f (_shadUnis' lcapShad V.! 0) x y z glBindVertexArray $ lcapShad ^. shadVAO' . vaoName --Just (_vao $ _shadVAO lcapShad) glDrawElements @@ -172,15 +165,17 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype toPos dra (fromIntegral nCaps) GL_UNSIGNED_SHORT nullPtr + glDisable GL_DEPTH_CLAMP CPUObjShads -> drawCPUShadows (V3 x y z) rad NoObjShads -> return () --draw lightmap itself glDepthFunc GL_ALWAYS -- bind world position texture + glDisable GL_CULL_FACE bindTO toPos glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE 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 glUniform4f (_shadUnis' ltextShad V.! 1) r g b rad --bindVertexArrayObject $= ltextShad ^? shadVAO' . vaoName -- Just (_vao $ _shadVAO ltextShad) @@ -190,7 +185,6 @@ createLightMap cfig pdata lightPoints nWalls nSils nCaps shadsdrawtype toPos dra 0 (fromIntegral (4 :: Int)) --cleanup: may not be necessary, depending on what comes after... - glDisable GL_CULL_FACE glDisable GL_STENCIL_TEST lightsToArray :: [(Point3, Float, Point3)] -> [Float] @@ -252,14 +246,14 @@ instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos = do glDisable GL_CULL_FACE glStencilFunc GL_ALWAYS 0 255 --draw wall shadows - glUseProgram $ pdata ^. shadowWallShader . shadProg' - glBindVertexArray $ pdata ^. shadowWallShader . shadVAO' . vaoName -- Just (_vao $ _shadVAO lwallShad) + glUseProgram $ pdata ^. shadowWallShader . shadName + glBindVertexArray $ pdata ^. shadowWallShader . shadVAO' . vaoName glDrawArrays (marshalEPrimitiveMode $ pdata ^. shadowWallShader . shadPrim') 0 (fromIntegral nWalls) --draw silhouette shadows - glUseProgram $ pdata ^. shadowEdgeShader . shadProg' + glUseProgram $ pdata ^. shadowEdgeShader . shadName glBindVertexArray $ pdata ^. shadowEdgeShader . shadVAO' . vaoName glDrawElements (marshalEPrimitiveMode $ pdata ^. shadowEdgeShader . shadPrim') @@ -267,9 +261,10 @@ instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos = do GL_UNSIGNED_SHORT nullPtr --draw caps on the near plane as required - glEnable GL_CULL_FACE + --glEnable GL_CULL_FACE glCullFace GL_BACK - glUseProgram (_shadProg' lcapShad) + --glCullFace GL_FRONT + glUseProgram (_shadName lcapShad) glBindVertexArray $ lcapShad ^. shadVAO' . vaoName glDrawElements (marshalEPrimitiveMode $ _shadPrim' lcapShad) @@ -280,15 +275,14 @@ instanceLightMap cfig pdata lightPoints nWalls nSils nCaps toPos = do glDepthFunc GL_ALWAYS glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE glStencilFunc GL_EQUAL 0 255 - glUseProgram (pdata ^. shadowLightShader . shadProg') + glUseProgram (pdata ^. shadowLightShader . shadName) -- bind world position texture bindTO toPos - glBindVertexArray $ pdata ^. shadowLightShader . shadVAO' . vaoName +-- glBindVertexArray $ pdata ^. shadowLightShader . shadVAO' . vaoName glDrawArrays (marshalEPrimitiveMode $ pdata ^. shadowLightShader . shadPrim') 0 1 - -- this was the end of the loop glDisable GL_CULL_FACE glDisable GL_STENCIL_TEST --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) glEnable GL_BLEND glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR - glUseProgram (pdata ^. shadowCombineShader . shadProg') --Just (_shadProg ltextShad) + glUseProgram (pdata ^. shadowCombineShader . shadName) glDrawArrays (marshalEPrimitiveMode EPoints) 0 diff --git a/src/Shader.hs b/src/Shader.hs index e13c0db7f..da384eba1 100644 --- a/src/Shader.hs +++ b/src/Shader.hs @@ -26,7 +26,7 @@ drawShaderLay :: Int -> UMV.MVector (PrimState IO) Int -> Int -> FullShader -> I drawShaderLay l countsVector shadIn fs = do i <- UMV.read countsVector shadIn --currentProgram $= Just (_shadProg' fs) - glUseProgram (_shadProg' fs) + glUseProgram (_shadName fs) glBindVertexArray $ fs ^. shadVAO' . vaoName --bindVertexArrayObject $= Just (_vaoName $ _shadVAO' fs) case _shadTex' fs of @@ -44,7 +44,7 @@ drawShader :: FullShader -> Int -> IO () {-# INLINE drawShader #-} drawShader fs i = do --currentProgram $= Just (_shadProg fs) - glUseProgram (_shadProg' fs) + glUseProgram (_shadName fs) glBindVertexArray $ fs ^. shadVAO' . vaoName --bindVertexArrayObject $= Just (_vaoName $ _shadVAO' fs) case _shadTex' fs of diff --git a/src/Shader/AuxAddition.hs b/src/Shader/AuxAddition.hs index b3b556368..3e72520f4 100644 --- a/src/Shader/AuxAddition.hs +++ b/src/Shader/AuxAddition.hs @@ -91,5 +91,5 @@ addUniforms uniStrings shad = do foldM addUniform shad uniStrings addUniform :: FullShader -> String -> IO FullShader 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]) diff --git a/src/Shader/Compile.hs b/src/Shader/Compile.hs index ab90f53dc..5b29d2903 100644 --- a/src/Shader/Compile.hs +++ b/src/Shader/Compile.hs @@ -35,7 +35,7 @@ makeShader s shaderlist sizes pm = do vaob <- setupVAO sizes return $ FullShader - { _shadProg' = prog + { _shadName = prog , _shadVAO' = vaob , _shadPrim' = pm , _shadTex' = Nothing @@ -54,7 +54,7 @@ makeByteStringShaderUsingVAO s shaderlist pm vao = do prog <- makeShaderProgram s shaderlist return $ FullShader - { _shadProg' = prog + { _shadName = prog , _shadVAO' = vao , _shadPrim' = pm , _shadTex' = Nothing @@ -74,7 +74,7 @@ makeShaderUsingVAO s shaderlist pm theVAO = do prog <- makeSourcedShader s shaderlist return $ FullShader - { _shadProg' = prog + { _shadName = prog , _shadVAO' = theVAO , _shadPrim' = pm , _shadTex' = Nothing @@ -101,7 +101,7 @@ makeShaderSized s shaderlist sizes ndraw pm = do vaob <- setupVAOSized ndraw sizes return $ FullShader - { _shadProg' = prog + { _shadName = prog , _shadVAO' = vaob , _shadPrim' = pm , _shadTex' = Nothing diff --git a/src/Shader/Data.hs b/src/Shader/Data.hs index f365670b2..0cb143340 100644 --- a/src/Shader/Data.hs +++ b/src/Shader/Data.hs @@ -19,7 +19,7 @@ module Shader.Data , eboName , eboPtr - , shadProg' + , shadName , shadVAO' , shadPrim' , shadTex' @@ -35,7 +35,7 @@ import Foreign import Control.Lens {- | Datatype containing the necessary information for a single shader. -} data FullShader = FullShader - { _shadProg' :: GLuint -- should be shaderID + { _shadName :: GLuint -- should be shaderID , _shadVAO' :: VAO , _shadPrim' :: EPrimitiveMode , _shadTex' :: Maybe ShaderTexture