Fix direction stuttering bug

src/Dodge/Creature/Impulse/Movement.hs

@@ -76,18 +76,21 @@ creatureTurnTo p cr
     vToTarg = p -.- _crPos cr
     dirToTarget = argV vToTarg
 
+-- the following is perhaps not ideal because it mixes normalizeAngle with
+-- angleVV, but it seems to work
 creatureTurnTowardDir 
     :: Float -- ^ Angle
     -> Float -- ^ Turn speed
     -> Creature
     -> Creature
 creatureTurnTowardDir a turnSpeed cr 
-    | vToTarg == V2 0 0 = cr -- this should deal with the angleVV error
+    | normalizeAngle (abs (a - cdir)) <= turnSpeed
-    | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
+                = cr & crDir .~ dirToTarget
-                                        = cr & crDir .~ dirToTarget
+    | isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) 
-    | isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) = cr & crDir +~ turnSpeed
+                = cr & crDir +~ turnSpeed
-    | otherwise                         = cr & crDir -~ turnSpeed
+    | otherwise = cr & crDir -~ turnSpeed
   where
+    cdir = _crDir cr
     vToTarg = rotateV a (V2 1 0)
     dirToTarget = argV vToTarg
 

src/Dodge/Creature/State.hs

@@ -100,19 +100,17 @@ bpVector = V.fromList $ 0 : [0 .. 18]
 
 movementSideEff :: Creature -> World -> World
 movementSideEff cr w
-    | hasJetPack 
+    | hasJetPack = case cr ^? crStance . carriage of
-        = case cr ^? crStance . carriage of
+        Just (Boosting v) 
-            Just (Boosting v) 
+            -> makeFlameletTimed 
-                -> makeFlameletTimed 
+                        (oldPos +.+ (_crRad cr + 3) *.* unitVectorAtAngle (_crDir cr + pi))
-                            (oldPos +.+ (_crRad cr + 3) *.* unitVectorAtAngle (_crDir cr + pi))
+                        20
-                            20
+                        (momentum +.+ 1 *.* rotateV randDir (vInverse v)) 
-                            (momentum +.+ 1 *.* rotateV randDir (vInverse v)) 
+                        Nothing
-                            Nothing
+                        1
-                            1
+                        20
-                            20
+                $ set randGen g w
-                    $ set randGen g
+        _   -> w
-                        w
-            _   -> w
     | otherwise = footstepSideEffect cr w
   where 
     hasJetPack = any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr
@@ -124,9 +122,6 @@ movementSideEff cr w
     (randDir,g) = randomR (-0.5,0.5) $ _randGen w
     (randAng,_) = randomR (0,2*pi) $ _randGen w
 
-    --crHasMoved = dist (_crPos cr) (_crOldPos cr) > 0.5
-
-
 invSideEff :: Creature -> World -> World
 invSideEff cr w = weaponReloadSounds cr $ IM.foldrWithKey f w (_crInv cr)
   where 
@@ -165,15 +160,11 @@ isFrictionless cr = case cr ^? crStance . carriage of
 stepItemUseCooldown :: Creature -> Creature
 stepItemUseCooldown cr = cr & crInv . ix iSel %~
     (itUseTime %~ decreaseToZero) . (wpCurWarmUp %~ decreaseToZero)
-    --( over (crInv . ix iSel . itUseTime) decreaseToZero cr
   where 
     iSel = _crInvSel cr 
 
 stepReloading :: Creature -> Creature
-stepReloading cr 
+stepReloading cr = over (crInv . ix iSel . wpReloadState) decreaseToZero cr
---    | crIsAiming' cr = cr
---    | otherwise     
-        = over (crInv . ix iSel . wpReloadState) decreaseToZero cr
   where 
     iSel = _crInvSel cr 
 

src/Dodge/Creature/YourControl.hs

@@ -38,7 +38,7 @@ wasdWithAiming
     -> Creature
 wasdWithAiming w speed i cr
     | isAiming  = set crDir mouseDir $ theMovement cr
-    | otherwise = theTurn $ theMovement cr
+    | otherwise = theMovement $ theTurn cr
   where 
     theMovement
         | movDir == V2 0 0 = id

src/Dodge/Item/Weapon/Bezier.hs

@@ -14,14 +14,12 @@ import Dodge.Particle.Bullet.Spawn
 import Dodge.Particle.Bullet.HitEffect
 import Dodge.WorldEvent.HitEffect
 import Dodge.RandomHelp
-import Dodge.Picture.Layer
 import Dodge.SoundLogic.LoadSound
 import Picture
 import Geometry
---import ShapePicture
+import ShapePicture
 import Shape
 
---import System.Random
 import Data.Maybe
 import Control.Lens
 import Control.Monad.State
@@ -37,8 +35,8 @@ bezierGun = defaultGun
         . withRecoilI 40
         . torqueBefore 0.05
         ]
-    , _itFloorPict = (,) emptySH $ onLayer FlItLayer bezierGunPic
+    , _itFloorPict = bezierGunSPic
-    , _itEquipPict = pictureWeaponOnAim $ (,) emptySH bezierGunPic
+    , _itEquipPict = pictureWeaponOnAim bezierGunSPic
     , _itAttachment = NoItAttachment
     , _itScroll   = \_ _ -> removeItTarget
     , _itHammer = HammerUp
@@ -49,8 +47,11 @@ bezierGun = defaultGun
     , _itUseRate = 6
     , _itAimStance = TwoHandTwist
     }
-bezierGunPic :: Picture
+bezierGunSPic :: SPic
-bezierGunPic = color red $ polygon $ rectNESW 4 12 (-4) (-12)
+bezierGunSPic = 
+    ( colorSH red $ upperPrismPoly 5 $ rectNESW 4 12 (-4) (-12)
+    , mempty
+    )
 
 shootBezier :: Point2 -> Creature -> World -> World
 shootBezier targetp cr w = w & particles %~ (theBullet :)

src/Dodge/Render.hs

@@ -42,6 +42,9 @@ doDrawing pdata w = do
         viewFrom3d = Vector3 vfx vfy 20
         shadV = _pictureShaders pdata
     -- bind as much data into vbos as feasible at this point
+    -- pictures
+    layerCounts <- UMV.replicate (6*6) 0
+    pokeBindFoldableLayer shadV layerCounts $ worldPictures w
     -- poke wall points and colors
     nWalls <- poke224s (shadVBOptr $ _wallTextureShader pdata) wallPointsCol
     (nShapeVs,nIndices,nSilIndices) <- pokeShape
@@ -83,11 +86,9 @@ doDrawing pdata w = do
     if w ^. config . wall_textured
         then renderTextureWalls pdata nWalls
         else renderBlankWalls pdata nWalls
-    --draw objects onto base buffer
+    --draw object pictures onto base buffer
-    layerCounts <- UMV.replicate (6*6) 0
-    pokeBindFoldableLayer shadV layerCounts $ worldPictures w
     renderLayer 0 shadV layerCounts
-
+    --draw object shpaes onto base buffer
     let fs = _shapeShader pdata
     currentProgram $= Just (_shadProg fs)
     bindVertexArrayObject $= Just (_vao $ _shadVAO fs)
@@ -96,15 +97,13 @@ doDrawing pdata w = do
         (fromIntegral nIndices)
         GL_UNSIGNED_SHORT
         nullPtr
-
     --draw floor onto base buffer
     nTextArrayVs <- pokePoint33s (shadVBOptr $ _textureArrayShader pdata) (_floorTiles w)
     bindShaderBuffers [_textureArrayShader pdata] [nTextArrayVs]
     drawShader (_textureArrayShader pdata) nTextArrayVs
-    --draw lightmap for base buffer
+    --draw lightmap into its own buffer
     bindFramebuffer Framebuffer $= fst (_fboLighting pdata)
     createLightMap pdata lightPoints nWalls nSilIndices nIndices (snd $ snd $ _fboBase pdata)
-    --createLightMap pdata lightPoints nWalls 0 0 (snd $ snd $ _fboBase pdata)
     colorMask $= Color4 Enabled Enabled Enabled Enabled
     clearColor $= Color4 0 0 0 0
     --apply lightmap to base buffer
@@ -113,7 +112,6 @@ doDrawing pdata w = do
     blend $= Enabled
     blendFunc $= (Zero, OneMinusSrcColor)
     drawShader (_fullscreenShader pdata) 4
-    blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
     --draw bloom onto bloom buffer
     bindFramebuffer Framebuffer $= fst (_fboBloom pdata)
     clear [ColorBuffer]

src/Dodge/Render/HUD.hs

@@ -103,27 +103,15 @@ displayMidList w strs s =
 invHead :: World -> String -> Picture
 invHead w s = winScale w . translate (-130) (halfHeight w - 40) . dShadCol white . scale 0.4 0.4 $ text s
 
-renderItemMapAt :: Float -> Float -> IM.IntMap Item -> World -> Picture
+renderItemMapAt :: Float -> Float -> World -> IM.IntMap Item -> Picture
-{-# INLINE renderItemMapAt #-}
+--{-# INLINE renderItemMapAt #-}
-renderItemMapAt tx ty scols w =
+renderItemMapAt tx ty w = concatMapPic (uncurry $ listItemAt tx ty w) . IM.toList
-    --concatMapPic (winScale w) $ IM.mapWithKey (listItemAt tx ty w) scols
-    --concatMapPic (winScale w . uncurry (listItemAt tx ty w)) $ IM.toList scols
-    concatMapPic (uncurry $ listItemAt' tx ty w) $ IM.toList scols
-
---renderPairListAt :: Float -> Float -> [(Int,(String,Color))] -> World -> Picture
---renderPairListAt tx ty scols w =
---    concatMapPic (winScale w) $ map (uncurry $ listPairAt tx ty w) scols
-
 
 displayInv :: Int -> World -> Picture
-displayInv n w = renderItemMapAt 0 0 items w
+displayInv n w = renderItemMapAt 0 0 w items
   where 
     items = _crInv $ _creatures w IM.! n
 
---itemStringCol :: Item -> (String,Color)
---itemStringCol NoItem    = ("----", greyN 0.5)
---itemStringCol itm       = (_itInvDisplay itm itm, _itInvColor itm)
-
 drawLocations :: World -> Picture
 drawLocations w = pictures $ 
     renderListAt 0 0 w locs
@@ -192,33 +180,27 @@ closeObjectTexts w = pictures $
 mainListCursor :: Color -> Int -> World -> Picture
 mainListCursor c = openCursorAt 120 c 5 0
 
-listItemAt'
+listItemAt
     :: Float    -- ^ x offset
     -> Float    -- ^ y offset
     -> World 
     -> Int      -- ^ y offset (discrete)
     -> Item   -- ^ The item
     -> Picture
-{-# INLINE listItemAt' #-}
+--{-# INLINE listItemAt #-}
-listItemAt' xoff yoff w yint item = winScale w . translate (xoff + 15 - halfWidth w) (yoff + halfHeight w - (20 * (fromIntegral yint+1)))
+listItemAt xoff yoff w yint item 
+    = winScale w 
+    . translate (xoff + 15 - hw) (yoff + hh - (20 * (fromIntegral yint+1)))
     . scale 0.1 0.1
     . dShadCol col
     $ text s
   where
+    hw = halfWidth w
+    hh = halfHeight w
     (s,col) = case item of 
         NoItem -> ("----", greyN 0.5)
         _       -> (_itInvDisplay item item , _itInvColor item)
 
---listItemAt
---    :: Float    -- ^ x offset
---    -> Float    -- ^ y offset
---    -> World 
---    -> Int      -- ^ y offset (discrete)
---    -> Item   -- ^ The item
---    -> Picture
---{-# INLINE listItemAt #-}
---listItemAt xoff yoff w yint = listPairAt xoff yoff w yint . itemStringCol
-
 openCursorAt 
     :: Float    -- ^ Width
     -> Color

src/Dodge/Render/List.hs

@@ -23,6 +23,7 @@ listPairAt xoff yoff w yint (s,col)
     $ text s
 {- | Colour picture and add black drop shadow. -}
 dShadCol :: Color -> Picture -> Picture
+{-# INLINE dShadCol #-}
 dShadCol c p = pictures
     [ color black $ translate 1.2 (-1.2) p
     , color c p

src/Geometry/Vector.hs

@@ -43,6 +43,8 @@ normalizeV :: Point2 -> Point2
 normalizeV p = (1 / magV p) *.* p
 
 {- | Angle between two vectors.  Always positive.  -}
+-- TODO fix this: it seems to be unstable when the two vectors are very close to
+-- each other
 angleVV :: Point2 -> Point2 -> Float
 {-# INLINE angleVV #-}
 angleVV a b 

src/Picture.hs

@@ -180,7 +180,6 @@ scale3 a b (V3 x y z) = V3 (x*a) (y*b) z
 
 scale :: Float -> Float -> Picture -> Picture
 {-# INLINE scale #-}
---scale x y = map . second . overPos $ scale3 x y
 scale x = map . overPos . scale3 x
 
 rotate :: Float -> Picture -> Picture
@@ -330,7 +329,6 @@ overCol f vx = vx {_vxCol = f (_vxCol vx)}
 -- no premature optimisation, consider changing to use texture arrays
 stringToList :: String -> [(Point3,Point4,Point2)]
 {-# INLINE stringToList #-}
---stringToList s = concat $ zipWith charToTuple [0,0.9*dimText ..] s
 stringToList s = concatMap (uncurry charToTuple) $ zip [0,0.9*dimText ..] s
   where
     dimText = 100

src/Render.hs

@@ -11,15 +11,12 @@ module Render
 import Shader
 import Shader.ExtraPrimitive
 import Shader.Data
---import Shader.Poke
 import Data.Preload.Render
 import Picture.Data
 import Geometry.Data
 
---import Data.Foldable
 import Foreign hiding (rotate)
 import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,Polygon,Color,T)
---import qualified SDL
 import qualified Data.Vector.Unboxed.Mutable as UMV
 import qualified Data.Vector.Mutable as MV
 import Control.Monad.Primitive
@@ -29,9 +26,6 @@ import Graphics.GL.Core43
 divideSize :: Int -> Size -> Size
 divideSize i (Size x y) = Size (div x $ fromIntegral i) (div y $ fromIntegral i)
 
---sizeToTexSize :: Size -> TextureSize2D
---sizeToTexSize (Size x y) = TextureSize2D x y
-
 {- | Determine where light is shining in the world.  -}
 createLightMap 
     :: RenderData 
@@ -42,6 +36,8 @@ createLightMap
     -> TextureObject -- ^ the texture object giving positions
     -> IO ()
 createLightMap pdata lightPoints nWalls nSils nCaps toPos = do
+    let llsShad = _lightingLineShadowShader pdata
+    let lcShad  = _lightingCapShader pdata
     -- we assume that the renderbuffer's depth has been correctly set elsewhere
     -- we will not be changing that here
     depthMask $= Disabled
@@ -68,35 +64,29 @@ createLightMap pdata lightPoints nWalls nSils nCaps toPos = do
             $= Vector3 x y z
         drawShader (_lightingOccludeShader pdata) nWalls
         --draw silhouette shadows
-        let llss = _lightingLineShadowShader pdata
+        currentProgram $= Just (_shadProg llsShad)
-        currentProgram $= Just (_shadProg $ _lightingLineShadowShader pdata)
         uniform (head $  _shadUnis $ _lightingLineShadowShader pdata)
             $= Vector3 x y z
-    --    drawShader (_lightingLineShadowShader pdata) nSils
+        bindVertexArrayObject $= Just (_vao $ _shadVAO llsShad)
-        bindVertexArrayObject $= Just (_vao $ _shadVAO llss)
         glDrawElements
-            (marshalEPrimitiveMode $ _shadPrim llss) 
+            (marshalEPrimitiveMode $ _shadPrim llsShad) 
             (fromIntegral nSils)
             GL_UNSIGNED_SHORT
             nullPtr
         cullFace $= Just Back
-
         --draw caps on the near plane as required
-        currentProgram $= Just (_shadProg $ _lightingCapShader pdata)
+        currentProgram $= Just (_shadProg $ lcShad)
-        uniform (head $  _shadUnis $ _lightingCapShader pdata)
+        uniform (head $  _shadUnis $ lcShad)
             $= Vector3 x y z
-        -- TODO clean this up
+        bindVertexArrayObject $= Just (_vao $ _shadVAO lcShad)
-        let fs = _lightingCapShader pdata
-        bindVertexArrayObject $= Just (_vao $ _shadVAO fs)
         glDrawElements
-            (marshalEPrimitiveMode $ _shadPrim fs) 
+            (marshalEPrimitiveMode $ _shadPrim lcShad) 
             (fromIntegral nCaps)
             GL_UNSIGNED_SHORT
             nullPtr
-        --drawShader (_lightingCapShader pdata) nCaps
         --draw lightmap itself
         depthFunc $= Just Always
-        --cullFace $= Nothing
+        -- bind world position texture
         bindTO toPos
         colorMask $= Color4 Enabled Enabled Enabled Enabled
         stencilOp $= (OpKeep,OpKeep,OpKeep)