First pass deletion, increases perfomance significantly

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

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]
+         _textures = [dirttex,dirttex]
-        ,_basicShader  = bs
-        , _textShader   = ts
-        , _circShader = cs
-        , _ellipseShader = es
-        , _arcShader = as
         , _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 $ _triVAO  pd
-    mapM_ free $ vaoPointers $ _textVAO pd
+--    mapM_ free $ vaoPointers $ _textVAO pd
-    mapM_ free $ vaoPointers $ _circVAO pd
+--    mapM_ free $ vaoPointers $ _circVAO pd
-    mapM_ free $ vaoPointers $ _arcVAO  pd
+--    mapM_ free $ vaoPointers $ _arcVAO  pd
-    mapM_ free $ vaoPointers $ _lineVAO pd
+--    mapM_ free $ vaoPointers $ _lineVAO pd
     free $ _dummyPtr pd

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
+    forM_ [_lightmapCircleShader pdata
-          ,_textShader       pdata
-          ,_circShader       pdata
-          ,_arcShader        pdata
-          ,_ellipseShader    pdata
-          ,_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)