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

Add newtype to floor item ids

Browse Source
This commit is contained in:
justin
2024-09-23 22:42:09 +01:00
parent 43b365185d
commit 265da89791
20 changed files with 193 additions and 158 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/Action.hs
+4 -14
View File
@@ -12,7 +12,6 @@ module Dodge.Creature.Action (
blinkActionFail,
unsafeBlinkAction,
sizeSelf,
copyInvItemToFloor,
youDropItem,
pickUpItem,
-- pickUpItemID,
@@ -170,19 +169,16 @@ setMinInvSize n cr = cWorld . lWorld . creatures . ix (_crID cr) . crInvCapacity
-- newSelKey = fromMaybe 0 $ findIndex ((== crSel cr) . fst) pairs
-- newInv = IM.fromAscList $ zip [0 ..] $ map snd pairs
--dropUnselected :: Creature -> World -> World
--dropUnselected cr w =
-- foldr (dropItem cr) w . IM.keys $
-- crSel cr `IM.delete` _crInv cr
dropExcept :: Creature -> Int -> World -> World
dropExcept cr invid w =
foldr (dropItem cr) w . IM.keys $
invid `IM.delete` _crInv cr
dropItem :: Creature -> Int -> World -> World
dropItem cr invid = rmInvItem (_crID cr) invid . copyInvItemToFloor cr invid -- . mayberemoveequip
dropItem cr invid = rmInvItem (_crID cr) invid .
copyItemToFloor (_crPos cr) itm -- . mayberemoveequip
where
itm = fromMaybe (error "dropItem cannot find item") $ cr ^? crInv . ix invid
-- the following should be done in rmInvItem
-- mayberemoveequip = case _crLeftInvSel cr of
-- Just i | i == invid -> creatures . ix cid . crLeftInvSel .~ Nothing
@@ -205,12 +201,6 @@ youDropItem w = fromMaybe w $ do
it <- yourSelectedItem w
return $ it ^. itCurseStatus /= Uncursed
-- | Copy an inventory item to the floor.
copyInvItemToFloor :: Creature -> Int -> World -> World
copyInvItemToFloor cr i =
copyItemToFloor (_crPos cr) $
_crInv cr IM.! i
sizeSelf :: Float -> Creature -> World -> Maybe World
sizeSelf x cr w
| not (crOnWall cr1 w) =
src/Dodge/Creature/State.hs
+7 -7
View File
@@ -226,7 +226,7 @@ useEquipment cr i = useE (_eeUse (_equipEffect $ _itUse itm)) itm cr
-- a map updating all inventory items
updateInv :: Creature -> World -> World
updateInv cr = cWorld . lWorld . creatures . ix (_crID cr) . crInv %~ IM.mapWithKey (itemUpdate cr)
updateInv cr = cWorld . lWorld . creatures . ix (_crID cr) . crInv %~ IM.map itemUpdate
-- a loop going over equipped items
equipmentEffects :: Creature -> World -> World
@@ -259,14 +259,14 @@ itemInvSideEffect _ _
-- where
-- attachoff = it ^?! itDimension . dimAttachPos
itemUpdate :: Creature -> Int -> Item -> Item
itemUpdate cr i =
itemUpdate :: Item -> Item
itemUpdate =
updateAutoRecharge
. (itUse %~ useUpdate)
. (itLocation .~ InInv (_crID cr) i itmisselected itmisroot)
where
itmisroot = Just i == (cr ^? crManipulation . manObject . inInventory . imRootItem)
itmisselected = Just i == (cr ^? crManipulation . manObject . inInventory . imSelectedItem)
-- . (itLocation .~ InInv (_crID cr) i itmisselected itmisroot)
-- where
-- itmisroot = Just i == (cr ^? crManipulation . manObject . inInventory . imRootItem)
-- itmisselected = Just i == (cr ^? crManipulation . manObject . inInventory . imSelectedItem)
updateAutoRecharge :: Item -> Item
updateAutoRecharge it = case it ^? itUse . leftConsumption of
src/Dodge/Data/FloorItem.hs
+3 -1
View File
@@ -5,13 +5,15 @@
module Dodge.Data.FloorItem where
import NewInt
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import Dodge.Data.Item
import Geometry.Data
data FloorItem = FlIt {_flIt :: Item, _flItPos :: Point2, _flItRot :: Float, _flItID :: Int}
data FloorItem = FlIt {_flIt :: Item, _flItPos :: Point2, _flItRot :: Float, _flItID :: NewInt FloorInt}
--deriving (Eq, Show, Read) --Generic, Flat)
makeLenses ''FloorItem
src/Dodge/Data/Item.hs
+4
View File
@@ -30,6 +30,9 @@ import Dodge.Data.Item.Use
import Dodge.Data.Item.Location
import Data.Set (Set)
data ItID = ItID
deriving (Eq,Ord,Show,Read)
data Item = Item
{ _itUse :: ItemUse
, _itType :: ItemType
@@ -57,5 +60,6 @@ _itUseAimStance :: Item -> AimStance
_itUseAimStance = _aimStance . _heldAim . _itUse
makeLenses ''Item
deriveJSON defaultOptions ''ItID
deriveJSON defaultOptions ''ItemAttachment
deriveJSON defaultOptions ''Item
src/Dodge/Data/Item/Location.hs
+17 -1
View File
@@ -2,18 +2,34 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE EmptyDataDeriving #-}
module Dodge.Data.Item.Location where
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import NewInt
-- it would be nice to have these as empty types, but I'm not sure how to get
-- aeson to handle that
data FloorInt = FloorInt
deriving (Eq,Ord,Show,Read)
-- should use these..
data InvInt = InvInt
deriving (Eq,Ord,Show,Read)
data TurretInt
deriving (Eq,Ord,Show,Read)
data CrInt = CrInt
deriving (Eq,Ord,Show,Read)
data ItemLocation
= InInv {_ilCrID :: Int, _ilInvID :: Int, _ilIsRoot :: Bool, _ilIsSelected :: Bool}
| OnTurret {_ilTuID :: Int}
| OnFloor {_ilFlID :: Int}
| OnFloor {_ilFlID :: NewInt FloorInt}
| InVoid
deriving (Eq, Show, Ord, Read) --Generic, Flat)
makeLenses ''ItemLocation
deriveJSON defaultOptions ''InvInt
deriveJSON defaultOptions ''FloorInt
deriveJSON defaultOptions ''ItemLocation
src/Dodge/Data/LWorld.hs
+2 -1
View File
@@ -47,6 +47,7 @@ module Dodge.Data.LWorld (
module Dodge.Data.WorldEffect,
) where
import NewInt
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
@@ -128,7 +129,7 @@ data LWorld = LWorld
, _blocks :: IM.IntMap Block
, _coordinates :: IM.IntMap Point2
, _triggers :: IM.IntMap Bool
, _floorItems :: IM.IntMap FloorItem
, _floorItems :: NewIntMap FloorInt FloorItem
, _modifications :: IM.IntMap Modification
, _worldEvents :: [WdWd]
, _delayedEvents :: [(Int, WdWd)]
src/Dodge/Default/World.hs
+2 -1
View File
@@ -1,5 +1,6 @@
module Dodge.Default.World where
import NewInt
import Control.Lens
import Data.Graph.Inductive.Graph hiding ((&))
import qualified Data.Map as M
@@ -125,7 +126,7 @@ defaultLWorld =
, _doors = IM.empty
, _coordinates = IM.empty
, _triggers = IM.empty
, _floorItems = IM.empty
, _floorItems = NIntMap IM.empty
, _worldEvents = []
, _delayedEvents = []
, _pressPlates = IM.empty
src/Dodge/FloorItem.hs
+14 -14
View File
@@ -3,8 +3,10 @@ module Dodge.FloorItem (
copyItemToFloorID,
) where
import NewInt
import Control.Lens
import Data.Maybe
import Data.Monoid
import Dodge.Base
import Dodge.Data.World
import Geometry
@@ -16,24 +18,22 @@ copyItemToFloor :: Point2 -> Item -> World -> World
copyItemToFloor pos it = snd . copyItemToFloorID pos it
-- | Copy an item to the floor, returns the floor item's id.
copyItemToFloorID :: Point2 -> Item -> World -> (Int, World)
copyItemToFloorID :: Point2 -> Item -> World -> (NewInt FloorInt, World)
copyItemToFloorID pos it w =
(,) flid $
(,) (NInt flid) $
w'
& cWorld . lWorld . floorItems %~ IM.insert flid theflit
& updateLocation
& cWorld . lWorld . floorItems . unNIntMap %~ IM.insert flid theflit
& cWorld . lWorld . itemLocations . ix (_itID it) .~ OnFloor (NInt flid)
where
(p', w') = findWallFreeDropPoint (_dimRad $ _itDimension it) pos w
rot = fst . randomR (- pi, pi) $ _randGen w
updateLocation = cWorld . lWorld . itemLocations . ix (_itID it) .~ OnFloor flid
flid = IM.newKey $ _floorItems (_lWorld (_cWorld w))
flid = IM.newKey . _unNIntMap . _floorItems . _lWorld $ _cWorld w
theflit =
FlIt
-- { _flIt = it & itUse . useAmount %~ const 1
{ _flIt = it
, _flItPos = p'
, _flItRot = rot
, _flItID = flid
, _flItID = NInt flid
}
cardinalVectors :: [Point2]
@@ -46,12 +46,12 @@ cardinalVectors =
findWallFreeDropPoint :: Float -> Point2 -> World -> (Point2, World)
findWallFreeDropPoint r p w =
( head $ mapMaybe f cardinalVectors ++ [p]
, w{_randGen = g}
( fromMaybe p . getFirst $ foldMap f cardinalVectors
, w & randGen .~ g
)
where
f q = testOnWall r $ p +.+ rotateV rot (10 *.* q)
testOnWall r' q
| circOnSomeWall q r' w = Nothing
| otherwise = Just q
f q = testOnWall $ p +.+ rotateV rot (10 *.* q)
testOnWall q
| circOnSomeWall q r w = mempty
| otherwise = pure q
(rot, g) = randomR (0, 2 * pi) $ _randGen w
src/Dodge/Inventory.hs
+5 -2
View File
@@ -13,6 +13,7 @@ module Dodge.Inventory (
module Dodge.Inventory.RBList
) where
import NewInt
import Dodge.Inventory.Location
import Dodge.Inventory.RBList
import Control.Applicative
@@ -195,10 +196,12 @@ updateCloseObjects w =
. filter ((/=) BtNoLabel . _btState)
. IM.elems
$ w ^. cWorld . lWorld . buttons
currentClose = filt $ map Left (IM.elems $ w ^. cWorld . lWorld . floorItems) ++ activeButtons
currentClose = filt $ map Left (IM.elems $ w ^. cWorld . lWorld . floorItems . unNIntMap)
++ activeButtons
oldClose = filt $ mapMaybe updatebyid $ w ^. hud . closeObjects
oldCloseFiltered = intersectBy closeObjEq oldClose currentClose
updatebyid (Left flid) = fmap Left $ w ^? cWorld . lWorld . floorItems . ix (_flItID flid)
updatebyid (Left flid) = fmap Left $ w ^? cWorld . lWorld . floorItems . unNIntMap
. ix (_unNInt $ _flItID flid)
updatebyid (Right btid) = fmap Right $ w ^? cWorld . lWorld . buttons . ix (_btID btid)
changeSwapSel :: Int -> World -> World
src/Dodge/Inventory/Add.hs
+4 -3
View File
@@ -5,6 +5,7 @@ module Dodge.Inventory.Add (
pickUpItem,
) where
import NewInt
import Dodge.SoundLogic
import Dodge.Inventory.Location
--import Dodge.Item.Grammar
@@ -18,9 +19,9 @@ import Dodge.FloorItem
import Dodge.Inventory.CheckSlots
import qualified IntMapHelp as IM
tryPutItemIDInInv :: Int -> Int -> World -> Maybe (Int, World)
tryPutItemIDInInv :: Int -> NewInt FloorInt -> World -> Maybe (Int, World)
tryPutItemIDInInv cid flitid w = do
flit <- w ^? cWorld . lWorld . floorItems . ix flitid
flit <- w ^? cWorld . lWorld . floorItems . unNIntMap . ix (_unNInt flitid)
tryPutItemInInv cid flit w
-- | Pick up a specific item.
@@ -32,7 +33,7 @@ tryPutItemInInv cid flit w = case maybeInvSlot of
( i
, w
& updateItLocation i
& cWorld . lWorld . floorItems %~ IM.delete (_flItID flit)
& cWorld . lWorld . floorItems . unNIntMap %~ IM.delete (_unNInt $ _flItID flit)
-- & cWorld . lWorld . creatures . ix cid . crInv %~ IM.insert i it
& cWorld . lWorld . creatures . ix cid . crInv . at i ?~ it
& setInvPosFromSS
src/Dodge/Item/Location.hs
+3 -2
View File
@@ -6,6 +6,7 @@ module Dodge.Item.Location (
pointerYourRootItem,
) where
import NewInt
import Control.Lens
import Data.Maybe
import Dodge.Data.World
@@ -14,7 +15,7 @@ getItem :: Int -> World -> Maybe Item
getItem itid w = do
itpos <- w ^? cWorld . lWorld . itemLocations . ix itid
case itpos of
OnFloor flitid -> w ^? cWorld . lWorld . floorItems . ix flitid . flIt
OnFloor flitid -> w ^? cWorld . lWorld . floorItems . unNIntMap . ix (_unNInt flitid) . flIt
InInv {_ilCrID = cid, _ilInvID = invid}
-> w ^? cWorld . lWorld . creatures . ix cid . crInv . ix invid
OnTurret mcid -> w ^? cWorld . lWorld . machines . ix mcid . mcType . _McTurret . tuWeapon
@@ -28,7 +29,7 @@ pointerToItemLocation ::
f World
pointerToItemLocation InInv {_ilCrID = cid, _ilInvID = invid}
= cWorld . lWorld . creatures . ix cid . crInv . ix invid
pointerToItemLocation (OnFloor flid) = cWorld . lWorld . floorItems . ix flid . flIt
pointerToItemLocation (OnFloor flid) = cWorld . lWorld . floorItems . unNIntMap . ix (_unNInt flid) . flIt
pointerToItemLocation _ = const pure
pointerYourSelectedItem :: Applicative a => (Item -> a Item) -> World -> a World
src/Dodge/Item/Location/Initialize.hs
+3 -2
View File
@@ -3,6 +3,7 @@ module Dodge.Item.Location.Initialize
, initItemLocations
)
where
import NewInt
import Dodge.Data.LWorld
import Control.Lens
import qualified IntMapHelp as IM
@@ -17,9 +18,9 @@ initCrsItemLocations w = w' & creatures .~ newcreatures
(w', newcreatures) = mapAccumR initCrItemLocations w (w ^. creatures)
initFlItemsLocations :: LWorld -> LWorld
initFlItemsLocations w = w' & floorItems .~ newfloorItems
initFlItemsLocations w = w' & floorItems .~ NIntMap newfloorItems
where
(w', newfloorItems) = mapAccumR initFlItemLocation w (w ^. floorItems)
(w', newfloorItems) = mapAccumR initFlItemLocation w (w ^. floorItems . unNIntMap)
initTusItemLocations :: LWorld -> LWorld
initTusItemLocations w = w' & machines .~ newmachines
src/Dodge/Placement/PlaceSpot.hs
+3 -1
View File
@@ -5,6 +5,7 @@ module Dodge.Placement.PlaceSpot (
placeSpot,
) where
import NewInt
import Color
import Control.Lens
import Control.Monad.State
@@ -99,7 +100,8 @@ placeSpotID' ps pt w = case pt of
PutProp prp -> plNewUpID (cWorld . lWorld . props) prID (mvProp p rot prp) w
PutButton bt -> plNewUpID (cWorld . lWorld . buttons) btID (mvButton p rot bt) w
PutTerminal tm -> plNewUpID (cWorld . lWorld . terminals) tmID tm w
PutFlIt itm -> plNewUpID (cWorld . lWorld . floorItems) flItID (createFlIt p rot itm) w
PutFlIt itm -> plNewUpID (cWorld . lWorld . floorItems . unNIntMap) (flItID . unNInt)
(createFlIt p rot itm) w
PutCrit cr -> plNewUpID (cWorld . lWorld . creatures) crID (mvCr p rot cr) w
PutForeground fs -> plNewUpID (cWorld . lWorld . foregroundShapes) fsID (mvFS p rot fs) w
PutDecoration pic -> plNewID (cWorld . lWorld . decorations) (shiftDec p rot pic) w
src/Dodge/RadarSweep.hs
+2 -1
View File
@@ -3,6 +3,7 @@ module Dodge.RadarSweep
, updateRadarSweep
) where
import NewInt
import Color
import Data.Maybe
import Dodge.Data.World
@@ -72,7 +73,7 @@ crBlips p r = IM.elems . IM.filter f . fmap _crPos . IM.filter g . _creatures .
g cr = _crID cr /= 0
itemBlips :: Point2 -> Float -> World -> [Point2]
itemBlips p r = IM.elems . IM.filter f . fmap _flItPos . _floorItems . _lWorld . _cWorld
itemBlips p r = IM.elems . IM.filter f . fmap _flItPos . _unNIntMap . _floorItems . _lWorld . _cWorld
where
f q = dist p q <= r && dist p q > r - 4
src/Dodge/Render/ShapePicture.hs
+2 -1
View File
@@ -2,6 +2,7 @@ module Dodge.Render.ShapePicture (
worldSPic,
) where
import NewInt
import Dodge.Render.List
import Control.Lens
import Control.Monad (guard)
@@ -30,7 +31,7 @@ worldSPic cfig u =
<> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foregroundShapes)
<> foldup (shiftDraw' _cpPos _cpDir _cpSPic) (filtOn _cpPos _corpses)
<> foldup drawCreature (filtOn _crPos _creatures)
<> foldup floorItemSPic (filtOn _flItPos _floorItems)
<> foldup floorItemSPic (filtOn _flItPos (_unNIntMap . _floorItems))
<> foldup btSPic (filtOn _btPos _buttons)
<> foldup mcSPic (filtOn _mcPos _machines)
<> aimDelaySweep w
src/Dodge/TestString.hs
+12 -13
View File
@@ -20,19 +20,18 @@ import Dodge.Data.Universe
import qualified IntMapHelp as IM
testStringInit :: Universe -> [String]
testStringInit _ = []
--testStringInit u = (topTestPart u
-- <>) $ map showh $
-- (IM.toList . IM.filter (\itloc -> itloc ^? ilCrID == Just 0) $ (u ^. uvWorld . cWorld . lWorld . itemLocations)) <> ( IM.elems $ fmap h (u ^?! uvWorld . cWorld . lWorld . creatures . ix 0 . crInv))
-- where
-- h itm = (_itID itm, _itLocation itm)
-- showh (x,(InInv a b c d)) = show x ++ "," ++ show a ++ "," ++ show b ++"," ++ show c ++"," ++ show d
-- showh _ = ""
--
--topTestPart :: Universe -> [String]
--topTestPart u = [show $ u ^? uvWorld . hud . hudElement . diSections . sssExtra . sssSelPos
-- , maybe "" showManObj $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crManipulation . manObject
-- ]
testStringInit u = (topTestPart u
<>) $ map showh $
(IM.toList . IM.filter (\itloc -> itloc ^? ilCrID == Just 0) $ (u ^. uvWorld . cWorld . lWorld . itemLocations)) <> ( IM.elems $ fmap h (u ^?! uvWorld . cWorld . lWorld . creatures . ix 0 . crInv))
where
h itm = (_itID itm, _itLocation itm)
showh (x,(InInv a b c d)) = show x ++ "," ++ show a ++ "," ++ show b ++"," ++ show c ++"," ++ show d
showh _ = ""
topTestPart :: Universe -> [String]
topTestPart u = [show $ u ^? uvWorld . hud . hudElement . diSections . sssExtra . sssSelPos
, maybe "" showManObj $ u ^? uvWorld . cWorld . lWorld . creatures . ix 0 . crManipulation . manObject
]
showManObj :: ManipulatedObject -> String
showManObj (InInventory SortInventory) = "SortInventory"
src/Dodge/TractorBeam/Update.hs
+2 -1
View File
@@ -1,5 +1,6 @@
module Dodge.TractorBeam.Update where
import NewInt
import Control.Lens
import Dodge.Data.World
import Geometry
@@ -11,7 +12,7 @@ updateTractorBeam w pj
| otherwise =
( w
& cWorld . lWorld . creatures %~ IM.map (tractCr pullVel pos outpos)
& cWorld . lWorld . floorItems %~ IM.map (tractFlIt pullVel pos outpos)
& cWorld . lWorld . floorItems . unNIntMap %~ IM.map (tractFlIt pullVel pos outpos)
, Just (pj & tbTime -~ 1)
)
where