95 lines
3.9 KiB
Haskell
95 lines
3.9 KiB
Haskell
module Dodge.Creature.Impulse.UseItem
|
|
( useItem
|
|
, useLeftItem
|
|
) where
|
|
import Dodge.Data
|
|
import Dodge.Inventory
|
|
|
|
import qualified Data.IntMap.Strict as IM
|
|
--import qualified Data.IntSet as IS
|
|
import Control.Lens
|
|
import Data.Maybe
|
|
|
|
useItem :: Creature -> World -> World
|
|
useItem cr' w = fromMaybe (f w) $ do
|
|
cr <- w ^? creatures . ix (_crID cr')
|
|
it <- cr ^? crInv . ix (crSel cr)
|
|
return $ itemEffect cr it w
|
|
where
|
|
f = creatures . ix (_crID cr') . crHammerPosition .~ HammerDown
|
|
|
|
itemEffect :: Creature -> Item -> World -> World
|
|
itemEffect cr it w = case it ^? itUse of
|
|
Just RightUse {_rUse = eff,_useMods = usemods}
|
|
-> hammerTest $ foldr ($) eff usemods it cr
|
|
Just LeftUse {} -> doequipmentchange
|
|
Just EquipUse{} -> doequipmentchange
|
|
-- ConsumeUse will cause problems if the item is not selected
|
|
Just (ConsumeUse eff) -> setuhamdown $ hammerTest $ eff it cr . rmInvItem (_crID cr) (crSel cr)
|
|
Just NoUse -> setuhamdown w
|
|
Nothing -> setuhamdown w
|
|
where
|
|
hammerTest f = case _crHammerPosition cr of
|
|
HammerUp -> f w
|
|
_ -> w & setuhamdown
|
|
setuhamdown = creatures . ix (_crID cr) . crHammerPosition .~ HammerDown
|
|
doequipmentchange = setuhamdown $ hammerTest (toggleEquipmentAt (_rbOptions w) (crSel cr) cr
|
|
. activateEquipmentAt (_rbOptions w) cr)
|
|
|
|
activateEquipmentAt :: RightButtonOptions -> Creature -> World -> World
|
|
activateEquipmentAt rbo cr = creatures . ix (_crID cr) %~ case (rbo ^? opActivateEquipment . activateEquipment, rbo ^? opActivateEquipment . deactivateEquipment) of
|
|
(Just i,_) -> crLeftInvSel ?~ i
|
|
(_,Just _) -> crLeftInvSel .~ Nothing
|
|
_ -> id
|
|
|
|
toggleEquipmentAt :: RightButtonOptions -> Int -> Creature -> World -> World
|
|
toggleEquipmentAt rbops invid cr w = case rbops ^? opAllocateEquipment of
|
|
Just DoNotMoveEquipment -> w
|
|
Just PutOnEquipment {_allocNewPos = newp}
|
|
-> w & crpoint . crEquipment . at newp ?~ invid
|
|
& crpoint . crInvEquipped . at invid ?~ newp
|
|
& onequip itm cr
|
|
Just MoveEquipment {_allocNewPos=newp,_allocOldPos = oldp }
|
|
-> w & crpoint . crEquipment . at newp ?~ invid
|
|
& crpoint . crEquipment . at oldp .~ Nothing
|
|
& crpoint . crInvEquipped . at invid ?~ newp
|
|
Just SwapEquipment {_allocNewPos=newp, _allocOldPos = oldp, _allocSwapID = sid }
|
|
-> w & crpoint . crEquipment . at newp ?~ invid
|
|
& crpoint . crEquipment . at oldp ?~ sid
|
|
& crpoint . crInvEquipped . at invid ?~ newp
|
|
& crpoint . crInvEquipped . at sid ?~ oldp
|
|
Just ReplaceEquipment {_allocNewPos = newp, _allocRemoveID = rid }
|
|
-> w & crpoint . crEquipment . at newp ?~ invid
|
|
& crpoint . crInvEquipped . at invid ?~ newp
|
|
& crpoint . crInvEquipped . at rid .~ Nothing
|
|
& onremove (itmat rid) cr
|
|
& onequip itm cr
|
|
Just RemoveEquipment {_allocOldPos = oldp }
|
|
-> w & crpoint . crEquipment . at oldp .~ Nothing
|
|
& crpoint . crInvEquipped . at invid .~ Nothing
|
|
& onremove itm cr
|
|
Nothing -> error "tried to toggle equipment whilst not prepared"
|
|
where
|
|
crpoint = creatures . ix (_crID cr)
|
|
itmat i = _crInv cr IM.! i
|
|
itm = itmat (crSel cr)
|
|
onequip itm' = (_eqOnEquip . _eqEq . _itUse) itm' itm'
|
|
onremove itm' = (_eqOnRemove . _eqEq . _itUse) itm' itm'
|
|
|
|
useLeftItem :: Int -> World -> World
|
|
useLeftItem cid w
|
|
| _crInvLock cr = w
|
|
| itmShouldBeUsed = useItem cr w
|
|
| otherwise = fromMaybe w $ do
|
|
invid <- _crLeftInvSel cr
|
|
itm <- cr ^? crInv . ix invid
|
|
f <- cr ^? crInv . ix invid . itUse . lUse
|
|
return $ f itm cr w
|
|
where
|
|
cr = _creatures w IM.! cid
|
|
itmShouldBeUsed = isJust (cr ^? crInv . ix (crSel cr) . itUse . cUse)
|
|
|| ( isJust (cr ^? crInv . ix (crSel cr) . itUse . eqEq . eqUse)
|
|
&& _crLeftInvSel cr /= Just (crSel cr)
|
|
)
|
|
-- TODO determine itmShouldBeUsed with reference to config options
|