From 4a455cc7c9566cec2560c8867337fcb65ba6705a Mon Sep 17 00:00:00 2001 From: jgk Date: Wed, 10 Mar 2021 19:44:59 +0100 Subject: [PATCH] First pass deletion, increases perfomance significantly --- src/Dodge/Inventory.hs | 105 +++++++++++++++++++++++++++++++++++++++++ src/Picture/Preload.hs | 83 +++----------------------------- src/Picture/Render.hs | 83 +++----------------------------- 3 files changed, 117 insertions(+), 154 deletions(-) create mode 100644 src/Dodge/Inventory.hs diff --git a/src/Dodge/Inventory.hs b/src/Dodge/Inventory.hs new file mode 100644 index 000000000..8bdc67d66 --- /dev/null +++ b/src/Dodge/Inventory.hs @@ -0,0 +1,105 @@ +module Dodge.Inventory + where +import Dodge.Data +import Dodge.Base +--import Dodge.SoundLogic + +import Geometry + +import Data.Maybe +import Data.List +import Data.Function (on) +import qualified Data.IntMap.Strict as IM + +import System.Random + +import Control.Lens + +checkInvSlotsYou' :: Maybe Item -> World -> Maybe Int +checkInvSlotsYou' it w = fmap fst $ find cond invListSelFirst + where cond (_,NoItem) = True + cond (_,it' ) = itNotFull it' && fmap _itName it == Just (_itName it') + youCr = you w + youSel = _crInvSel youCr + invList = _crInv youCr + invListSelFirst = (youSel , invList IM.! youSel) : IM.toList invList + +checkInvSlotsYou :: Item -> World -> Maybe Int +checkInvSlotsYou it w = fmap fst $ find cond invListSelFirst + where cond (_,NoItem) = True + cond (_,it' ) = itNotFull it' && _itName it == _itName it' + youCr = you w + youSel = _crInvSel youCr + invList = _crInv youCr + invListSelFirst = (youSel , invList IM.! youSel) : IM.toList invList + +checkInvSlots :: Item -> IM.IntMap Item -> Maybe Int +checkInvSlots it its = fmap fst $ find cond $ IM.toList its + where cond (_,NoItem) = True + cond (_,it' ) = itNotFull it' && _itName it == _itName it' + +addItem :: Item -> Item -> Item +addItem it NoItem = it +addItem it it' = it' & itAmount +~ 1 + +numInventorySlots :: Int +numInventorySlots = 9 + +itNotFull :: Item -> Bool +itNotFull it = _itMaxStack it > _itAmount it + +rmInvItem :: Int -> World -> World +rmInvItem n w = + let i = _crInvSel (_creatures w IM.! n) + item = _crInv (_creatures w IM.! n) IM.! i + itRef = creatures . ix n . crInv . ix i + in case item of + Consumable {_itAmount = 1} -> set itRef NoItem w + Craftable {_itAmount = 1} -> set itRef NoItem w + Equipment {_itAmount = 1} -> set itRef NoItem w + Throwable {_itAmount = 1} -> set itRef NoItem w + Consumable {_itAmount = x} -> over (itRef . itAmount) (\y-> y-1) w + Craftable {_itAmount = x} -> over (itRef . itAmount) (\y-> y-1) w + Equipment {_itAmount = x} -> over (itRef . itAmount) (\y-> y-1) w + Throwable {_itAmount = x} -> over (itRef . itAmount) (\y-> y-1) w + _ -> set itRef NoItem w + +-- for now, left are floor items, right are buttons +closestActiveObject :: World -> Maybe (Either FloorItem Button) +closestActiveObject w = listToMaybe $ sortBy (compare `on` dist ypos . pos) $ actObjs + where ypos = _crPos $ you w + actObjs = filter (\obj -> dist ypos (pos obj) < 40 && hasLOS ypos (pos obj) w) + $ map Left (IM.elems $ _floorItems w) ++ activeButtons -- map Right (IM.elems $ _buttons w) + pos (Right x) = _btPos x + pos (Left x) = _flItPos x + activeButtons = map Right + . filter ( (/=) BtNoLabel . _btState) + . IM.elems + $ _buttons w + +updateCloseObjects :: World -> World +updateCloseObjects w = w & closeActiveObjects .~ unionBy eTest oldCloseFiltered currentClose + where filt = filter $ \obj -> dist ypos (pos obj) < 40 && hasLOS ypos (pos obj) w + ypos = _crPos $ you w + objs = map Left (IM.elems $ _floorItems w) ++ activeButtons + activeButtons = map Right + . filter ( (/=) BtNoLabel . _btState) + . IM.elems + $ _buttons w + pos (Right x) = _btPos x + pos (Left x) = _flItPos x + eTest (Right x) (Right y) = _btID x == _btID y + eTest (Left x) (Left y) = _flItID x == _flItID y + eTest _ _ = False + currentClose = filt objs + oldClose = filt $ _closeActiveObjects w + oldCloseFiltered = intersectBy eTest oldClose currentClose + +closeObjScrollUp :: World -> World +closeObjScrollUp = over closeActiveObjects rotU + where rotU [] = [] + rotU (x:xs) = xs ++ [x] +closeObjScrollDown :: World -> World +closeObjScrollDown = over closeActiveObjects rotD + where rotD [] = [] + rotD xs = last xs : init xs diff --git a/src/Picture/Preload.hs b/src/Picture/Preload.hs index 2ee81f40f..8f47d172f 100644 --- a/src/Picture/Preload.hs +++ b/src/Picture/Preload.hs @@ -21,21 +21,10 @@ import Shaders data RenderData = RenderData { --_charMap :: Image PixelRGBA8 _textures :: [TextureObject] - , _basicShader :: (Program, [UniformLocation]) - , _textShader :: (Program, [UniformLocation]) - , _circShader :: (Program, [UniformLocation]) - , _ellipseShader :: (Program, [UniformLocation]) - , _arcShader :: (Program, [UniformLocation]) , _lightmapCircleShader :: (Program, [UniformLocation]) , _backShader :: (Program, [UniformLocation]) , _wallShadowShader :: (Program, [UniformLocation]) , _listShaders :: [FullShader] - , _triVAO :: VAO - , _lineVAO :: VAO - , _textVAO :: VAO - , _circVAO :: VAO - , _ellipseVAO :: VAO - , _arcVAO :: VAO , _backVAO :: VAO , _wallVAO :: VAO , _fadeCircVAO :: VAO @@ -87,18 +76,6 @@ makeTextureShader s shaderlist alocs pm renStrat texturePath = do , _shaderTexture = Just $ ShaderTexture {_textureObject = textureOb} } - -mkS :: IO FullShader -mkS = do - (prog,unis) <- makeSourcedShader "basic" [VertexShader,FragmentShader] - trivao <- setupVAO [(0,3),(1,4)] - return $ FullShader { _shaderProgram = prog - , _shaderUniforms = unis - , _shaderVAO = trivao - , _shaderPokeStrategy = pokeTriStrat - , _shaderDrawPrimitive = Triangles - } - pokeTriStrat (RenderPoly vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs pokeTriStrat _ = [] @@ -147,17 +124,6 @@ setupArrayBuffer (aloc,i) = do return vbo -loadTextures :: IO [Image PixelRGBA8] -loadTextures = do --- echarMap <- readImage "data/texture/smudgedDirt.png" - echarMap <- readImage "data/texture/charMap.png" - case echarMap of - Left err -> do - putStrLn err - return [] - Right charMap -> - return [convertRGBA8 charMap] - bufferOffset :: Integral a => a -> Ptr b bufferOffset = plusPtr nullPtr . fromIntegral @@ -168,14 +134,9 @@ frag = FragmentShader preloadRender :: IO RenderData preloadRender = do -- compile shader programs - bs <- makeSourcedShader "basic" [VertexShader,FragmentShader] - ts <- makeSourcedShader "character" [VertexShader,GeometryShader,FragmentShader] - cs <- makeSourcedShader "circle" [VertexShader,GeometryShader,FragmentShader] - as <- makeSourcedShader "arc" [VertexShader,GeometryShader,FragmentShader] fcs <- makeSourcedShader "lightmapCircle" [VertexShader,GeometryShader,FragmentShader] bgs <- makeSourcedShader "background" [VertexShader,GeometryShader,FragmentShader] wss <- makeSourcedShader "wallShadow" [VertexShader,GeometryShader,FragmentShader] - es <- makeSourcedShader "ellipseInterpolate" [VertexShader,GeometryShader,FragmentShader] wssLightPosUniLoc <- GL.uniformLocation (fst wss) "lightPos" @@ -194,21 +155,6 @@ preloadRender = do bindBuffer ArrayBuffer $= Just dummyvbo bufferData ArrayBuffer $= (fromIntegral floatSize, dummyptr, StaticDraw) --- load charmap as texture --- Right cmap <- readImage "data/texture/smudgedDirt.png" - Right cmap <- readImage "data/texture/charMap.png" - let tex = convertRGBA8 cmap - chartex <- genObjectName - textureBinding Texture2D $= Just chartex - let texData = V.toList $ imageData tex - wtex = fromIntegral $ imageWidth tex - htex = fromIntegral $ imageHeight tex - withArray texData $ \ptr -> do - texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D wtex htex) 0 - (PixelData RGBA UnsignedByte ptr) - generateMipmap' Texture2D - textureFilter Texture2D $= ((Linear',Just Linear') , Nearest) - Right cmap' <- readImage "data/texture/smudgedDirt.png" let dirt = convertRGBA8 cmap' dirttex <- genObjectName @@ -226,34 +172,17 @@ preloadRender = do -- input a list of (attribute location, attrib length) pairs -- these will have buffers and pointers created - trivao <- setupVAO [(0,3),(1,4)] - linevao <- setupVAO [(0,3),(1,4)] - textvao <- setupVAO [(0,3),(1,4),(2,3)] - circvao <- setupVAO [(0,3),(1,4),(2,1)] - ellipsevao <- setupVAO [(0,3),(1,4)] - arcvao <- setupVAO [(0,3),(1,4),(2,4)] backgroundvao <- setupVAO [(0,4),(1,2)] wallvao <- setupVAO [(0,4),(1,4)] fadecircvao <- setupVAO [(0,4)] return $ RenderData { -- _charMap = convertRGBA8 cmap - _textures = [chartex,dirttex] - ,_basicShader = bs - , _textShader = ts - , _circShader = cs - , _ellipseShader = es - , _arcShader = as + _textures = [dirttex,dirttex] , _listShaders = [bslist,lslist,cslist,aslist,eslist] , _lightmapCircleShader = fcs , _backShader = bgs , _wallShadowShader = wss - , _triVAO = trivao - , _textVAO = textvao - , _circVAO = circvao - , _ellipseVAO = ellipsevao - , _arcVAO = arcvao - , _lineVAO = linevao , _backVAO = backgroundvao , _wallVAO = wallvao , _fadeCircVAO = fadecircvao @@ -267,9 +196,9 @@ vaoPointers = (\(_,ps,_) -> ps) . unzip3 . _vaoBufferTargets cleanUpRenderPreload :: RenderData -> IO () cleanUpRenderPreload pd = do - mapM_ free $ vaoPointers $ _triVAO pd - mapM_ free $ vaoPointers $ _textVAO pd - mapM_ free $ vaoPointers $ _circVAO pd - mapM_ free $ vaoPointers $ _arcVAO pd - mapM_ free $ vaoPointers $ _lineVAO pd +-- mapM_ free $ vaoPointers $ _triVAO pd +-- mapM_ free $ vaoPointers $ _textVAO pd +-- mapM_ free $ vaoPointers $ _circVAO pd +-- mapM_ free $ vaoPointers $ _arcVAO pd +-- mapM_ free $ vaoPointers $ _lineVAO pd free $ _dummyPtr pd diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index c35922229..6c4554e2d 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -405,12 +405,7 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p -- set common uniforms setShaderUniforms rot zoom (tranx,trany) (winx,winy) (_listShaders pdata) - forM_ [_basicShader pdata - ,_textShader pdata - ,_circShader pdata - ,_arcShader pdata - ,_ellipseShader pdata - ,_lightmapCircleShader pdata + forM_ [_lightmapCircleShader pdata ,_backShader pdata ,_wallShadowShader pdata ] $ \shad -> do @@ -496,18 +491,6 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p uniform (_shaderUniforms shad !! 2) $= (0::Float) uniform (_shaderUniforms shad !! 3) $= Vector2 (0::Float) 0 uniform (_shaderUniforms shad !! 4) $= idmat - forM_ [_basicShader pdata - ,_textShader pdata - ,_circShader pdata - ,_arcShader pdata - ,_ellipseShader pdata - ] $ \shad -> do - currentProgram $= Just (fst shad) - uniform (snd shad !! 0) $= Vector2 (2::Float) 2 - uniform (snd shad !! 1) $= (1::Float) - uniform (snd shad !! 2) $= (0::Float) - uniform (snd shad !! 3) $= Vector2 (0::Float) 0 - uniform (snd shad !! 4) $= idmat endWallTicks <- SDL.ticks --return (ticksAfterL, ticks2+ticks3+ticks4, endWallTicks - startWallTicks) ticksE <- SDL.ticks @@ -525,69 +508,15 @@ renderTree' pdata rot zoom (tranx,trany) (winx,winy) tree = do let slist = _listShaders pdata +-- poke data, returns list of number of vertices for each shader is <- F.foldM (pokeShaders slist) tree +-- the idea of doing as binding of buffers at once, rather than interweaving with draw +-- calls, is to prevent opengl from waiting for a draw call to finish +-- before it performs another state change bindShaderBuffers slist is + drawShaders slist is pokeEndTicks <- SDL.ticks return $ pokeEndTicks - pokeStartTicks - --- the following code draws a picture tree --- it does not set nor change the blend function or depth buffer --- nor does it set uniforms -renderTree :: Foldable f => RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) - -> f RenderType -> IO Word32 -renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do - - pokeStartTicks <- SDL.ticks --- poke necessary data - (nTriVs,nTextVs,nCircVs,nLineVs,nArcVs,nEllVs) --- <- F.foldM (theFold (_ptrPosVBO pdata, _ptrColVBO pdata) - <- F.foldM (theFold (twoPtrsVAO $ _triVAO pdata) - (threePtrsVAO $ _textVAO pdata) - (threePtrsVAO $ _circVAO pdata) - (twoPtrsVAO $ _lineVAO pdata) - (threePtrsVAO $ _arcVAO pdata) - (twoPtrsVAO $ _ellipseVAO pdata) - ) $ tree - - pokeEndTicks <-SDL.ticks --- bind buffers --- the idea of doing as much of this at once, rather than interweaving with draw --- calls, is to prevent opengl from waiting for a draw call to finish --- before it performs another state change - bindArrayBuffers nTriVs $ _vaoBufferTargets $ _triVAO pdata - bindArrayBuffers nCircVs $ _vaoBufferTargets $ _circVAO pdata - bindArrayBuffers nArcVs $ _vaoBufferTargets $ _arcVAO pdata - bindArrayBuffers nLineVs $ _vaoBufferTargets $ _lineVAO pdata - bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO pdata - bindArrayBuffers nEllVs $ _vaoBufferTargets $ _ellipseVAO pdata - - --- draw triangles - currentProgram $= Just (fst $ _basicShader pdata) - bindVertexArrayObject $= Just (_vao $ _triVAO pdata) - drawArrays Triangles 0 (fromIntegral $ nTriVs) --- draw circles - currentProgram $= Just (fst $ _circShader pdata) - bindVertexArrayObject $= Just (_vao $ _circVAO pdata) - drawArrays Points 0 (fromIntegral $ nCircVs) --- draw ellipses - currentProgram $= Just (fst $ _ellipseShader pdata) - bindVertexArrayObject $= Just (_vao $ _ellipseVAO pdata) - drawArrays Triangles 0 (fromIntegral $ nEllVs) --- draw arcs - currentProgram $= Just (fst $ _arcShader pdata) - bindVertexArrayObject $= Just (_vao $ _arcVAO pdata) - drawArrays Points 0 (fromIntegral $ nArcVs) --- draw lines - currentProgram $= Just (fst $ _basicShader pdata) - bindVertexArrayObject $= Just (_vao $ _lineVAO pdata) - drawArrays Lines 0 (fromIntegral $ nLineVs) --- draw text - currentProgram $= Just (fst $ _textShader pdata) - bindVertexArrayObject $= Just (_vao $ _textVAO pdata) - textureBinding Texture2D $= Just (_textures pdata !! 0) - drawArrays Points 0 (fromIntegral $ nTextVs) - return (pokeEndTicks - pokeStartTicks)