diff --git a/src/Dodge/Creature/Impulse/Movement.hs b/src/Dodge/Creature/Impulse/Movement.hs index 16c7770a4..caf7d59da 100644 --- a/src/Dodge/Creature/Impulse/Movement.hs +++ b/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 - | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed - = cr & crDir .~ dirToTarget - | isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) = cr & crDir +~ turnSpeed - | otherwise = cr & crDir -~ turnSpeed + | normalizeAngle (abs (a - cdir)) <= turnSpeed + = cr & crDir .~ dirToTarget + | isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) + = cr & crDir +~ turnSpeed + | otherwise = cr & crDir -~ turnSpeed where + cdir = _crDir cr vToTarg = rotateV a (V2 1 0) dirToTarget = argV vToTarg diff --git a/src/Dodge/Creature/State.hs b/src/Dodge/Creature/State.hs index a4d307c45..03ed1a233 100644 --- a/src/Dodge/Creature/State.hs +++ b/src/Dodge/Creature/State.hs @@ -100,19 +100,17 @@ bpVector = V.fromList $ 0 : [0 .. 18] movementSideEff :: Creature -> World -> World movementSideEff cr w - | hasJetPack - = case cr ^? crStance . carriage of - Just (Boosting v) - -> makeFlameletTimed - (oldPos +.+ (_crRad cr + 3) *.* unitVectorAtAngle (_crDir cr + pi)) - 20 - (momentum +.+ 1 *.* rotateV randDir (vInverse v)) - Nothing - 1 - 20 - $ set randGen g - w - _ -> w + | hasJetPack = case cr ^? crStance . carriage of + Just (Boosting v) + -> makeFlameletTimed + (oldPos +.+ (_crRad cr + 3) *.* unitVectorAtAngle (_crDir cr + pi)) + 20 + (momentum +.+ 1 *.* rotateV randDir (vInverse v)) + Nothing + 1 + 20 + $ set randGen g 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 --- | crIsAiming' cr = cr --- | otherwise - = over (crInv . ix iSel . wpReloadState) decreaseToZero cr +stepReloading cr = over (crInv . ix iSel . wpReloadState) decreaseToZero cr where iSel = _crInvSel cr diff --git a/src/Dodge/Creature/YourControl.hs b/src/Dodge/Creature/YourControl.hs index b1b597a9d..7982703a2 100644 --- a/src/Dodge/Creature/YourControl.hs +++ b/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 diff --git a/src/Dodge/Item/Weapon/Bezier.hs b/src/Dodge/Item/Weapon/Bezier.hs index f1447915e..c118582a4 100644 --- a/src/Dodge/Item/Weapon/Bezier.hs +++ b/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 - , _itEquipPict = pictureWeaponOnAim $ (,) emptySH bezierGunPic + , _itFloorPict = bezierGunSPic + , _itEquipPict = pictureWeaponOnAim bezierGunSPic , _itAttachment = NoItAttachment , _itScroll = \_ _ -> removeItTarget , _itHammer = HammerUp @@ -49,8 +47,11 @@ bezierGun = defaultGun , _itUseRate = 6 , _itAimStance = TwoHandTwist } -bezierGunPic :: Picture -bezierGunPic = color red $ polygon $ rectNESW 4 12 (-4) (-12) +bezierGunSPic :: SPic +bezierGunSPic = + ( colorSH red $ upperPrismPoly 5 $ rectNESW 4 12 (-4) (-12) + , mempty + ) shootBezier :: Point2 -> Creature -> World -> World shootBezier targetp cr w = w & particles %~ (theBullet :) diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index c7de871e0..4e2401bfc 100644 --- a/src/Dodge/Render.hs +++ b/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 - layerCounts <- UMV.replicate (6*6) 0 - pokeBindFoldableLayer shadV layerCounts $ worldPictures w + --draw object pictures onto base buffer 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] diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index 96d9cd60b..75a1fec56 100644 --- a/src/Dodge/Render/HUD.hs +++ b/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 -{-# INLINE renderItemMapAt #-} -renderItemMapAt tx ty scols w = - --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 - +renderItemMapAt :: Float -> Float -> World -> IM.IntMap Item -> Picture +--{-# INLINE renderItemMapAt #-} +renderItemMapAt tx ty w = concatMapPic (uncurry $ listItemAt tx ty w) . IM.toList 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' #-} -listItemAt' xoff yoff w yint item = winScale w . translate (xoff + 15 - halfWidth w) (yoff + halfHeight w - (20 * (fromIntegral yint+1))) +--{-# INLINE listItemAt #-} +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 diff --git a/src/Dodge/Render/List.hs b/src/Dodge/Render/List.hs index 75e1a3e37..10ac06870 100644 --- a/src/Dodge/Render/List.hs +++ b/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 diff --git a/src/Geometry/Vector.hs b/src/Geometry/Vector.hs index 0dfb4c58d..ead9e63dc 100644 --- a/src/Geometry/Vector.hs +++ b/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 diff --git a/src/Picture.hs b/src/Picture.hs index 08f54d1bf..7ee0f1baa 100644 --- a/src/Picture.hs +++ 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 diff --git a/src/Render.hs b/src/Render.hs index 4f5363fab..ec6e9df49 100644 --- a/src/Render.hs +++ b/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 $ _lightingLineShadowShader pdata) + currentProgram $= Just (_shadProg llsShad) uniform (head $ _shadUnis $ _lightingLineShadowShader pdata) $= Vector3 x y z - -- drawShader (_lightingLineShadowShader pdata) nSils - bindVertexArrayObject $= Just (_vao $ _shadVAO llss) + bindVertexArrayObject $= Just (_vao $ _shadVAO llsShad) 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) - uniform (head $ _shadUnis $ _lightingCapShader pdata) + currentProgram $= Just (_shadProg $ lcShad) + uniform (head $ _shadUnis $ lcShad) $= Vector3 x y z - -- TODO clean this up - let fs = _lightingCapShader pdata - bindVertexArrayObject $= Just (_vao $ _shadVAO fs) + bindVertexArrayObject $= Just (_vao $ _shadVAO lcShad) 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)