Tweak chase crit perception

appDodge/Main.hs

@@ -95,6 +95,7 @@ firstWorldLoad theConfig = do
                 , _uvFrameTicks = 0
                 , _uvRAMSave = Nothing
                 , _uvDebug = mempty
+                , _uvDebugMessageOffset = 0
                 }
     return $ u & uvScreenLayers .~ [splashMenu u]
 

shader/compute/multiplyArray.comp

@@ -1,7 +0,0 @@
-#version 450 core
-layout(local_size_x= 1, local_size_y=1) in;
-uniform sampler2DArray screenTexture;
-layout(rgba8, binding = 5) uniform restrict writeonly image2D img_output;
-void main()
-{
-}

shader/compute/shadow.comp

@@ -1,40 +0,0 @@
-#version 450 core
-layout(local_size_x= 20, local_size_y=1) in;
-layout(rgba8, binding = 5) uniform restrict writeonly image2D img_output;
-layout (std140, binding = 1) uniform LightsBlock
-{
-    vec4 posBool[20];
-    vec4 colRad[20];
-} ;
-layout (binding = 0) uniform sampler2D posTexture;
-layout (binding = 1) uniform sampler2D normals;
-void main ()
-{
-    shared vec3[20] larray;
-    uint i = gl_LocalInvocationID.x;
-    vec3 lightamount = vec3(0,0,0);
-    ivec2 pixel_coords = ivec2(gl_WorkGroupID.xy);
-    vec2 tex_coords = vec2((4*pixel_coords.x+4)/800.0, (4*pixel_coords.y+4)/835.0);
-    vec3 pos = texture(posTexture,tex_coords).xyz;
-    vec3 lightPos = posBool[i].xyz;
-    vec4 lumRad = colRad[i];
-    vec3 distVec = lightPos - pos;
-    float dist = dot (distVec,distVec);
-    if (dist > lumRad.a) { }
-    else 
-    {
-        float x = 1 - dist / lumRad.a;
-        vec3 norm = texture(normals,tex_coords).xyz;
-        float y1 = dot(normalize(norm), normalize(distVec));
-        float y = float(y1 > 0 ? 0 : 1);
-        lightamount = y*x*lumRad.rgb;
-
-    }
-      larray[i] = lightamount;
-    if (i == 0)
-        {   vec3 inverselight = 1 - lightamount;
-        //{   vec3 inverselight = vec3(0,0,0);
-            for (uint j=1 ; j < 20; ++j) {inverselight = inverselight * (1 - larray[j]);}
-            imageStore(img_output, pixel_coords, vec4(inverselight,1));
-        }
-}

shader/shadow/cap.geom

@@ -1,47 +0,0 @@
-#version 450 core
-layout (triangles) in;
-layout (invocations = 20) in;
-layout (triangle_strip, max_vertices = 3) out;
-layout (std140, binding = 0) uniform TheMat { mat4 theMat; } ;
-layout (std140, binding = 1) uniform LightsBlock
-{
-    vec4 posBool[20];
-    vec4 colRad[20];
-} ;
-vec3 lightPos = posBool[gl_InvocationID].xyz ;
-float theBool = posBool[gl_InvocationID].w;
-// this code is duplicated in shadow/edge.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 = (100 - pos.z) / dir.z ;
-    vec2 xy = (pos.xyz + a * dir).xy ;
-    return vec4 ( xy, 100 , 1) ;
-}
-void main()
-{
-    vec4 p0 = gl_in[0].gl_Position ;
-    vec4 p1 = gl_in[1].gl_Position ;
-    vec4 p2 = gl_in[2].gl_Position ;
-    if ( //if Light Source is below all vertices, draw cap 
-        // TODO think about when LS is beside the object
-            ( p0.z - lightPos.z > 0 )
-            && ( p1.z - lightPos.z > 0 )
-            && ( p2.z - lightPos.z > 0 )
-            && theBool == 1
-            )
-    {
-        // the front cap
-        vec4 v1 = vec4 (0,0,1,0) ;
-        gl_Layer = gl_InvocationID;
-        gl_Position = theMat * projNear(p0); EmitVertex();
-        gl_Layer = gl_InvocationID;
-        gl_Position = theMat * projNear(p1); EmitVertex();
-        gl_Layer = gl_InvocationID;
-        gl_Position = theMat * projNear(p2); EmitVertex();
-        EndPrimitive();
-    }
-    else {}
-}

shader/shadow/cap.vert

@@ -1,7 +0,0 @@
-#version 450 core
-layout (location = 0) in vec3 position;
-layout (std140, binding = 0) uniform TheMat { mat4 theMat; } ;
-void main()
-{
-    gl_Position = vec4(position,1);
-}

shader/shadow/combine.frag

@@ -1,9 +0,0 @@
-#version 450 core
-uniform sampler2DArray screenTexture;
-in vec3 gTexPos;
-out vec4 fColor;
-void main()
-{
-    fColor = texture(screenTexture,gTexPos);
-    //fColor = vec4(0.05,0.01,0,1);
-}

shader/shadow/combine.geom

@@ -1,30 +0,0 @@
-#version 450 core
-layout (points) in;
-layout (triangle_strip, max_vertices = 4) out;
-layout (invocations = 20) in;
-layout (std140, binding = 1) uniform LightsBlock
-{
-    vec4 posBool[20];
-    vec4 colRad[20];
-} ;
-out vec3 gTexPos;
-float theBool = posBool[gl_InvocationID].w;
-float l = gl_InvocationID;
-void main()
-{
-    if (theBool == 1){
-        gTexPos = vec3(0,1,l);
-        gl_Position = vec4(-1,1,0,1) ;
-        EmitVertex();
-        gTexPos = vec3(0,0,l);
-        gl_Position = vec4(-1,-1,0,1) ;
-        EmitVertex();
-        gTexPos = vec3(1,1,l);
-        gl_Position = vec4(1,1,0,1) ;
-        EmitVertex();
-        gTexPos = vec3(1,0,l);
-        gl_Position = vec4(1,-1,0,1) ;
-        EmitVertex();
-    EndPrimitive();
-    }else {}
-}

shader/shadow/combine.vert

@@ -1,4 +0,0 @@
-#version 450 core
-void main()
-{
-}

shader/shadow/edge.geom

@@ -1,85 +0,0 @@
-#version 450 core
-layout(lines_adjacency) in;
-layout(invocations = 20) in;
-layout(triangle_strip, max_vertices = 4) out;
-layout(std140, binding = 0) uniform TheMat { mat4 theMat; };
-layout(std140, binding = 1) uniform LightsBlock {
-  vec4 posBool[20];
-  vec4 colRad[20];
-};
-vec3 lightPos = posBool[gl_InvocationID].xyz;
-float theBool = posBool[gl_InvocationID].w;
-float rad = colRad[gl_InvocationID].w;
-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 shift1(vec4 p) {
-  return (vec4(lightPos + (rad * normalize(p.xyz - lightPos)), 1));
-};
-// copied from shadow/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 = (100 - pos.z) / dir.z;
-  vec2 xy = (pos.xyz + a * dir).xy;
-  return vec4(xy, 100, 1);
-};
-vec4 shiftNear(vec4 pos) {
-  vec4 sp = shift(pos);
-  if (sp.z > 100) {
-    return projNear(pos);
-  } else {
-    return sp;
-  }
-};
-void main() {
-  if (theBool == 1) {
-    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 lightDir = p0.xyz - lightPos.xyz;
-    vec3 lightDir2 = p1.xyz - lightPos.xyz;
-    // 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) < rad * rad ||
-         dot(lightDir2, lightDir2) < rad * rad))
-    // using <= rather than < seems to get rid of overlapping shadow
-    // artefacts
-    {
-      vec4 p2 = shiftNear(p0);
-      vec4 p3 = shiftNear(p1);
-      gl_Position = theMat * p0;
-      gl_Layer = gl_InvocationID;
-      EmitVertex();
-      if (dot(n0, lightDir) > 0) {
-        gl_Position = theMat * p1;
-        gl_Layer = gl_InvocationID;
-        EmitVertex();
-        gl_Position = theMat * p2;
-        gl_Layer = gl_InvocationID;
-        EmitVertex();
-      } else {
-        gl_Position = theMat * p2;
-        gl_Layer = gl_InvocationID;
-        EmitVertex();
-        gl_Position = theMat * p1;
-        gl_Layer = gl_InvocationID;
-        EmitVertex();
-      }
-      gl_Position = theMat * p3;
-      gl_Layer = gl_InvocationID;
-      EmitVertex();
-      EndPrimitive();
-    } else {
-    }
-  } else {
-  }
-}

shader/shadow/edge.vert

@@ -1,6 +0,0 @@
-#version 450 core
-layout (location = 0) in vec3 pos;
-void main()
-{
-    gl_Position = vec4(pos,1);
-}

shader/shadow/light.frag

@@ -1,36 +0,0 @@
-#version 450 core
-layout (std140, binding = 1) uniform LightsBlock
-{
-    vec4 posBool[20];
-    vec4 colRad[20];
-} ;
-//uniform int lightID;
-vec3 lightPos = posBool[gl_Layer].xyz;
-vec4 lumRad = colRad[gl_Layer];
-layout (binding = 0) uniform sampler2D screenTexture;
-layout (binding = 1) uniform sampler2D normals;
-in vec2 gTexPos;
-out vec4 fColor;
-void main()
-{
-float rad = lumRad.a;
-    vec3 distVec = texture(screenTexture,gTexPos).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);
-  //  //fColor = vec4(0.05,0,0,0);
-  vec4 normbit = texture(normals, gTexPos);
-  vec3 norm = normbit.xyz;
-  float y1 = dot(normalize(norm), normalize(distVec));
-  float y2 = float(y1 > 0 ? 1 : 0);
-  //float y3 = clamp(0.5 * (y1 + 1),0,1) ;
-  float y3 = clamp(2*y1 + 1,0,1) ;
-  //float y3 = clamp(0.5 * (y1 + 2),0,1) ;
-  //float y = float(normbit.w == 0 ? y3 : y2);
-  float y = y2;
-  float x = 1 - dist / rad;
-  vec3 c = y* (x * x * x) * lumRad.rgb;
-  fColor = vec4(c, 1);
-}

shader/shadow/light.geom

@@ -1,33 +0,0 @@
-#version 450 core
-layout (points) in;
-layout (triangle_strip, max_vertices = 4) out;
-layout (invocations = 20) in;
-layout (std140, binding = 1) uniform LightsBlock
-{
-    vec4 posBool[20];
-    vec4 colRad[20];
-} ;
-float theBool = posBool[gl_InvocationID].w;
-out vec2 gTexPos;
-void main()
-{
-    if (theBool == 1){
-        gTexPos = vec2(0,1);
-        gl_Position = vec4(-1,1,0,1) ;
-        gl_Layer = gl_InvocationID;
-        EmitVertex();
-        gTexPos = vec2(0,0);
-        gl_Position = vec4(-1,-1,0,1) ;
-        gl_Layer = gl_InvocationID;
-        EmitVertex();
-        gTexPos = vec2(1,1);
-        gl_Position = vec4(1,1,0,1) ;
-        gl_Layer = gl_InvocationID;
-        EmitVertex();
-        gTexPos = vec2(1,0);
-        gl_Position = vec4(1,-1,0,1) ;
-        gl_Layer = gl_InvocationID;
-        EmitVertex();
-    EndPrimitive();
-    }else {}
-}

shader/shadow/light.vert

@@ -1,4 +0,0 @@
-#version 450 core
-void main()
-{
-}

shader/shadow/wallShadow.geom

@@ -1,78 +0,0 @@
-#version 450 core
-layout(points) in;
-layout(invocations = 20) in;
-layout(triangle_strip, max_vertices = 8) out;
-layout(std140, binding = 0) uniform TheMat { mat4 theMat; };
-layout(std140, binding = 1) uniform LightsBlock {
-  vec4 posBool[20];
-  vec4 colRad[20];
-};
-vec3 lightPos = posBool[gl_InvocationID].xyz;
-float theBool = posBool[gl_InvocationID].w;
-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);
-  vec4 p2 = vec4(gl_in[0].gl_Position.zw, 0, 1);
-  if (theBool == 1 && 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);
-
-    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 = a1;
-    gl_Layer = gl_InvocationID;
-    EmitVertex();
-    gl_Position = a5;
-    gl_Layer = gl_InvocationID;
-    EmitVertex();
-    gl_Position = a3;
-    gl_Layer = gl_InvocationID;
-    EmitVertex();
-    gl_Position = a8;
-    gl_Layer = gl_InvocationID;
-    EmitVertex();
-    gl_Position = a4;
-    gl_Layer = gl_InvocationID;
-    EmitVertex();
-    gl_Position = a7;
-    gl_Layer = gl_InvocationID;
-    EmitVertex();
-    gl_Position = a2;
-    gl_Layer = gl_InvocationID;
-    EmitVertex();
-    gl_Position = a6;
-    gl_Layer = gl_InvocationID;
-    EmitVertex();
-
-    EndPrimitive();
-  } else {
-  }
-}

shader/shadow/wallShadow.vert

@@ -1,6 +0,0 @@
-#version 450 core
-layout (location = 0) in vec4 poss;
-void main()
-{
-  gl_Position = poss;
-}

src/Color.hs

@@ -138,8 +138,8 @@ numColor 11 = toV4 (1, 0.5, 0, 1)
 numColor 12 = toV4 (1, 1, 1, 1)
 numColor _ = toV4 (1, 1, 1, 1)
 
-light4 :: Color -> Color
-light4 = light . light . light . light
+lightx4 :: Color -> Color
+lightx4 = light . light . light . light
 
 toColor8 :: Color -> Color8
 toColor8 = over each floor . (255 *) . normalizeColor

src/Data/Preload/Render.hs

@@ -11,17 +11,11 @@ import Graphics.GL.Core45
 import Shader.Data
 
 data RenderData = RenderData
-    { _computeShadowShader :: GLuint
-    , _lightingWallShadShader :: Shader
+    { _lightingWallShadShader :: Shader
     , _lightingLineShadowShader :: Shader
     , _lightingCapShader :: Shader
     , _lightingTextureShader :: Shader
     , _alphaDivideShader :: Shader
-    , _shadowEdgeShader :: Shader
-    , _shadowCapShader :: Shader
-    , _shadowWallShader :: Shader
-    , _shadowLightShader :: Shader
-    , _shadowCombineShader :: Shader
     , _windowShader :: Shader
     , _fullscreenShader :: Shader
     , _bloomBlurShader :: Shader
@@ -41,10 +35,8 @@ data RenderData = RenderData
     , _fboBloom :: (FBO, TO)
     , _fboPos :: (FBO, TO)
     , _fboLighting :: (FBO, TO)
-    , _fboShadow :: (FBO, (TO, TO))
     , _rboBaseBloom :: GLuint -- RenderbufferObject id
     , _matUBO :: GLuint -- BufferObject id
---    , _orthonormalMatUBO :: GLuint -- BufferObject id
     , _lightsUBO :: GLuint -- BufferObject id
     , _vboWindows :: VBO
     , _vboShapes :: VBO

src/Dodge/Camera.hs

@@ -4,10 +4,9 @@ import Dodge.Data.Universe
 import Control.Lens
 
 useNormalCamera :: Universe -> Universe
-useNormalCamera = uvWorld . wCam . camControl .~ CamInGame
+useNormalCamera = (uvWorld . wCam . camControl .~ CamInGame)
+    . (uvWorld . timeFlow .~ NormalTimeFlow)
 
 pauseAndFloatCam :: Universe -> Universe
-pauseAndFloatCam = uvWorld . wCam . camControl .~ CamFloat
-
-pauseAndPanCam :: Universe -> Universe
-pauseAndPanCam = uvWorld . wCam . camControl .~ CamPan
+pauseAndFloatCam = (uvWorld . wCam . camControl .~ CamFloat)
+    . (uvWorld . timeFlow .~ CameraScrollTimeFlow 0 200 [])

src/Dodge/Creature.hs

@@ -55,34 +55,27 @@ spawnerCrit =
     defaultCreature
         & crHP .~ 300
         & crInv .~ IM.empty
-        & crType . skinUpper .~ light4 blue
+        & crType . skinUpper .~ lightx4 blue
 
 miniGunCrit :: Creature
 miniGunCrit =
     defaultCreature
         & crInv .~ IM.fromList [(0, miniGunX 3)]
-        & crType . skinUpper .~ light4 red
+        & crType . skinUpper .~ lightx4 red
         & crType . humanoidAI .~ MiniGunAI
 
 longCrit :: Creature
 longCrit =
     defaultCreature
-        & crActionPlan
-            .~ ActionPlan
-                { _apImpulse = []
-                , _apAction = []
-                , _apStrategy = StrategyActions WatchAndWait [StartSentinelPost]
-                , _apGoal = []
-                }
         & crInv .~ IM.fromList [(0, sniperRifle), (1, medkit 100)]
         & crType . humanoidAI .~ LongAI
-        & crType . skinUpper .~ light4 red
+        & crType . skinUpper .~ lightx4 red
 
 multGunCrit :: Creature
 multGunCrit =
     defaultCreature
         & crInv .~ IM.fromList [(0, volleyGun 4), (1, medkit 100)]
-        & crType . skinUpper .~ light4 red
+        & crType . skinUpper .~ lightx4 red
         & crType . humanoidAI .~ MultGunAI
 
 addArmour :: Creature -> Creature
@@ -107,7 +100,7 @@ startCr =
         & crCorpse .~ MakeDefaultCorpse
         & crFaction .~ PlayerFaction
         & crMvType .~ MvWalking yourDefaultSpeed
-        & crType . skinUpper .~ light4 black
+        & crType . skinUpper .~ lightx4 black
         & crType . humanoidAI .~ YourAI
 
 -- | Items you start with.

src/Dodge/Creature/Action.hs

@@ -92,8 +92,8 @@ performTurnToA cr p
     dirv = p -.- cpos
     jit = _mvTurnJit $ _crMvType cr
 
-{- | Performing an action means that a creature has some impulses for a frame, and
- updates or deletes the action itself.
+{- | Performing an action on a frame creates an OutAction:
+  adds impulses and updates or deletes the action itself.
 -}
 performAction :: Creature -> World -> Action -> OutAction
 performAction cr w ac = case ac of

src/Dodge/Creature/AutoCrit.hs

@@ -18,5 +18,5 @@ autoCrit =
         , _crHP = 300
         , _crMvType = defaultAimMvType
         }
-        & crType . skinUpper .~ light4 red
+        & crType . skinUpper .~ lightx4 red
         & crType . humanoidAI .~ AutoAI

src/Dodge/Creature/ChainUpdates.hs

@@ -11,6 +11,3 @@ chainCreatureUpdates ::
 chainCreatureUpdates ls w cr = foldl' unf cr ls
   where
     unf cr' g = g w cr'
---chainCreatureUpdates ls w cr = foldr unf cr ls
---  where
---    unf g cr' = g w cr'

src/Dodge/Creature/ChaseCrit.hs

@@ -38,7 +38,13 @@ chaseCrit =
         , _crInv = IM.fromList [(0, medkit 200)]
         , _crMeleeCooldown = 0
         , _crFaction = ColorFaction green
-        , _crVocalization =
+        , _crVocalization = chaseCritVocalization
+        , _crMvType = defaultChaseMvType
+        }
+        & crType . humanoidAI .~ ChaseAI
+
+chaseCritVocalization :: Vocalization
+chaseCritVocalization =
             Vocalization
                 seagullChatterS
                 [ seagullBarkS
@@ -52,6 +58,3 @@ chaseCrit =
                 ]
                 50
                 0
-        , _crMvType = defaultChaseMvType
-        }
---        & crType . humanoidAI .~ ChaseAI

src/Dodge/Creature/HandPos.hs

@@ -45,7 +45,7 @@ translatePointToRightHand' cr
     f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
 
 translateToRightHand :: Creature -> SPic -> SPic
-translateToRightHand cr = translateToRightHand' cr -- . mirrorSPxz
+translateToRightHand = translateToRightHand' -- . mirrorSPxz
 
 translateToRightHand' :: Creature -> SPic -> SPic
 translateToRightHand' cr
@@ -61,7 +61,7 @@ translateToRightHand' cr
     f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
 
 translateToRightWrist :: Creature -> SPic -> SPic
-translateToRightWrist cr = translateToRightWrist' cr -- . mirrorSPxz
+translateToRightWrist = translateToRightWrist' -- . mirrorSPxz
 
 translateToRightWrist' :: Creature -> SPic -> SPic
 translateToRightWrist' cr

src/Dodge/Creature/Impulse/UseItem.hs

@@ -55,7 +55,7 @@ itemEffect cr it w = case it ^. itUse of
 
 tryReload :: Creature -> Item -> Input -> (World -> World) -> World -> World
 tryReload cr it theinput f
-    | cid == 0 && itNeedsLoading it && _mouseButtons theinput M.!? SDL.ButtonLeft == Just 1 =
+    | cid == 0 && itNeedsLoading it && _mouseButtons theinput M.!? SDL.ButtonLeft == Just 0 =
         cWorld . lWorld . creatures . ix cid %~ crToggleReloading
     | otherwise =
         (runIdentity . pointerToItemLocation (_itLocation it) (return . (itUse . heldHammer .~ HammerDown)))

src/Dodge/Creature/LauncherCrit.hs

@@ -17,5 +17,5 @@ launcherCrit =
         , _crState = defaultState
         , _crHP = 300
         }
-        & crType . skinUpper .~ light4 red
+        & crType . skinUpper .~ lightx4 red
         & crType . humanoidAI .~ LauncherAI

src/Dodge/Creature/LtAutoCrit.hs

@@ -18,4 +18,4 @@ ltAutoCrit =
         , _crHP = 500
         }
         & crType . humanoidAI .~ LtAutoAI
-        & crType . skinUpper .~ light4 red
+        & crType . skinUpper .~ lightx4 red

src/Dodge/Creature/Perception.hs

@@ -2,8 +2,10 @@
 module Dodge.Creature.Perception (
     perceptionUpdate,
     chaseCritPerceptionUpdate,
+    visionCheck,
 ) where
 
+import Linear
 import Control.Lens
 import qualified Data.Map.Strict as M
 import Data.Maybe
@@ -47,9 +49,6 @@ basicAwarenessUpdate cr = case _cpAttention $ _crPerception cr of
         newAwareness = (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is) oldAwareness
         becomesCognizant = any isCognizant $ IM.unionWith cogRaised oldAwareness newAwareness
         thejitter = RandImpulseCircMove 1
-        --do
-        --p <- randInCirc 1
-        --return $ Move p
         maybeBark
             | becomesCognizant = case vocalizationTest cr of
                 Just sid ->
@@ -81,11 +80,7 @@ chaseCritAwarenessUpdate w cr = case _cpAttention $ _crPerception cr of
         oldAwareness = _cpAwareness $ _crPerception cr
         newAwareness = (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is) oldAwareness
         becomesCognizant = any isCognizant $ IM.unionWith cogRaised oldAwareness newAwareness
-        --randBool = takeOne [False,True] & evalState $ _randGen w
         thejitter = RandImpulseCircMove 2
-        --  do
-        --    p <- randInCirc 2
-        --    return $ Move p
         maybeBark
             | becomesCognizant -- && randBool
                 && cr ^? crVocalization . vcCoolDown == Just 0 =
@@ -99,7 +94,7 @@ chaseCritAwarenessUpdate w cr = case _cpAttention $ _crPerception cr of
                                   replicate numjits [RandomImpulse thejitter]
                                     ++ [[ChangeStrategy $ CloseToMelee 0]]
                                 )
-                            , AimAt 0 (w ^?! cWorld . lWorld . creatures . ix 0 . crPos) --_crPos $ _creatures (_cWorld w) IM.! 0)
+                            , AimAt 0 (w ^?! cWorld . lWorld . creatures . ix 0 . crPos)
                             ]
             | otherwise = id
 
@@ -149,20 +144,27 @@ newExtraAwareness ::
 newExtraAwareness cr w cid
     | dist cpos tpos > 600 = Nothing
     | not $ canSeeIndirect (_crID cr) cid w = Nothing
-    | otherwise = Just . Suspicious $ doFloatFloat (_viFOV vi) ang * doFloatFloat (_viDist vi) d * awakeLevelPerception cr
+    | otherwise = Just . Suspicious $ visionCheck cr tpos * awakeLevelPerception cr
   where
-    vi = _cpVision $ _crPerception cr
     tpos = w ^?! cWorld . lWorld . creatures . ix cid . crPos -- _crPos $ _creatures (_cWorld w) IM.! cid
     cpos = _crPos cr
-    ang = angleVV (unitVectorAtAngle (_crDir cr)) (tpos - cpos)
+
+visionCheck :: Creature -> Point2 -> Float
+visionCheck cr tpos = doFloatFloat (_viFOV vi) ang * doFloatFloat (_viDist vi) d
+  where
+    vi = _cpVision $ _crPerception cr
+    cpos = _crPos cr
+    dirvec = unitVectorAtAngle (_crDir cr)
+    ang = angleVV dirvec (tpos - (cpos - _crRad cr *^ dirvec))
     d = dist tpos cpos
+    
 
 awakeLevelPerception :: Creature -> Float
 awakeLevelPerception cr = case _cpVigilance $ _crPerception cr of
     Comatose -> 0
     Asleep -> 10
-    Lethargic -> 200
-    Vigilant -> 500
+    Lethargic -> 100
+    Vigilant -> 1000
     Overstrung -> 10000
 
 newSounds :: World -> [(Point2, Float)]
@@ -174,14 +176,8 @@ newSounds = mapMaybe f . M.elems . _playingSounds
 
 rememberSounds :: World -> Creature -> Creature
 rememberSounds w cr =
-    cr
-        & crMemory . soundsToInvestigate .~ closesounds
-        & awakeupdate
-  where
-    awakeupdate
-        | null closesounds = id
-        | otherwise = crPerception . cpVigilance .~ Vigilant
-    closesounds = map fst (filter (soundIsClose w cr) (newSounds w))
+    cr & crMemory . soundsToInvestigate
+        .~ map fst (filter (soundIsClose w cr) (newSounds w))
 
 -- TODO work out correct form for sounds passing through walls
 soundIsClose :: World -> Creature -> (Point2, Float) -> Bool

src/Dodge/Creature/PistolCrit.hs

@@ -18,4 +18,4 @@ pistolCrit =
         , _crHP = 500
         }
         & crType . humanoidAI .~ PistolAI
-        & crType . skinUpper .~ light4 red
+        & crType . skinUpper .~ lightx4 red

src/Dodge/Creature/ReaderUpdate.hs

@@ -1,4 +1,3 @@
--- | Functions updating a creature in a Reader World environment
 module Dodge.Creature.ReaderUpdate (
     doStrategyActions,
     setTargetMv,
@@ -15,8 +14,12 @@ module Dodge.Creature.ReaderUpdate (
     setViewPos,
 ) where
 
+import Dodge.Creature.Perception
+import qualified IntMapHelp as IM
+import Data.List (sortOn)
 import Control.Applicative
 import Control.Lens
+import Control.Monad
 import Data.Bifunctor
 import Data.Maybe
 import Dodge.Base
@@ -26,7 +29,6 @@ import Dodge.Data.World
 import Dodge.Zoning.Creature
 import FoldableHelp
 import Geometry
-import Control.Monad
 
 overrideMeleeCloseTarget :: Creature -> Creature
 overrideMeleeCloseTarget cr = maybe cr (tryMeleeAttack cr) (_targetCr $ _crIntention cr)
@@ -34,12 +36,13 @@ overrideMeleeCloseTarget cr = maybe cr (tryMeleeAttack cr) (_targetCr $ _crInten
 tryMeleeAttack :: Creature -> Creature -> Creature
 tryMeleeAttack cr tcr
     | _crMeleeCooldown cr == 0
-        && dist (_crPos tcr) cpos < _crRad cr + _crRad tcr + 5
-        && abs (_crDir cr - argV (_crPos tcr -.- cpos)) < pi / 4 =
+        && dist tpos cpos < _crRad cr + _crRad tcr + 5
+        && abs (_crDir cr - argV (tpos -.- cpos)) < pi / 4 =
         cr & crActionPlan . apImpulse .~ [Melee $ _crID tcr]
     | otherwise = cr
   where
     cpos = _crPos cr
+    tpos = _crPos tcr
 
 setMvPos :: World -> Creature -> Creature
 setMvPos w cr = cr & crIntention . mvToPoint .~ mpos
@@ -47,20 +50,23 @@ setMvPos w cr = cr & crIntention . mvToPoint .~ mpos
     int = _crIntention cr
     mtpos = do
         tpos <- _crPos <$> _targetCr int
-        if hasLOSIndirect (_crPos cr) tpos w
-            then Just tpos
-            else Nothing
-    mpos =
-        mtpos
-            <|> _mvToPoint int
+        guard $ hasLOSIndirect (_crPos cr) tpos w
+        return $ tpos
+    mpos = mtpos <|> _mvToPoint int
 
---        <|> listToMaybe (_soundsToInvestigate $ _crMemory cr)
-
-setViewPos :: Creature -> Creature
-setViewPos cr = cr & crIntention . viewPoint %~ (<|> mpos)
+setViewPos :: World -> Creature -> Creature
+setViewPos w cr = cr & crIntention . viewPoint %~ ((<|> mpos) . (attentionViewPoint w cr <|>))
   where
     mpos = listToMaybe (_soundsToInvestigate $ _crMemory cr)
 
+attentionViewPoint :: World -> Creature -> Maybe Point2
+attentionViewPoint w cr = do
+    attention <- cr ^? crPerception . cpAttention . getAttentiveTo
+    cid <- (sortOn snd $ IM.toList attention) ^? ix 0 . _1
+    tcr <- w ^? cWorld . lWorld . creatures . ix cid
+    guard $ visionCheck cr (_crPos tcr) > 0
+    return (_crPos tcr)
+
 setTargetMv ::
     -- | Function for determining target
     (World -> Creature -> Maybe Creature) ->
@@ -112,31 +118,26 @@ chaseCritMv w cr = case _apStrategy (_crActionPlan cr) of
         _ -> viewTarget w cr
 
 goToTarget :: World -> Creature -> Creature
-goToTarget w cr =
-    case cr ^? crIntention . mvToPoint . _Just of
-        Just p -> cr & crActionPlan . apAction .~ [PathTo p]
-        _ -> viewTarget w cr
+goToTarget w cr = case cr ^? crIntention . mvToPoint . _Just of
+    Just p -> cr & crActionPlan . apAction .~ [PathTo p]
+    _ -> viewTarget w cr
 
-lookAroundSelf :: Action
-lookAroundSelf = UseSelf CrTurnAround
+--lookAroundSelf :: Action
+--lookAroundSelf = UseSelf CrTurnAround
 
 viewTarget :: World -> Creature -> Creature
-viewTarget w cr = do
-    case cr ^? crIntention . viewPoint . _Just of
-        Just p
-            | hasLOSIndirect p (_crPos cr) w ->
-                cr'
-                    & crActionPlan . apAction
-                        %~ replaceNullWith
-                            ( TurnToPoint p
-                                `DoActionThen` 40 `WaitThen` lookAroundSelf
-                                `DoActionThen` 20 `WaitThen` lookAroundSelf
-                            )
-                    & crIntention . viewPoint .~ Nothing
-            | otherwise -> cr' & crActionPlan . apAction %~ replaceNullWith (PathTo p)
-        Nothing -> cr -- & crPerception . crAwakeLevel .~ Lethargic
-  where
-    cr' = cr & crPerception . cpVigilance .~ Vigilant
+viewTarget w cr = case cr ^? crIntention . viewPoint . _Just of
+    Just p
+        | hasLOSIndirect p (_crPos cr) w ->
+            cr
+                & crActionPlan . apAction
+                    .~ [TurnToPoint p]
+--                    %~ replaceNullWith
+--                        ( TurnToPoint p
+--                        )
+                & crIntention . viewPoint .~ Nothing
+        | otherwise -> cr & crActionPlan . apAction %~ replaceNullWith (PathTo p)
+    Nothing -> cr
 
 replaceNullWith :: a -> [a] -> [a]
 replaceNullWith x [] = [x]
@@ -155,7 +156,7 @@ reloadOverride cr = fromMaybe cr $ do
     guard $ cr ^. crStance . posture == Aiming
     itRef <- cr ^? crManipulation . manObject . inInventory . ispItem
     guard $ cr ^? crInv . ix itRef . itUse . heldConsumption . laLoaded == Just 0
-    return $    cr & crActionPlan . apStrategy .~ StrategyActions Reload reloadActions
+    return $ cr & crActionPlan . apStrategy .~ StrategyActions Reload reloadActions
   where
     reloadActions =
         [ holsterWeapon
@@ -192,21 +193,22 @@ targetYouWhenCognizant :: World -> Creature -> Creature
 targetYouWhenCognizant w cr = case cr ^? crPerception . cpAwareness . ix 0 of
     -- so this caused a space leak: be careful with ?~
     -- consider changing targeted creature to be just an index
-    Just (Cognizant _) -> (w ^?! cWorld . lWorld . creatures . ix 0) `seq` cr & crIntention . targetCr ?~ (w ^?! cWorld . lWorld . creatures . ix 0)
+    Just (Cognizant _) -> (w ^?! cWorld . lWorld . creatures . ix 0) `seq` 
+        cr & crIntention . targetCr ?~ (w ^?! cWorld . lWorld . creatures . ix 0)
+            & crPerception . cpVigilance .~ Vigilant
     _ -> cr & crIntention . targetCr .~ Nothing
 
 searchIfDamaged :: Creature -> Creature
 searchIfDamaged cr
-    | _crPastDamage cr > 0 = case _apStrategy (_crActionPlan cr) of
-        WatchAndWait ->
-            cr & crPerception . cpVigilance .~ Vigilant
-                & crActionPlan . apStrategy
-                    .~ StrategyActions
-                        LookAround
-                        [ TurnToPoint (_crPos cr -.- unitVectorAtAngle (_crDir cr))
-                            `DoActionThen` 40 `WaitThen` bfsThenReturn 500
-                        ]
-        _ -> cr
+    | _crPastDamage cr > 0
+        && _apStrategy (_crActionPlan cr) == WatchAndWait =
+        cr & crPerception . cpVigilance .~ Vigilant
+            & crActionPlan . apStrategy
+                .~ StrategyActions
+                    LookAround
+                    [ TurnToPoint (_crPos cr -.- unitVectorAtAngle (_crDir cr))
+                        `DoActionThen` 40 `WaitThen` bfsThenReturn 500
+                    ]
     | otherwise = cr
 
 bfsThenReturn :: Int -> Action

src/Dodge/Creature/SetTarget.hs

@@ -3,6 +3,7 @@ module Dodge.Creature.SetTarget where
 
 import Control.Lens
 import Dodge.Data.World
+--import MaybeHelp
 
 -- | Assumes that you are id 0: if creature is cognizant of you, sets you as target
 targetYouWhenCognizant ::

src/Dodge/Creature/SpreadGunCrit.hs

@@ -18,4 +18,4 @@ spreadGunCrit =
         , _crHP = 500
         }
         & crType . humanoidAI .~ SpreadGunAI
-        & crType . skinUpper .~ light4 red
+        & crType . skinUpper .~ lightx4 red

src/Dodge/Creature/State.hs

@@ -53,13 +53,12 @@ foldCr xs cr w = foldl' f w xs
 stateUpdate :: (Creature -> World -> World) -> Creature -> World -> World
 stateUpdate f =
     foldCr
-        [ doDamage -- these three
-        , checkDeath -- must be in
-        , clearDamage -- this order 24/7/22
-        , internalUpdate
+        [ doDamage -- these two
+        , checkDeath -- must be in this order 24/7/22
+        , internalHammerUpdate
         , f
         , movementSideEff
-        , upInv -- upInv must be called before invSideEff 22.05.23
+        , updateInv -- upInv must be called before invSideEff 22.05.23
         , invSideEff
         , equipmentEffects
         , heldAimEffects
@@ -76,6 +75,7 @@ heldAimEffects cr = fromMaybe id $ do
 checkDeath :: Creature -> World -> World
 checkDeath cr w
     | _crHP cr > 0 = w
+        & cWorld . lWorld . creatures . ix (_crID cr) . crState . csDamage .~ []
     | otherwise =
         w
             --        & creatures . at (_crID cr) .~ Nothing
@@ -139,8 +139,8 @@ bloodPuddleAt p w =
   where
     (q, g) = randInCirc 10 & runState $ _randGen w
 
-internalUpdate :: Creature -> World -> World
-internalUpdate cr =
+internalHammerUpdate :: Creature -> World -> World
+internalHammerUpdate cr =
     cWorld . lWorld . creatures . ix (_crID cr)
         %~ ( (crHammerPosition %~ moveHammerUp)
                 . stepReloading
@@ -156,11 +156,6 @@ dropByState cr w = foldr (dropItem cr) w $ case cr ^. crState . csDropsOnDeath o
     DropSpecific xs -> xs
     DropAmount n -> take n $ evalState (shuffle $ IM.keys $ _crInv cr) (_randGen w)
 
-clearDamage :: Creature -> World -> World
-clearDamage cr w =
-    w
-        & cWorld . lWorld . creatures . ix (_crID cr) . crState . csDamage .~ []
-
 doDamage :: Creature -> World -> World
 doDamage cr w =
     w
@@ -225,8 +220,8 @@ useEquipment cr i = useE (_eeUse (_equipEffect $ _itUse itm)) itm cr
     itm = _crInv cr IM.! i
 
 -- a map updating all inventory items
-upInv :: Creature -> World -> World
-upInv cr = cWorld . lWorld . creatures . ix (_crID cr) . crInv %~ IM.mapWithKey (itemUpdate cr)
+updateInv :: Creature -> World -> World
+updateInv cr = cWorld . lWorld . creatures . ix (_crID cr) . crInv %~ IM.mapWithKey (itemUpdate cr)
 
 -- a loop going over equipped items
 equipmentEffects :: Creature -> World -> World

src/Dodge/Creature/SwarmCrit.hs

@@ -17,7 +17,7 @@ swarmCrit =
         , _crFaction = ColorFaction yellow
         , _crMeleeCooldown = 0
         }
-        & crType . skinUpper .~ light4 yellow
+        & crType . skinUpper .~ lightx4 yellow
         & crType . humanoidAI .~ SwarmAI
 
 --swarmCritMoveFunc :: Creature -> Point2 -> Creature -> Point2

src/Dodge/Creature/Test.hs

@@ -24,6 +24,7 @@ module Dodge.Creature.Test (
     crSafeDistFromTarg,
 ) where
 
+--import MaybeHelp
 import Control.Lens
 import Data.List (find)
 import Data.Maybe
@@ -45,6 +46,11 @@ crWeaponReady cr = fromMaybe False $ do
 crCanSeeCr :: Creature -> (World, Creature) -> Bool
 crCanSeeCr tcr (w, cr) = hasLOS (_crPos cr) (_crPos tcr) w
 
+--crCanSeeCrid :: Int -> (World, Creature) -> Bool
+--crCanSeeCrid tcid (w, cr) = fromMaybe False $ do
+--    tcr <- w ^? cWorld . lWorld . creatures . ix tcid
+--    return $ hasLOS (_crPos cr) (_crPos tcr) w
+
 crIsAiming :: Creature -> Bool
 crIsAiming cr = _posture (_crStance cr) == Aiming
 

src/Dodge/Creature/YourControl.hs

@@ -2,9 +2,9 @@ module Dodge.Creature.YourControl (
     yourControl,
 ) where
 
+import Dodge.WASD
 import Dodge.Base.You
 import Dodge.Creature.Impulse.UseItem
-import Data.Foldable
 import qualified Data.Map.Strict as M
 import Data.Maybe
 import Dodge.Base.Coordinate
@@ -74,7 +74,7 @@ wasdWithAiming w speed cr
         | movDir == V2 0 0 = id
         | otherwise = crMvForward speed
     theTurn cr' = creatureTurnTowardDir (_crMvAim cr') 0.2 cr'
-    movDir = wasdDir w
+    movDir = wasdDir (w ^. input)
     dir = fmap ((w ^. wCam . camRot) +) (safeArgV movDir)
     movAbs = rotateV (w ^. wCam . camRot) $ normalizeV movDir
     isAiming = _posture (_crStance cr) == Aiming
@@ -92,16 +92,6 @@ aimTurn a cr = creatureTurnTowardDir a (x * 0.2) cr
         itRef <- cr ^? crManipulation . manObject . inInventory . ispItem
         cr ^? crInv . ix itRef . itUse . heldAim . aimTurnSpeed
 
-wasdM :: SDL.Scancode -> Point2
-wasdM scancode = case scancode of
-    SDL.ScancodeW -> V2 0 1
-    SDL.ScancodeS -> V2 0 (-1)
-    SDL.ScancodeD -> V2 1 0
-    SDL.ScancodeA -> V2 (-1) 0
-    _ -> V2 0 0
-
-wasdDir :: World -> Point2
-wasdDir = foldl' (flip $ (+.+) . wasdM) (V2 0 0) . M.keys . _pressedKeys . _input
 
 -- | Set posture according to mouse presses.
 mouseActionsCr :: M.Map SDL.MouseButton Int -> Creature -> Creature
@@ -128,5 +118,6 @@ pressedMBEffectsTopInventory pkeys w
         _ -> False
     isDown but = but `M.member` pkeys
     theinput = w ^. input
-    rotation = fromMaybe 0 
-        $ angleBetween (theinput ^. mousePos) <$> (theinput ^. heldPos . at SDL.ButtonMiddle)
+    rotation = maybe 0 
+        (angleBetween (theinput ^. mousePos)) 
+        (theinput ^. heldPos . at SDL.ButtonMiddle)

src/Dodge/Data/ActionPlan.hs

@@ -16,10 +16,10 @@ import Sound.Data
 data ActionPlan
     = Inanimate
     | ActionPlan
-        { _apImpulse :: [Impulse]
-        , _apAction :: [Action]
-        , _apStrategy :: Strategy
-        , _apGoal :: [Goal]
+        { _apImpulse :: [Impulse] -- done per frame
+        , _apAction :: [Action] -- updated per frame, likely persist across frames
+        , _apStrategy :: Strategy -- current strategy
+        , _apGoal :: [Goal] -- particular ordered goals
         }
     --deriving (Eq, Ord, Show, Read) --Generic, Flat)
     deriving (Eq, Ord, Show) --Generic, Flat)
@@ -174,8 +174,8 @@ data Action
     --deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data Strategy
-    = Flank Int
-    | Ambush Int
+    = Flank {_flankTarget :: Int}
+    | Ambush {_ambushTarget :: Int}
     | Lure Int Point2
     | Patrol [Point2]
     | ShootAt Int
@@ -183,7 +183,7 @@ data Strategy
     | WatchAndWait
     | WarningCry
     | LookAround
-    | CloseToMelee Int
+    | CloseToMelee {_meleeTarget :: Int}
     | StrategyActions Strategy [Action]
     | GetTo Point2
     | Reload
@@ -194,8 +194,8 @@ data Strategy
 
 data Goal
     = LiveLongAndProsper
-    | Kill Int
-    | SentinelAt Point2 Float
+    | Kill {_killTarget :: Int}
+    | SentinelAt {_sentinelPos :: Point2, _sentinelDir :: Float}
     deriving (Eq, Ord, Show) --Generic, Flat)
     --deriving (Eq, Ord, Show, Read) --Generic, Flat)
 

src/Dodge/Data/Camera.hs

@@ -12,7 +12,6 @@ import Geometry.Data
 data CamControl
     = CamInGame
     | CamFloat
-    | CamPan
   deriving (Eq,Show,Read,Enum,Bounded)
 
 data Camera = Camera

src/Dodge/Data/Config.hs

@@ -89,6 +89,7 @@ data DebugBool
     | Inspect_wall
     | Show_nodes_near_select
     | Show_path_between
+    | Select_creature
     deriving (Eq, Ord, Bounded, Enum, Show)
 
 data ResFactor = DoubleRes | FullRes | HalfRes | QuarterRes | EighthRes | SixteenthRes
@@ -96,11 +97,9 @@ data ResFactor = DoubleRes | FullRes | HalfRes | QuarterRes | EighthRes | Sixtee
 
 data ShadowRendering 
     = GeoObjShads 
-    | InstancingShads
     | NoObjShads
     | NoShadows
     | NoLighting
-    | ComputeShader
     deriving (Show, Eq, Ord, Enum, Bounded)
 
 data RoomClipping = NoRoomClipBoundaries | AllRoomClipBoundaries | IntersectingRoomClipBoundaries

src/Dodge/Data/Creature.hs

@@ -32,6 +32,7 @@ import Dodge.Data.Item
 import Dodge.Data.Material
 import Geometry.Data
 import qualified IntMapHelp as IM
+--import MaybeHelp
 
 data Creature = Creature
     { _crPos :: Point2

src/Dodge/Data/FloatFunction.hs

@@ -12,6 +12,7 @@ data FloatFloat
     = FloatID
     | FloatFOV Float
     | FloatLessCheck Float
+    | FloatDistLinearNearFar Float Float Float
     | FloatAbsCheckGreaterLess Float Float Float
     | FloatConst Float
     deriving (Eq, Ord, Show, Read) --Generic, Flat)

src/Dodge/Data/Input.hs

@@ -25,6 +25,8 @@ data Input = Input
     , _smoothScrollAmount :: Int
     , _clickPos :: M.Map MouseButton Point2 -- updates on initial mouse button press
     , _heldPos :: M.Map MouseButton Point2 -- updates while mouse button is held, lags one frame
+    , _clickWorldPos :: M.Map MouseButton Point2 -- updates on initial mouse button press
+    , _heldWorldPos :: M.Map MouseButton Point2 -- updates while mouse button is held, lags one frame
     , _textInput :: [Either TermSignal Char]
     , _scrollTestFloat :: Float
     , _scrollTestInt :: Int

src/Dodge/Data/Universe.hs

@@ -41,25 +41,21 @@ data Universe = Universe
     , _uvFrameTicks :: Word32
     , _uvRAMSave :: Maybe World
     , _uvDebug :: M.Map DebugBool DebugItem
+    , _uvDebugMessageOffset :: Int
     }
 
 data DebugItem = DebugItem
-    { _debugPic :: Picture
-    , _debugInfo :: [DebugMessage]
+    { _debugPic :: Universe -> Picture
+    , _debugMessage :: Universe -> [String]
+    , _debugInfo :: DebugInfo
     }
 
-data DebugMessage
-    = DebugSimpleMessage
-        { _debugMessage :: [String]
-        }
-    | DebugWorldPosMessage
-        { _debugWorldPos :: V3 Float
-        , _debugMessage :: [String]
-        }
-    | DebugScreenPosMessage
-        { _debugScreenPos :: V2 Float
-        , _debugMessage :: [String]
-        }
+data DebugInfo
+    = NoDebugInfo
+    | DebugV3 { _debugV3 :: V3 Float}
+    | DebugV2 { _debugV2 :: V2 Float}
+    | DebugMInt { _debugMInt :: Maybe Int}
+    | DebugIntMInt {_debugInt :: Int, _debugMInt :: Maybe Int}
 
 data SideEffect
     = NewSideEffect
@@ -119,3 +115,5 @@ makeLenses ''SideEffect
 makeLenses ''MenuOptionDisplay
 makeLenses ''MenuOption
 makeLenses ''PositionedMenuOption
+makeLenses ''DebugItem
+makeLenses ''DebugInfo

src/Dodge/Data/World.hs

@@ -58,12 +58,17 @@ data TimeFlowStatus
     = DeathTime
         {_deathDelay :: Int}
     | NormalTimeFlow
-    | ScrollTimeFlow
+    | ItemScrollTimeFlow
         { _scrollSmoothing :: Int
         , _reverseAmount :: Int
         , _futureWorlds :: [LWorld]
         , _scrollItemLocation :: Int
         }
+    | CameraScrollTimeFlow
+        { _scrollSmoothing :: Int
+        , _reverseAmount :: Int
+        , _futureWorlds :: [LWorld]
+        }
     | RewindLeftClick
         { _reverseAmount :: Int
         , _scrollItemLocation :: Int

src/Dodge/Debug.hs

@@ -1,13 +1,22 @@
 module Dodge.Debug where
 
-import Dodge.Debug.Picture
+import Data.Aeson.Types
+import AesonHelp
 import Control.Lens
-import Dodge.Data.Universe
+import Data.List (sortOn)
+import qualified Data.Map.Strict as M
+import Data.Maybe
 import qualified Data.Set as S
+import Dodge.Base.Coordinate
+import Dodge.Data.Universe
+import Dodge.Debug.Picture
+import Dodge.WorldEvent.ThingsHit
+import Geometry.Vector
+import qualified SDL
 
 debugEvents :: Universe -> Universe
 debugEvents u = case dbools ^. at Enable_debug of
-    Nothing -> u 
+    Nothing -> u
     Just () -> S.foldr debugEvent u dbools
   where
     dbools = u ^. uvConfig . debug_booleans
@@ -15,10 +24,73 @@ debugEvents u = case dbools ^. at Enable_debug of
 debugEvent :: DebugBool -> Universe -> Universe
 debugEvent db u = case db of
     Collision_test -> u & uvDebug . at Collision_test ?~ collisionDebugItem u
+    Select_creature -> u & uvDebug . at Select_creature ?~ selectCreatureDebugItem u
     _ -> u
 
 collisionDebugItem :: Universe -> DebugItem
-collisionDebugItem u = DebugItem
-    { _debugPic = drawCollisionTest $ u ^. uvWorld
-    , _debugInfo = []
-    }
+collisionDebugItem u =
+    DebugItem
+        { _debugPic = const $ drawCollisionTest $ u ^. uvWorld
+        , _debugMessage = const []
+        , _debugInfo = NoDebugInfo
+        }
+
+selectCreatureDebugItem :: Universe -> DebugItem
+selectCreatureDebugItem u =
+    DebugItem
+        { _debugPic = const mempty
+        , _debugMessage = debugSelectCreatureMessage
+        , _debugInfo = scrollDebugInfoInt (length $ debugSelectCreatureList 0 u) u $ clickGetCreature u
+        }
+
+scrollDebugInfoInt :: Int -> Universe -> DebugInfo -> DebugInfo
+scrollDebugInfoInt i u
+    | SDL.ScancodeRShift `M.member` (u ^. uvWorld . input . pressedKeys) =
+        debugInt %~ ((`mod` i) . (+ (u ^. uvWorld . input . scrollAmount)))
+    | otherwise = id
+
+debugSelectCreatureMessage :: Universe -> [String]
+debugSelectCreatureMessage u = fromMaybe
+    [show (u ^? uvDebug . ix Select_creature . debugInfo . debugInt)]
+    $ do
+        cid <- u ^? uvDebug . ix Select_creature . debugInfo . debugMInt . _Just
+        i <- u ^? uvDebug . ix Select_creature . debugInfo . debugInt
+        cap <- debugSelectCreatureList cid u !! i
+        return $ show cid : cap
+
+debugSelectCreatureList :: Int -> Universe -> [Maybe [String]]
+debugSelectCreatureList cid u =
+    [ debugList "ActionPlan"
+        (u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crActionPlan)
+    , debugList "Perception"
+        (u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crPerception)
+    , debugList "Intention"
+        (u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crIntention)
+    , debugList "Memory"
+        (u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crMemory)
+    , debugList "Strategy"
+        (u ^? uvWorld . cWorld . lWorld . creatures . ix cid . crActionPlan . apStrategy)
+    ]
+
+
+debugList :: (Functor f, ToJSON a) => String -> f a -> f [String]
+debugList str = fmap (([str] ++) . getPrettyShort )
+
+
+clickGetCreature :: Universe -> DebugInfo
+clickGetCreature u
+    | SDL.ButtonLeft `M.member` (u ^. uvWorld . input . mouseButtons)
+        && SDL.ScancodeRShift `M.member` (u ^. uvWorld . input . pressedKeys) =
+        DebugIntMInt 0 (closestCreatureID u)
+    | otherwise =
+        fromMaybe (DebugIntMInt 0 Nothing) $
+            u ^? uvDebug . ix Select_creature . debugInfo
+
+closestCreatureID :: Universe -> Maybe Int
+closestCreatureID u =
+    fmap (_crID . snd) . listToMaybe . reverse
+        . sortOn (dist mwp . fst)
+        . crsHitRadial mwp 100
+        $ _uvWorld u
+  where
+    mwp = mouseWorldPos (u ^. uvWorld . input) (u ^. uvWorld . wCam)

src/Dodge/Debug/Picture.hs

@@ -102,15 +102,15 @@ intersectLinefromScreen cfig w a b =
 
 drawCollisionTest :: World -> Picture
 drawCollisionTest w = fromMaybe mempty $ do
-    a <- w ^. input . clickPos . at ButtonLeft
-    b <- w ^. input . clickPos . at ButtonRight
+    a <- w ^. input . heldWorldPos . at ButtonLeft
+    b <- w ^. input . heldWorldPos . at ButtonRight
     return $
         setLayer DebugLayer (color orange $ line [a, b])
-            <> foldMap (drawCross . fst) (crHit a b w)
-            <> foldMap (drawCross . _crPos) (crsNearSeg a b w)
-            <> foldMap (drawZoneCol green crZoneSize . zoneOfPoint crZoneSize) (xIntercepts crZoneSize a b)
-            <> foldMap (drawZoneCol yellow crZoneSize . zoneOfPoint crZoneSize) (yIntercepts' crZoneSize a b)
-            <> foldMap (drawLabCrossCol blue) (xIntercepts crZoneSize a b)
+            <> foldMap (drawCrossCol red . fst) (thingHit a b w)
+--            <> foldMap (drawCross . _crPos) (crsNearSeg a b w)
+--            <> foldMap (drawZoneCol green crZoneSize . zoneOfPoint crZoneSize) (xIntercepts crZoneSize a b)
+--            <> foldMap (drawZoneCol yellow crZoneSize . zoneOfPoint crZoneSize) (yIntercepts' crZoneSize a b)
+--            <> foldMap (drawLabCrossCol blue) (xIntercepts crZoneSize a b)
 
 drawZoneCol :: Color -> Float -> V2 Int -> Picture
 drawZoneCol col s (V2 x y) = setLayer DebugLayer . color col $ thickLine 2 (p : ps ++ [p])
@@ -158,6 +158,7 @@ debugDraw' cfig w bl = case bl of
     Show_nodes_near_select -> undefined --drawNodesNearSelect w
     Show_path_between -> drawPathBetween w
     Collision_test -> mempty
+    Select_creature -> mempty
 
 drawCreatureDisplayTexts :: World -> Picture
 drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (w ^. cWorld . lWorld . creatures)

src/Dodge/Default/Creature.hs

@@ -7,6 +7,7 @@ import Dodge.Data.FloatFunction
 import Geometry.Data
 import qualified IntMapHelp as IM
 import Picture
+--import MaybeHelp
 
 defaultCreature :: Creature
 defaultCreature =
@@ -62,7 +63,7 @@ defaultCreatureTargeting :: CreatureTargeting
 defaultCreatureTargeting = CreatureTargeting Nothing Nothing Nothing False
 
 defaultCreatureSkin :: CreatureType
-defaultCreatureSkin = Humanoid (greyN 0.9) (light4 green) (greyN 0.3) InanimateAI
+defaultCreatureSkin = Humanoid (greyN 0.9) (lightx4 green) (greyN 0.3) InanimateAI
 
 defaultInanimate :: Creature
 defaultInanimate = defaultCreature & crActionPlan .~ Inanimate
@@ -90,8 +91,8 @@ defaultPerceptionState =
 defaultVision :: Vision
 defaultVision =
     Eyes
-        { _viFOV = FloatFOV 0.5
-        , _viDist = FloatLessCheck 500
+        { _viFOV = FloatFOV 0.8
+        , _viDist = FloatDistLinearNearFar 500 10 1
         }
 
 defaultAudition :: Audition
@@ -112,7 +113,7 @@ defaultChaseMvType :: CrMvType
 defaultChaseMvType =
     CrMvType
         { _mvSpeed = 2
-        , _mvTurnRad = FloatAbsCheckGreaterLess (pi / 4) 0.2 0.05 --f
+        , _mvTurnRad = FloatAbsCheckGreaterLess (pi / 4) 0.2 0.05
         , _mvTurnJit = 0.2
         , _mvAimSpeed = FloatAbsCheckGreaterLess (pi / 8) 0.2 0.01
         }
@@ -139,7 +140,6 @@ defaultState :: CreatureState
 defaultState =
     CrSt
         { _csDamage = []
-        , --    , _crPastDamage = V.fromList $ replicate 20 []
-          _csSpState = GenCr
+        , _csSpState = GenCr
         , _csDropsOnDeath = DropAll
         }

src/Dodge/Default/World.hs

@@ -14,7 +14,9 @@ defaultInput :: Input
 defaultInput =
     Input
         { _clickPos = mempty
+        , _clickWorldPos = mempty
         , _heldPos = mempty
+        , _heldWorldPos = mempty
         , _textInput = mempty
         , _pressedKeys = mempty
         , _mouseButtons = mempty

src/Dodge/Event/Input.hs

@@ -1,5 +1,4 @@
 {- | Capture input events, store them in structures for later use.
- Should not update the world other than this.
 -}
 module Dodge.Event.Input (
     handleKeyboardEvent,
@@ -57,8 +56,7 @@ handleMouseMotionEvent mmev cfig =
             (0.5 * windowYFloat cfig - fromIntegral y)
 
 handleMouseWheelEvent :: MouseWheelEventData -> Input -> Input
-handleMouseWheelEvent mwev =
-    (scrollAmount +~ fromIntegral y)
+handleMouseWheelEvent mwev = scrollAmount +~ fromIntegral y
   where
     V2 _ y = mouseWheelEventPos mwev
 
@@ -66,7 +64,7 @@ handleMouseButtonEvent :: MouseButtonEventData -> Input -> Input
 handleMouseButtonEvent mbev theinput = case mouseButtonEventMotion mbev of
     Released -> theinput & mouseButtons . at thebutton .~ Nothing
     Pressed -> theinput
-        & mouseButtons . at thebutton ?~ 1
+        & mouseButtons . at thebutton ?~ 0
         & clickPos . at thebutton ?~ (theinput ^. mousePos)
     -- note that mouse button down events are NOT repeating
   where

src/Dodge/FloatFunction.hs

@@ -12,6 +12,9 @@ doFloatFloat ff x = case ff of
     FloatLessCheck y
         | x > y -> 0
         | otherwise -> 1
+    FloatDistLinearNearFar maxd a b
+        | x > maxd -> 0
+        | otherwise -> (a * (maxd - x) + b * (x - maxd)) / maxd
     FloatAbsCheckGreaterLess a y1 y2
         | abs x > a -> y1
         | otherwise -> y2

src/Dodge/Humanoid.hs

@@ -16,7 +16,7 @@ updateHumanoid cr = case cr ^?! crType . humanoidAI of
             [ const doStrategyActions
             , performActions
             , const overrideMeleeCloseTarget
-            , const setViewPos
+            , setViewPos
             , setMvPos
             , chaseCritMv
             , chaseCritPerceptionUpdate [0]

src/Dodge/Luse.hs

@@ -30,7 +30,7 @@ useStopWatch itm _ w = w
 
 
 useTimeScrollGun :: Item -> Creature -> World -> World
-useTimeScrollGun itm _ w = w & timeFlow .~ ScrollTimeFlow
+useTimeScrollGun itm _ w = w & timeFlow .~ ItemScrollTimeFlow
     { _scrollSmoothing = 0
     , _reverseAmount = itm ^?! itUse . leftConsumption . wpCharge
     , _futureWorlds = []

src/Dodge/Menu.hs

@@ -185,7 +185,7 @@ graphicsMenuOptions =
     [ makeEnumOption graphics_world_resolution "World resolution" (uvIOEffects .~ updatePreload)
     , makeEnumOption graphics_downsize_resolution "Downsize resolution" 
         (uvIOEffects .~ updatePreload)
-    , makeEnumOption graphics_distortion_resolution "Overlay resolution" 
+    , makeEnumOption graphics_distortion_resolution "Distortion resolution" 
         (uvIOEffects .~ updatePreload)
     , makeEnumOption graphics_shadow_rendering "SHADOW RENDERING" id
     , makeEnumOption graphics_shadow_size "SHADOW DETAIL" id
@@ -233,7 +233,7 @@ listControls =
     , ("q|e", "ROTATE CAMERA")
     , ("<F1>", "USE NORMAL CAMERA")
     , ("<F2>", "PAUSE AND FLOAT CAMERA")
-    , ("<F3>", "PAUSE AND PAN CAMERA")
+--    , ("<F3>", "PAUSE AND PAN CAMERA")
     , ("<F5>", "QUICKSAVE")
     , ("<F9>", "QUICKLOAD")
     ]

src/Dodge/Render.hs

@@ -228,11 +228,9 @@ doDrawing' win pdata u = do
     glBindTextureUnit 0 (pdata ^. fboBloom . _2 . unTO)
     glDisable GL_BLEND
     drawShader (_bloomBlurShader pdata) 4
-    if cfig ^. graphics_bloom 
-    then do   
+    when (cfig ^. graphics_bloom) $ do   
         replicateM_ 2 $ pingPongBetween (_fboHalf1 pdata) (_fboHalf2 pdata) (_bloomBlurShader pdata)
         glEnable GL_BLEND
-    else return ()
     setViewport _graphics_world_resolution cfig
     --draw clouds onto cloud buffer
     glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboCloud pdata)))

src/Dodge/Render/ShapePicture.hs

@@ -2,6 +2,7 @@ module Dodge.Render.ShapePicture (
     worldSPic,
 ) where
 
+import Dodge.Render.List
 import Control.Lens
 import Control.Monad (guard)
 import Data.Foldable
@@ -139,6 +140,11 @@ extraPics cfig u =
         <> concatMapPic ppDraw (_pressPlates lw)
         <> viewClipBounds cfig w
         <> debugDraw cfig w
+        <> foldMap (`_debugPic` u) (_uvDebug u)
+        <> setLayer FixedCoordLayer
+            (listPicturesAt (1.3 * halfWidth cfig) 0 cfig 
+                . take 50 . drop (u ^. uvDebugMessageOffset)
+                . map text $ foldMap (`_debugMessage` u) (_uvDebug u))
   where
     w = u ^. uvWorld
     lw = w ^. cWorld . lWorld

src/Dodge/Save.hs

@@ -10,6 +10,7 @@ module Dodge.Save (
 ) where
 
 
+import Control.Monad
 import Data.Maybe
 import Dodge.WorldLoad
 import Dodge.Path.Translate
@@ -44,8 +45,7 @@ writeSaveSlot ss u = do
 readSaveSlot :: SaveSlot -> IO (Universe -> Maybe Universe)
 readSaveSlot ss = do
     fExists <- doesFileExist $ saveSlotPath ss
-    if not fExists then error "Tried to read non-existant save file"
-        else return ()
+    unless fExists $ error "Tried to read non-existant save file"
     mcw <- decodeFileStrict $ saveSlotPath ss
     flip (maybe (error "Tried to read incorrectly encoded save file")) mcw $ \cw ->
         return $ \uv -> Just 

src/Dodge/TestString.hs

@@ -1,6 +1,7 @@
 {-# OPTIONS_GHC -Wno-unused-imports #-}
 module Dodge.TestString where
 
+import AesonHelp
 import Dodge.SmoothScroll
 import HelpNum
 import Dodge.Base.Coordinate
@@ -39,14 +40,12 @@ testStringInit u = [show $ u ^. uvWorld . input . smoothScrollAmount
     --[show $ u ^? uvWorld . hud . hudElement . diSections . sssExtra . sssSelPos . _Just]
 --    [show $ fmap IM.keys $ u ^? uvWorld . hud . hudElement . subInventory . ciSections . sssSections]
 
-getPretty :: ToJSON a => a -> [String]
-getPretty = lines . unpack . AEP.encodePretty' (AEP.Config (AEP.Spaces 2) compare AEP.Generic False)
-
 showTimeFlow :: TimeFlowStatus -> String
 showTimeFlow tfs = case tfs of
     DeathTime i -> "DeathTime"++show i
     NormalTimeFlow -> "NormalTimeFlow"
-    ScrollTimeFlow {_reverseAmount = ra } -> "ScrollTimeFlow" ++ show ra
+    ItemScrollTimeFlow {_reverseAmount = ra } -> "ItemScrollTimeFlow" ++ show ra
+    CameraScrollTimeFlow {_reverseAmount = ra } -> "CameraScrollTimeFlow" ++ show ra
     RewindLeftClick {_reverseAmount = ra } -> "RewindLeftClick" ++ show ra
     PausedTimeFlow {_timeFlowCharge = ra } -> "PausedTimeFlow" ++ show ra
 --    [ show $ u ^? uvScreenLayers . _head . scOffset

src/Dodge/Update.hs

@@ -83,10 +83,23 @@ updateUniverse u =
 updateUniverseFirst :: Universe -> Universe
 updateUniverseFirst u =
     u
+        & uvWorld . input . clickWorldPos %~ M.union (setClickWorldPos u)
         & uvWorld . input . smoothScrollAmount %~ calcSmoothScroll (u ^. uvWorld . input . scrollAmount)
         & over (uvWorld . input) updateScrollTestValue
+        & updateDebugMessageOffset
         & over (uvWorld . cWorld . cClock) (+ 1)
 
+updateDebugMessageOffset :: Universe -> Universe
+updateDebugMessageOffset u
+    | SDL.ScancodeRShift `M.member` (u ^. uvWorld . input . pressedKeys)
+        = u & uvDebugMessageOffset %~ (max 0 . subtract (u ^. uvWorld . input . scrollAmount))
+    | otherwise = u
+
+setClickWorldPos :: Universe -> M.Map MouseButton Point2
+setClickWorldPos u = fmap 
+    (const (screenToWorldPos (u ^. uvWorld . wCam) (u ^. uvWorld . input . mousePos)))
+    (M.filter (== 0) $ u ^. uvWorld . input . mouseButtons)
+
 updateWorldEventFlags :: Universe -> Universe
 updateWorldEventFlags u =
     (uvWorld . worldEventFlags .~ mempty)
@@ -119,8 +132,10 @@ updateUniverseLast u =
         & uvWorld . input . mouseMoving .~ False
         & uvWorld . input . mouseButtons . each +~ 1
         & uvWorld . input . heldPos %~ M.union (fmap (const mp) (u ^. uvWorld . input . mouseButtons))
+        & uvWorld . input . heldWorldPos %~ M.union (fmap (const mwp) (u ^. uvWorld . input . mouseButtons))
   where
     mp = u ^. uvWorld . input . mousePos
+    mwp = screenToWorldPos (u ^. uvWorld . wCam) mp
     f LongPress = LongPress
     f _ = ShortPress
 
@@ -143,32 +158,33 @@ updateUniverseMid u = case _uvScreenLayers u of
 
 timeFlowUpdate :: Universe -> Universe
 timeFlowUpdate u = case u ^. uvWorld . timeFlow of
-    _ | debugcamera -> u
     NormalTimeFlow -> functionalUpdate u
-    ScrollTimeFlow smoothing _ _ _ -> over uvWorld (doTimeScroll smoothing) u
+    ItemScrollTimeFlow smoothing _ _ _ -> over uvWorld (doItemTimeScroll smoothing) u
+    CameraScrollTimeFlow smoothing _ _ 
+        | SDL.ScancodeLShift `M.member` (u ^. uvWorld . input . pressedKeys) 
+            -> over uvWorld (doTimeScroll smoothing) u
+    CameraScrollTimeFlow {} -> u
     RewindLeftClick 0 _ -> u & uvWorld . timeFlow .~ NormalTimeFlow
     RewindLeftClick _ _ -> over uvWorld scrollTimeBack u -- & uvWorld . cWorld . timeFlow .~ NormalTimeFlow
     DeathTime{} -> u
     PausedTimeFlow _ itmloc -> over uvWorld (pauseTime itmloc) u
-  where
-    debugcamera = CamInGame /= (u ^. uvWorld . wCam . camControl)
 
 pauseTime :: Int -> World -> World
 pauseTime itmloc w
     | justPressedButtonLeft || outofcharge = w & timeFlow .~ NormalTimeFlow
     | otherwise = w & pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix itmloc) . itUse . leftConsumption . wpCharge -~ 1
   where
-    justPressedButtonLeft = w ^? input . mouseButtons . ix ButtonLeft == Just 1
+    justPressedButtonLeft = w ^? input . mouseButtons . ix ButtonLeft == Just 0
     outofcharge = maybe True (== 0) charge
     charge = w ^? pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix itmloc) . itUse . leftConsumption . wpCharge
 
-doTimeScroll :: Int -> World -> World
-doTimeScroll smoothing w = case w ^? input . mouseButtons . ix ButtonLeft of
-    Just 1 -> w & timeFlow .~ NormalTimeFlow
-    _ -> doTimeScroll' smoothing w
+doItemTimeScroll :: Int -> World -> World
+doItemTimeScroll smoothing w = case w ^? input . mouseButtons . ix ButtonLeft of
+    Just 0 -> w & timeFlow .~ NormalTimeFlow
+    _ -> doTimeScroll smoothing w
 
-doTimeScroll' :: Int -> World -> World
-doTimeScroll' smoothing w = case w ^. input . scrollAmount of
+doTimeScroll :: Int -> World -> World
+doTimeScroll smoothing w = case w ^. input . scrollAmount of
     x | x > 1 -> w & scrollTimeBack & timeFlow . scrollSmoothing .~ 20
     x | x > 0 -> w & scrollTimeBack & timeFlow . scrollSmoothing %~ max 0
     x | x < (-1) -> w & scrollTimeForward & timeFlow . scrollSmoothing .~ negate 20
@@ -187,12 +203,14 @@ scrollTimeBack w = case w ^? pastWorlds . _head of
                     & timeFlow . futureWorlds .:~ (w ^. cWorld . lWorld)
                     & timeFlow . reverseAmount -~ 1
                     & cWorld . lWorld .~ lw
-                    & pointituse . leftConsumption . wpCharge .~ (x -1)
-                    & pointituse . leftHammer .~ HammerDown
+                    & mupdateitem x
         _ -> w
   where
-    pointituse = pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix i) . itUse
-    i = w ^?! timeFlow . scrollItemLocation
+    mupdateitem x = fromMaybe id $ do
+        i <- w ^? timeFlow . scrollItemLocation
+        let pointituse = pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix i) . itUse
+        return $ (pointituse . leftConsumption . wpCharge .~ (x -1))
+                    . ( pointituse . leftHammer .~ HammerDown)
 
 scrollTimeForward :: World -> World
 scrollTimeForward w = case w ^? timeFlow . futureWorlds . _head of
@@ -202,10 +220,13 @@ scrollTimeForward w = case w ^? timeFlow . futureWorlds . _head of
             & pastWorlds .:~ (w ^. cWorld . lWorld)
             & cWorld . lWorld .~ lw
             & timeFlow . reverseAmount .~ ramount
-            & pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix i) . itUse . leftConsumption . wpCharge .~ ramount
+            & mupdateitem   
   where
-    i = w ^?! timeFlow . scrollItemLocation
     ramount = (w ^?! timeFlow . reverseAmount) + 1
+    mupdateitem = fromMaybe id $ do
+        i <- w ^? timeFlow . scrollItemLocation
+        return $ pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix i) . itUse . leftConsumption . wpCharge .~ ramount
+
 
 -- | The update step.
 functionalUpdate :: Universe -> Universe
@@ -273,9 +294,8 @@ advanceScrollAmount u =
         & uvWorld . input . smoothScrollAmount %~ advanceSmoothScroll
 
 updatePastWorlds :: World -> World
-updatePastWorlds w = w & pastWorlds %~ (forceFoldable . take 100 . ((w ^. cWorld . lWorld) :))
-
---updatePastWorlds w = w & pastWorlds .~ []
+--updatePastWorlds w = w & pastWorlds %~ (forceFoldable . take 100 . ((w ^. cWorld . lWorld) :))
+updatePastWorlds w = w & pastWorlds %~ (forceFoldable . take 300 . ((w ^. cWorld . lWorld) :))
 
 doWorldEvents :: World -> World
 doWorldEvents w =

src/Dodge/Update/Camera.hs

@@ -5,6 +5,7 @@ module Dodge.Update.Camera (
     updateCamera,
 ) where
 
+import Dodge.WASD
 import Dodge.SmoothScroll
 import SDL (MouseButton (..))
 import Dodge.Base.Coordinate
@@ -32,13 +33,13 @@ updateCamera :: Configuration -> World -> World
 updateCamera cfig w = case w ^. wCam . camControl of
     CamInGame -> updateInGameCamera cfig w
     CamFloat -> updateFloatingCamera cfig w
-    CamPan -> w
 
 updateFloatingCamera :: Configuration -> World -> World
 updateFloatingCamera cfig w = w 
     & updateBounds cfig
     & wCam %~ setViewDistance cfig
     & wCam %~ translateFloatingCamera theinput
+    & wCam %~ translateFloatingCameraKeys theinput
     & wCam %~ zoomFloatingCamera theinput
   where
     theinput = w ^. input
@@ -46,7 +47,7 @@ updateFloatingCamera cfig w = w
 translateFloatingCamera :: Input -> Camera -> Camera
 translateFloatingCamera theinput cam = fromMaybe cam $ do
     presstime <- theinput ^. mouseButtons . at ButtonLeft
-    guard $ presstime > 1
+    guard $ presstime > 0
     hpos <- theinput ^? heldPos . ix ButtonLeft
     let thetran = 
             screenToWorldPos cam hpos
@@ -55,17 +56,23 @@ translateFloatingCamera theinput cam = fromMaybe cam $ do
     return $ cam & camCenter +~ thetran
         & camViewFrom +~ thetran
 
+translateFloatingCameraKeys :: Input -> Camera -> Camera
+translateFloatingCameraKeys theinput =  (camCenter -~ thetran)
+        . (camViewFrom -~ thetran)
+  where
+    thetran = 10 *.* wasdDir theinput
+
 zoomFloatingCamera :: Input -> Camera -> Camera
-zoomFloatingCamera theinput cam = cam
-    & camZoom *~ (zoomSpeed ^^ negate (getSmoothScrollValue theinput))
-    -- & camZoom *~ (zoomSpeed ^^ negate (theinput ^. smoothScrollAmount))
-    
+zoomFloatingCamera theinput cam 
+    | ButtonRight `M.member` (theinput ^. mouseButtons) = cam
+        & camZoom *~ (zoomSpeed ^^ negate (getSmoothScrollValue theinput))
+    | otherwise =  cam
 
 updateInGameCamera :: Configuration -> World -> World
 updateInGameCamera cfig w =
     w
         & updateBounds cfig
-        & over (wCam) (setViewDistance cfig)
+        & over wCam (setViewDistance cfig)
         & wCam %~ moveZoomCamera cfig (w ^. input) (you w)
         & updateScopeZoom
         & rotateCamera cfig
@@ -140,12 +147,12 @@ updateScopeZoom' i w
 doScopeZoom :: Int -> Point2 -> Scope -> Scope
 doScopeZoom scrollamount mp sc = case scrollamount of
     x
-        | x > 10 -> (zoomInLongGun mp . zoomInLongGun mp . zoomInLongGun mp) $ sc
-        | x > 5 -> (zoomInLongGun mp . zoomInLongGun mp) $ sc
-        | x > 0 -> zoomInLongGun mp $ sc
-        | x < -10 -> (zoomOutLongGun . zoomOutLongGun . zoomOutLongGun) $ sc
-        | x < -5 -> (zoomOutLongGun . zoomOutLongGun) $ sc
-        | x < 0 ->  zoomOutLongGun $ sc
+        | x > 10 -> (zoomInLongGun mp . zoomInLongGun mp . zoomInLongGun mp) sc
+        | x > 5 -> (zoomInLongGun mp . zoomInLongGun mp) sc
+        | x > 0 -> zoomInLongGun mp sc
+        | x < -10 -> (zoomOutLongGun . zoomOutLongGun . zoomOutLongGun) sc
+        | x < -5 -> (zoomOutLongGun . zoomOutLongGun) sc
+        | x < 0 ->  zoomOutLongGun sc
         | otherwise -> sc
 
 zoomSpeed :: Float
@@ -220,8 +227,8 @@ rotateCameraBy x w =
 rotateCamera :: Configuration -> World -> World
 rotateCamera cfig w
     | keydown SDL.ScancodeQ && keydown SDL.ScancodeE = w
-    | keydown SDL.ScancodeQ = (rotateCameraBy 0.025) w
-    | keydown SDL.ScancodeE = (rotateCameraBy (-0.025)) w
+    | keydown SDL.ScancodeQ = rotateCameraBy 0.025 w
+    | keydown SDL.ScancodeE = rotateCameraBy (-0.025) w
     | otherwise = ifConfigWallRotate cfig w
   where
     keydown scode = scode `M.member` _pressedKeys (_input w) && not (inInputFocus w)

src/Dodge/Update/Input/InGame.hs

@@ -61,7 +61,7 @@ updateUseInputInGame u = case u ^. uvWorld . hud . hudElement of
   where
     w = u ^. uvWorld
     pkeys = u ^. uvWorld . input . pressedKeys
-    lbinitialpress = u ^? uvWorld . input . mouseButtons . ix ButtonLeft == Just 1
+    lbinitialpress = u ^? uvWorld . input . mouseButtons . ix ButtonLeft == Just 0
 
 updatePressedButtonsCarte :: World -> World
 updatePressedButtonsCarte w = updatePressedButtonsCarte' (_mouseButtons (_input w)) w
@@ -78,7 +78,7 @@ updatePressedButtonsCarte' pkeys w
   where
     isDown but = but `M.member` pkeys
     mbutpos but = theinput ^. heldPos . at but
-    rot = fromMaybe 0 $ angleBetween (_mousePos (_input w)) <$> mbutpos SDL.ButtonLeft
+    rot = maybe 0 (angleBetween (_mousePos (_input w))) $ mbutpos SDL.ButtonLeft
     czoom = fromMaybe 1 $ do
         p <- mbutpos SDL.ButtonLeft
         return $ magV (_mousePos theinput) / magV p
@@ -110,7 +110,7 @@ updateInitialPressInGame :: Universe -> Scancode -> Universe
 updateInitialPressInGame uv sc = case sc of
     ScancodeF1 -> useNormalCamera uv
     ScancodeF2 -> pauseAndFloatCam uv
-    ScancodeF3 -> pauseAndPanCam uv
+--    ScancodeF3 -> pauseAndPanCam uv
     ScancodeF5 -> doQuicksave uv
     ScancodeF9 -> doQuickload uv
     ScancodeEscape -> pauseGame uv
@@ -152,7 +152,7 @@ doRegexInput u i sss
         any
             ((== Just InitialPress) . (`M.lookup` pkeys))
             [ScancodeReturn, ScancodeSlash]
-    endmouse = maybe False (==1) $ u ^? uvWorld . input . mouseButtons . ix ButtonLeft
+    endmouse = (Just 0 == ) $ u ^? uvWorld . input . mouseButtons . ix ButtonLeft
     backspacetonothing =
         sss ^? sssExtra . sssFilters . ix i . _Just == Just ""
             && ScancodeBackspace `M.lookup` pkeys == Just InitialPress

src/Dodge/Update/Input/ScreenLayer.hs

@@ -60,12 +60,12 @@ mouseClickOptionsList :: ScreenLayer -> Universe -> Universe
 mouseClickOptionsList screen u = fromMaybe u $ do
     sl <- screen ^? scSelectionList
     Just $ case u ^. uvWorld . input . mouseButtons . at ButtonLeft of
-        Just 1 -> fromMaybe u $ do
+        Just 0 -> fromMaybe u $ do
             i <- sl ^. slSelPos
             f <- sl ^? slItems . ix i . siPayload . _1
             return $ f u
         _ -> case u ^. uvWorld . input . mouseButtons . at ButtonRight of
-            Just 1 -> fromMaybe u $ do
+            Just 0 -> fromMaybe u $ do
                 i <- sl ^. slSelPos
                 f <- sl ^? slItems . ix i . siPayload . _2
                 return $ f u

src/Dodge/WASD.hs

@@ -0,0 +1,19 @@
+module Dodge.WASD where
+
+import Data.Foldable
+import qualified Data.Map.Strict as M
+import Dodge.Data.Input
+import Geometry
+import qualified SDL
+
+wasdM :: SDL.Scancode -> Point2
+wasdM scancode = case scancode of
+    SDL.ScancodeW -> V2 0 1
+    SDL.ScancodeS -> V2 0 (-1)
+    SDL.ScancodeD -> V2 1 0
+    SDL.ScancodeA -> V2 (-1) 0
+    _ -> V2 0 0
+
+wasdDir :: Input -> Point2
+{-# INLINE wasdDir #-}
+wasdDir = foldl' (flip $ (+.+) . wasdM) (V2 0 0) . M.keys . _pressedKeys

src/Dodge/WorldEvent/ThingsHit.hs

@@ -104,7 +104,8 @@ crsHitRadial :: Point2 -> Float -> World -> [(Point2, Creature)]
 crsHitRadial p r = mapMaybe f . crsNearCirc p r
   where
     f cr
-        | dist cpos p <= r = Just (cpos +.+ r *.* normalizeV (p -.- cpos), cr)
+        | dist hitpos p <= r = Just (hitpos, cr)
         | otherwise = Nothing
       where
+        hitpos = cpos +.+ r *.* normalizeV (p -.- cpos)
         cpos = _crPos cr

src/Dodge/WorldLoad.hs

@@ -9,7 +9,7 @@ import Shader.Data
 import Shader.Poke.Floor
 
 postUniverseLoadSideEffect :: Universe -> Universe
-postUniverseLoadSideEffect = (uvIOEffects %~ (\f uv -> (uvWorld . cWorld) (postWorldLoad (uv ^. preloadData . renderData)) uv >>= f))
+postUniverseLoadSideEffect = uvIOEffects %~ (\f uv -> (uvWorld . cWorld) (postWorldLoad (uv ^. preloadData . renderData)) uv >>= f)
 
 postWorldLoad :: RenderData -> CWorld -> IO CWorld
 postWorldLoad rdata cw = do

src/Framebuffer/Update.hs

@@ -61,7 +61,6 @@ sizeFBOs cfig rdata =
                 GL_LINEAR
                 GL_RGBA16F
                 [fboHalf1, fboHalf2]
-            >>= resizeShadowFBO' cfig
   where
     updateFBOTO' f =
         uncurry
@@ -149,33 +148,6 @@ updateFBOTO3 xsize ysize minfilt magfilt inFormat1 inFormat2 inFormat3 pdata tar
     newfbo2 <- resizeFBOTO3 (pdata ^# target) xsize ysize minfilt magfilt inFormat1 inFormat2 inFormat3
     return $ storing target newfbo2 pdata
 
-resizeShadowFBO' :: Configuration -> RenderData -> IO RenderData
-resizeShadowFBO' cfig = fboShadow (uncurry resizeShadowFBO (getWindowSize _graphics_world_resolution cfig))
-
--- note we only really "change" the texture objects
-resizeShadowFBO ::
-    Int ->
-    Int ->
-    (FBO, (TO, TO)) ->
-    IO (FBO, (TO, TO))
-resizeShadowFBO x y (fbo, (oldto1, oldto2)) = do
-    glBindFramebuffer GL_FRAMEBUFFER (_unFBO fbo)
-    mglDelete glDeleteTextures $ _unTO oldto1
-    mglDelete glDeleteTextures $ _unTO oldto2
-    to1 <- initializeTexture2DArray fbo GL_COLOR_ATTACHMENT0 x y 20 GL_NEAREST GL_NEAREST GL_RGBA8
-    to2 <-
-        initializeTexture2DArray
-            fbo
-            GL_DEPTH_STENCIL_ATTACHMENT
-            x
-            y
-            20
-            GL_NEAREST
-            GL_NEAREST
-            GL_DEPTH24_STENCIL8
-    checkFBO fbo
-    return (fbo, (TO to1, TO to2))
-
 --resizeFBOTO2 ::
 --    (FBO, (TO, TO)) ->
 --    Int ->
@@ -257,18 +229,6 @@ initializeTexture2D fbo attachpoint x y minfilt magfilt informat = do
     glNamedFramebufferTexture (_unFBO fbo) attachpoint to1 0
     return to1
 
-initializeTexture2DArray :: FBO -> GLenum -> Int -> Int -> Int -> GLenum -> GLenum -> GLenum -> IO GLuint
-initializeTexture2DArray fbo attachpoint x y z minfilt magfilt informat = do
-    let xsize = fromIntegral x
-        ysize = fromIntegral y
-        zsize = fromIntegral z
-    to1 <- mglCreate (glCreateTextures GL_TEXTURE_2D_ARRAY)
-    glTextureStorage3D to1 1 informat xsize ysize zsize
-    glTextureParameteri to1 GL_TEXTURE_MIN_FILTER (unsafeCoerce minfilt)
-    glTextureParameteri to1 GL_TEXTURE_MAG_FILTER (unsafeCoerce magfilt)
-    glNamedFramebufferTexture (_unFBO fbo) attachpoint to1 0
-    return to1
-
 --getWindowSize :: Integral a => (Configuration -> ResFactor) -> Configuration -> (a, a)
 --getWindowSize f cfig = (g _windowX, g _windowY)
  -- where

src/MaybeHelp.hs

@@ -19,6 +19,8 @@ data Maybe' a = Just' {__Just' :: a} | Nothing'
 --
 --instance FromJSON a => FromJSON (Maybe' a)
 
+--maybe' :: b -> (a -> b) -> Maybe' a -> b
+
 fromJust' :: Maybe' a -> a
 fromJust' mx = case mx of
     Just' x -> x

src/Preload/Render.hs

@@ -32,25 +32,6 @@ preloadRender = do
     putStrLn "Number cores available:"
     getNumCapabilities >>= print
 
-    forM_ [0, 1, 2] $ \i -> do
-        putStrLn $ "GL_MAX_COMPUTE_WORK_GROUP_COUNT " ++ show i
-        alloca $ \ptr -> do
-            glGetIntegeri_v GL_MAX_COMPUTE_WORK_GROUP_COUNT i ptr
-            x <- peek ptr
-            putStrLn $ show x
-
-    forM_ [0, 1, 2] $ \i -> do
-        putStrLn $ "GL_MAX_COMPUTE_WORK_GROUP_SIZE " ++ show i
-        alloca $ \ptr -> do
-            glGetIntegeri_v GL_MAX_COMPUTE_WORK_GROUP_SIZE i ptr
-            x <- peek ptr
-            putStrLn $ show x
-    putStrLn $ "GL_MAX_COMPUTE_WORK_GROUP_INVOCATIONS"
-    alloca $ \ptr -> do
-        glGetIntegerv GL_MAX_COMPUTE_WORK_GROUP_INVOCATIONS ptr
-        x <- peek ptr
-        putStrLn $ show x
-
     -- set up uniform buffer object
     putStrLn "Setup UBO"
     theUBO <- mglCreate glCreateBuffers
@@ -95,21 +76,6 @@ preloadRender = do
         makeShaderUsingVAO "lighting/cap" [vert, geom] pmTriangles shPosVAO
     lightingLineShadowShad <-
         makeShaderUsingVAO "lighting/lineShadow" [vert, geom] pmLinesAdjacency shedgevao
-    shadowedgeshader <-
-        makeShaderUsingVAO "shadow/edge" [vert, geom] pmLinesAdjacency shedgevao
-    shadowcapshader <-
-        makeShaderUsingVAO "shadow/cap" [vert, geom] pmTriangles shPosVAO
-    shadowwallshader <-
-        makeShaderUsingVBO "shadow/wallShadow" [vert, geom] (toFloatVAs [4]) pmPoints wallvbo
-    shadowlightshader <-
-        makeStaticShader
-            "shadow/light"
-            [vert, geom, frag]
-            [VertexAttribute 1 GL_BYTE GL_FALSE 0]
-            ([1] :: [GLbyte])
-            pmPoints
-    shadowcombineshader <- makeShaderUsingVAO "shadow/combine" [vert, geom, frag] pmPoints 
-        (shadowlightshader ^. shaderVAO)
 
     putStrLn "Setup 2D shaders"
     bslist <- makeShaderVBO "dualTwoD/basic" [vert, frag] (toFloatVAs [3, 4]) pmTriangles
@@ -118,7 +84,8 @@ preloadRender = do
     cslist <-
         makeShaderVBO "picture/charArray" [vert, frag] (toFloatVAs [3, 4, 4]) pmTriangles
     --    initTexture2DArray 50 "data/texture/charMapVertBig.png" 2 32 64 95 GL_NEAREST_MIPMAP_LINEAR GL_LINEAR
-    initTexture2DArray 50 "data/texture/charMapVert16Block.png" 2 16 32 95 GL_NEAREST GL_NEAREST
+    --initTexture2DArray 50 "data/texture/charMapVert16Block.png" 2 16 32 95 GL_NEAREST GL_NEAREST
+    initTexture2DArray 50 "data/charMaps/charMapVert16Tall.png" 2 16 32 95 GL_NEAREST GL_NEAREST
     --initTexture2DArray 50 "data/texture/charMapVert8Block.png" 2 8 16 95 GL_NEAREST GL_NEAREST
     --initTexture2DArray 50 "data/texture/charMapVertBig.png" 2 32 64 95 GL_LINEAR_MIPMAP_LINEAR GL_LINEAR
     --initTexture2DArray 50 "data/texture/charMapVertBig.png" 2 32 64 95 GL_LINEAR_MIPMAP_NEAREST GL_LINEAR
@@ -163,8 +130,6 @@ preloadRender = do
     fboPosName <- setupFramebufferGivenStencil rboBaseBloomName
     fboLightingName <- setupFramebufferGivenStencil rboBaseBloomName
 
-    fboShadowName <- setupShadowFramebuffer
-
     fboHalf1Name <- newTextureFramebuffer
     fboHalf2Name <- newTextureFramebuffer
 
@@ -181,26 +146,17 @@ preloadRender = do
         , eslist
         ]
 
-    -- setup compute shader
-    computeshadowshader <- makeSourcedShader "compute/shadow" [GL_COMPUTE_SHADER]
-
     initializeGLState
     putStrLn "Return preload"
     return $
         RenderData
-            { _computeShadowShader = computeshadowshader
-            , _pictureShaders = shadV
+            { _pictureShaders = shadV
             , _shapeShader = shapeshader -- & shaderVAO' .~ shPosColVAO
             , _shapeEBO = shEBO
             , _silhouetteEBO = shedgeebo
             , _lightingCapShader = lightingCapShad
             , _lightingLineShadowShader = lightingLineShadowShad
             , _lightingWallShadShader = lightingWallShadShad
-            , _shadowEdgeShader = shadowedgeshader
-            , _shadowCapShader = shadowcapshader
-            , _shadowWallShader = shadowwallshader
-            , _shadowLightShader = shadowlightshader
-            , _shadowCombineShader = shadowcombineshader
             , _windowShader = windowshader
             , _fullscreenShader = fsShad
             , _alphaDivideShader = alphadivideshader
@@ -214,15 +170,14 @@ preloadRender = do
             , _fboHalf1 = fboHalf1Name
             , _fboHalf2 = fboHalf2Name
             , _fboLighting = fboLightingName
-            , _fboShadow = fboShadowName
+--            , _fboShadow = fboShadowName
             , _fboBase = fboBaseName
             , _fboCloud = fboCloudName
             , _fboBloom = fboBloomName
             , _fboPos = fboPosName
             , _rboBaseBloom = rboBaseBloomName
             , _matUBO = theUBO
-            , --            , _orthonormalMatUBO = orthonormalUBO
-              _lightsUBO = lightsubo
+            , _lightsUBO = lightsubo
             , _vboWindows = winvbo
             , _vboShapes = shVBO
             , _floorVBO = floorvbo

src/Render.hs

@@ -6,14 +6,12 @@ module Render (
 ) where
 
 import Control.Lens
-import Control.Monad
 import Control.Monad.Primitive
 import Data.Preload.Render
 import qualified Data.Vector.Fusion.Stream.Monadic as VFSM
 import qualified Data.Vector.Mutable as MV
 import qualified Data.Vector.Unboxed.Mutable as UMV
 import Dodge.Data.Config
-import Dodge.WindowSize
 import Foreign hiding (rotate)
 import Geometry.Data
 import Graphics.GL.Core45
@@ -41,10 +39,8 @@ createLightMap ::
     RenderData ->
     IO ()
 createLightMap cfig = case shadrendertype of
-    InstancingShads -> instanceLightMap cfig
     NoShadows -> const . const . const renderLightingNoShadows
     NoLighting -> const . const . const . const . const . const renderFlatLighting
-    ComputeShader -> renderComputeShadows
     _ -> renderShadows shadrendertype
   where
     shadrendertype = cfig ^. graphics_shadow_rendering
@@ -104,27 +100,6 @@ renderLightingNoShadows positiontexture normaltexture lightPoints pdata = do
     glDisable GL_CULL_FACE
     glDisable GL_STENCIL_TEST
 
-renderComputeShadows ::
-    GLsizei ->
-    Int ->
-    Int ->
-    TO ->
-    TO ->
-    [(Point3, Float, Point3)] ->
-    RenderData ->
-    IO ()
-renderComputeShadows _ _ _ toPos tanormals lightPoints rd = do
-    withArray (lightsToArray lightPoints) $ \ptr ->
-        glNamedBufferSubData (rd ^. lightsUBO) 0 620 ptr
-    glBindTextureUnit 0 (toPos ^. unTO)
-    glBindTextureUnit 1 (tanormals ^. unTO)
-    glBindImageTexture 5 (rd ^. fboLighting . _2 . unTO) 0 GL_FALSE 0 GL_WRITE_ONLY GL_RGBA8
-    glUseProgram (rd ^. computeShadowShader)
-    glDispatchCompute 800 835 1
-    -- the following should be later, just before the texture is accessed
-    --glMemoryBarrier GL_SHADER_IMAGE_ACCESS_BARRIER_BIT
-    glMemoryBarrier GL_TEXTURE_FETCH_BARRIER_BIT
-    return ()
 
 renderFlatLighting :: RenderData -> IO ()
 renderFlatLighting pdata = do
@@ -241,136 +216,6 @@ renderShadows shadrendertype nWalls nSils nCaps positiontexture normaltexture li
     glDisable GL_STENCIL_TEST
     glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE
 
-lightsToArray :: [(Point3, Float, Point3)] -> [Float]
-lightsToArray xs =
-    concat (take 20 $ map t xs ++ repeat [0, 0, 0, 0])
-        ++ concat (take 20 $ map s xs ++ repeat [0, 0, 0, 0])
-  where
-    t (V3 a b c, _, _) = [a, b, c, 1]
-    s (_, d, V3 e f g) = [e, f, g, d]
-
-instanceLightMap ::
-    Configuration ->
-    -- | number of walls
-    GLsizei ->
-    -- | number of silhoutte lines to draw
-    Int ->
-    -- | number of "caps" to attempt to draw
-    Int ->
-    -- | the texture object giving positions
-    TO ->
-    TO ->
-    [(Point3, Float, Point3)] -> -- Lights
-    RenderData ->
-    IO ()
-instanceLightMap cfig nWalls nSils nCaps toPos tanormals lightPoints pdata = do
-    let lcapShad = _shadowCapShader pdata
-        (xsize, ysize) = getWindowSize _graphics_world_resolution cfig
-    withArray (lightsToArray lightPoints) $ \ptr ->
-        glNamedBufferSubData (pdata ^. lightsUBO) 0 620 ptr
-    forM_ [0 .. 19] $ \i ->
-        glCopyImageSubData
-            (pdata ^. rboBaseBloom)
-            GL_RENDERBUFFER
-            0
-            0
-            0
-            0
-            (pdata ^. fboShadow . _2 . _2 . unTO)
-            GL_TEXTURE_2D_ARRAY
-            0
-            0
-            0
-            i
-            xsize
-            ysize
-            1
-    glBindFramebuffer GL_FRAMEBUFFER $ pdata ^. fboShadow . _1 . unFBO
-    glDepthMask GL_FALSE
-    withArray [0, 0, 0, 0] $ \ptr ->
-        glClearNamedFramebufferfv
-            (pdata ^. fboShadow . _1 . unFBO)
-            GL_COLOR
-            0
-            ptr
-    with 0 $ \ptr ->
-        glClearNamedFramebufferiv
-            (pdata ^. fboShadow . _1 . unFBO)
-            GL_STENCIL
-            0
-            ptr
-    -- stencil out the shadows from each light's point of view
-    -- setup stencil
-    glEnable GL_STENCIL_TEST
-    glStencilOpSeparate GL_FRONT GL_KEEP GL_KEEP GL_INCR_WRAP
-    glStencilOpSeparate GL_BACK GL_KEEP GL_KEEP GL_DECR_WRAP
-    glDepthFunc GL_LESS
-    glColorMask GL_FALSE GL_FALSE GL_FALSE GL_FALSE
-    glDisable GL_BLEND
-    glDisable GL_CULL_FACE
-    glStencilFunc GL_ALWAYS 0 255
-    --draw wall shadows
-    glUseProgram $ pdata ^. shadowWallShader . shaderUINT
-    glBindVertexArray $ pdata ^. shadowWallShader . shaderVAO . vaoName
-    glDrawArrays
-        (_unPrimitiveMode $ pdata ^. shadowWallShader . shaderPrimitive)
-        0
-        nWalls
-    --draw silhouette shadows
-    glUseProgram $ pdata ^. shadowEdgeShader . shaderUINT
-    glBindVertexArray $ pdata ^. shadowEdgeShader . shaderVAO . vaoName
-    glDrawElements
-        (_unPrimitiveMode $ pdata ^. shadowEdgeShader . shaderPrimitive)
-        (fromIntegral nSils)
-        GL_UNSIGNED_SHORT
-        nullPtr
-    --draw caps on the near plane as required
-    glEnable GL_CULL_FACE
-    glCullFace GL_BACK
-    --glCullFace GL_FRONT
-    glUseProgram (_shaderUINT lcapShad)
-    glBindVertexArray $ lcapShad ^. shaderVAO . vaoName
-    glDrawElements
-        (_unPrimitiveMode $ _shaderPrimitive lcapShad)
-        (fromIntegral nCaps)
-        GL_UNSIGNED_SHORT
-        nullPtr
-    --draw lightmap itself
-    glDepthFunc GL_ALWAYS
-    glColorMask GL_TRUE GL_TRUE GL_TRUE GL_TRUE
-    glStencilFunc GL_EQUAL 0 255
-    glUseProgram (pdata ^. shadowLightShader . shaderUINT)
-    -- bind world position texture
-    glBindTextureUnit 0 (toPos ^. unTO)
-    glBindTextureUnit 1 (tanormals ^. unTO)
-    glDrawArrays
-        (_unPrimitiveMode $ pdata ^. shadowLightShader . shaderPrimitive)
-        0
-        1
-    glDisable GL_CULL_FACE
-    glDisable GL_STENCIL_TEST
-    --draw to the lighting framebuffer here
-    glBindFramebuffer GL_FRAMEBUFFER (_unFBO (fst (_fboLighting pdata)))
-    withArray [1, 1, 1, 1] $ \ptr ->
-        glClearNamedFramebufferfv
-            (pdata ^. fboLighting . _1 . unFBO)
-            GL_COLOR
-            0
-            ptr
-    glBindTextureUnit 0 (pdata ^. fboShadow . _2 . _1 . unTO)
-    glEnable GL_BLEND
-    glBlendFunc GL_ZERO GL_ONE_MINUS_SRC_COLOR
-    glUseProgram (pdata ^. shadowCombineShader . shaderUINT)
-    glDrawArrays
-        GL_POINTS
-        0
-        1
-    withArray [GL_COLOR_ATTACHMENT0, GL_DEPTH_STENCIL_ATTACHMENT] $ \ptr ->
-        glInvalidateNamedFramebufferData
-            (pdata ^. fboShadow . _1 . unFBO)
-            2
-            ptr
-
 -- assumes that vertices have already been sent to the shader
 pingPongBetween ::
     (FBO, TO) ->

src/Shader/Compile.hs

@@ -46,7 +46,7 @@ makeShaderVBO ::
     IO (Shader, VBO)
 makeShaderVBO s shaderlist sizes pm = do
     prog <- makeSourcedShader s shaderlist
-    (vao, vbo) <- setupVBOVAO (sizes)
+    (vao, vbo) <- setupVBOVAO sizes
     return
         ( Shader
             { _shaderUINT = prog

src/Shader/Poke.hs

@@ -277,7 +277,7 @@ boxSurfaces size =
 
 memoBoxSurfaces :: V.Vector [[Int]]
 {-# INLINE memoBoxSurfaces #-}
-memoBoxSurfaces = V.generate 10 $ boxSurfaces
+memoBoxSurfaces = V.generate 10 boxSurfaces
 
 boxSurfacesIndices :: Int -> [[Int]]
 {-# INLINE boxSurfacesIndices #-}