justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

First pass deletion, increases perfomance significantly

Browse Source
This commit is contained in:
jgk
2021-03-10 19:44:59 +01:00
parent 06a8ae7c99
commit 4a455cc7c9
3 changed files with 117 additions and 154 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Inventory.hs
+105
View File
@@ -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
+6 -77
View File
@@ -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
src/Picture/Render.hs
+6 -77
View File
@@ -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)