First pass deletion, increases perfomance significantly

2021-03-10 19:44:59 +01:00
parent 06a8ae7c99
commit 4a455cc7c9
3 changed files with 117 additions and 154 deletions
@@ -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