Start to implement equipment sites on body

src/Dodge/Creature.hs

@@ -174,6 +174,8 @@ inventoryA = IM.fromList $ zip [0..]
 testInventory :: IM.IntMap Item
 testInventory = IM.fromList $ zip [0..] 
     [ makeTypeCraftNum 9 PIPE
+    , frontArmour
+    , flameShield
     , makeModule INCENDIARYMODULE
     , makeModule STATICMODULE
     , makeModule CONCUSSMODULE

src/Dodge/Creature/Impulse/UseItem.hs

@@ -6,6 +6,7 @@ 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
 
@@ -22,7 +23,7 @@ itemEffect cr it w = case it ^? itUse of
     Just RightUse {_rUse = eff,_useMods = usemods} 
                     -> hammerTest $ foldr ($) eff usemods it cr
     Just LeftUse {} -> setuhamdown $ lhammer setEquipLeftItem
-    Just EquipUse{} -> setuhamdown $ lhammer setEquipment
+    Just EquipUse{} -> setuhamdown $ lhammer $ toggleEquipmentAt (_crInvSel cr) it
     -- ConsumeUse will cause problems if the item is not selected
     Just (ConsumeUse eff) -> setuhamdown $ hammerTest $ eff it cr . rmInvItem (_crID cr) (_crInvSel cr)
     Just NoUse -> setuhamdown w
@@ -37,15 +38,44 @@ itemEffect cr it w = case it ^? itUse of
     setEquipLeftItem cr' = case _crLeftInvSel cr' of
         Just i | i == _crInvSel cr' -> cr' & crLeftInvSel .~ Nothing
         _ -> cr' & crLeftInvSel ?~ _crInvSel cr'
-    setEquipment = toggleEquipmentAt (_crInvSel cr)
     setuhamdown = creatures . ix (_crID cr) . crHammerPosition .~ HammerDown
 
-toggleEquipmentAt :: Int -> Creature -> Creature
+toggleEquipmentAt :: Int -> Item -> Creature -> Creature
-toggleEquipmentAt invid cr = cr & crInvEquipped . at invid %~ f
+toggleEquipmentAt invid itm cr 
+    | invid `IS.member` _crInvEquipped cr = cr & crInvEquipped . at invid .~ Nothing
+        & removeEquipmentUsingSite esite
+        & setEquipmentSite esite Nothing'
+    | otherwise = cr & crInvEquipped . at invid .~ Just ()
+        & removeEquipmentUsingSite esite
+        & setEquipmentSite esite (Just' invid)
   where
+    esite = _eqSite (_itUse itm)
     f Nothing = Just ()
     f (Just ()) = Nothing
 
+removeEquipmentUsingSite :: EquipSite -> Creature -> Creature
+removeEquipmentUsingSite esite cr = case esite of
+    GoesOnSpecial   -> cr
+    _ -> case cr ^? crEquipment . esiteToPoint . _Just' of
+        Just invid -> cr & crInvEquipped . at invid .~ Nothing
+        _ -> cr
+  where
+    esiteToPoint = case esite of
+        GoesOnHead      -> onHead
+        GoesOnChest     -> onChest
+        GoesOnBack      -> onBack
+        GoesOnWrist     -> onWristL
+        GoesOnLegs      -> onLegs
+
+setEquipmentSite :: EquipSite -> Maybe' Int -> Creature -> Creature
+setEquipmentSite esite = case esite of
+    GoesOnHead      -> set (crEquipment . onHead)
+    GoesOnChest     -> set (crEquipment . onChest)
+    GoesOnBack      -> set (crEquipment . onBack)
+    GoesOnWrist     -> set (crEquipment . onWristL)
+    GoesOnLegs      -> set (crEquipment . onLegs)
+    GoesOnSpecial   -> const id
+
 useLeftItem :: Int -> World -> World
 useLeftItem cid w 
     | _crInvLock cr = w

src/Dodge/Creature/Perception.hs

@@ -169,9 +169,8 @@ rememberSounds w cr = cr
 
 -- TODO work out correct form for sounds passing through walls
 soundIsClose :: World -> Creature -> (Point2,Float) -> Bool
-soundIsClose w cr (pos,vol) 
+soundIsClose w cr (pos,vol) = dist cpos pos < 2000 
-    | dist cpos pos > 2000 = False
+    && vol > (_auDist . _crAudition $ _crPerception cr) (dist pos cpos)
-    | hasLOS cpos pos w = vol > (_auDist . _crAudition $ _crPerception cr) (dist pos cpos)
+    && hasLOS cpos pos w
-    | otherwise = False
   where
     cpos = _crPos cr

src/Dodge/Creature/Property.hs

@@ -8,11 +8,14 @@ import Geometry
 
 import Control.Lens
 
+-- the use of crOldPos is because the damage position is calculated on the
+-- previous frame
+-- Not sure if it is a good idea
 crIsArmouredFrom :: Point2 -> Creature -> Bool
 crIsArmouredFrom p cr 
-    = p /= _crPos cr 
+    = p /= _crOldPos cr 
         && any (\it -> it ^? itType == Just FRONTARMOUR) (_crInv cr)
-        && angleVV (unitVectorAtAngle $ _crDir cr) (p -.- _crPos cr) < pi/2
+        && angleVV (unitVectorAtAngle $ _crDir cr) (p -.- _crOldPos cr) < pi/2
 -- even though angleVV can generate NaN, the comparison seems to deal with it
 
 --crOnSeg :: Point2 -> Point2 -> Creature -> Bool

src/Dodge/Data.hs

@@ -278,6 +278,7 @@ data Creature = Creature
     , _crInvCapacity    :: Int
     , _crInvLock        :: Bool
     , _crInvEquipped    :: IS.IntSet
+    , _crEquipment      :: CreatureEquipment
     , _crLeftInvSel     :: Maybe Int
     , _crState          :: CreatureState
     , _crCorpse         :: Picture
@@ -296,6 +297,14 @@ data Creature = Creature
     , _crHammerPosition :: HammerPosition
     , _crName           :: String
     }
+data CreatureEquipment = CreatureEquipment
+    {_onHead    :: Maybe' Int
+    ,_onChest   :: Maybe' Int
+    ,_onBack    :: Maybe' Int
+    ,_onWristL  :: Maybe' Int
+    ,_onWristR  :: Maybe' Int
+    ,_onLegs    :: Maybe' Int
+    }
 data Vocalization 
     = Mute
     | Vocalization
@@ -376,8 +385,17 @@ data ItemUse
         }
     | EquipUse
         { _eqUse :: Creature -> Int -> World -> World
+        , _eqSite :: EquipSite
         }
     | NoUse
+data EquipSite
+    = GoesOnHead
+    | GoesOnChest
+    | GoesOnBack
+    | GoesOnWrist
+    | GoesOnLegs
+    | GoesOnSpecial
+    deriving (Eq,Ord,Show)
 _itUseAimStance :: Item -> AimStance
 _itUseAimStance = _aimStance . _useAim . _itUse
 data ItemConsumption
@@ -1288,3 +1306,4 @@ makeLenses ''Beam
 makeLenses ''BeamType
 makeLenses ''WorldBeams
 makeLenses ''ArcStep
+makeLenses ''CreatureEquipment

src/Dodge/Default.hs

@@ -46,6 +46,14 @@ defaultCreature = Creature
     , _crCorpse = setLayer BottomLayer $ setDepth 5 $ color (greyN 0.5) $ circleSolid 10
     , _crApplyDamage = defaultApplyDamage
     , _crPastDamage = 0
+    , _crEquipment = CreatureEquipment 
+        {_onHead    = Nothing'
+        ,_onChest   = Nothing'
+        ,_onBack    = Nothing'
+        ,_onWristL  = Nothing'
+        ,_onWristR  = Nothing'
+        ,_onLegs    = Nothing'
+        }
     , _crStance = Stance 
         {_carriage=Walking 0 WasLeftForward
         ,_posture=AtEase
@@ -156,7 +164,10 @@ defaultEquipment = Item
     , _itInvPos = Nothing
     , _itDimension = defItDimCol yellow
     , _itConsumption = NoConsumption
-    , _itUse = EquipUse {_eqUse = \_ _ -> id}
+    , _itUse = EquipUse 
+        {_eqUse = \_ _ -> id
+        ,_eqSite = GoesOnSpecial
+        }
     , _itScroll = \ _ _ -> id
     , _itAttachment = NoItAttachment
     , _itParams = NoParams

src/Dodge/Item/Equipment.hs

@@ -19,7 +19,7 @@ magShield :: Item
 magShield = defaultEquipment
     { _itType = MAGSHIELD
     , _itName = "MAGSHIELD"
-    , _itUse = EquipUse useMagShield
+    , _itUse = EquipUse useMagShield GoesOnWrist
     , _itEquipPict = \_ _ -> (,) emptySH blank
     , _itID = Nothing
     , _itAttachment = ItMInt Nothing
@@ -38,11 +38,14 @@ useMagShield cr invid w = w & magnets . at mgid ?~ themagnet
         Nothing -> IM.newKey $ _magnets w
     it = _crInv cr IM.! invid
 
-
 flameShield :: Item 
 flameShield = defaultEquipment
     { _itType = FLAMESHIELD
     , _itName = "FLAMESHIELD"
+    , _itUse = EquipUse 
+        {_eqUse = \_ _ -> id
+        ,_eqSite = GoesOnChest
+        }
     , _itEquipPict = \cr _ -> (,) emptySH $ setDepth 20 $ pictures [color cyan $ circle (_crRad cr+2)]
     , _itID = Nothing
     }
@@ -51,6 +54,10 @@ frontArmour :: Item
 frontArmour = defaultEquipment
     { _itType = FRONTARMOUR
     , _itName = "FARMOUR"
+    , _itUse = EquipUse 
+        {_eqUse = \_ _ -> id
+        ,_eqSite = GoesOnChest
+        }
 --    , _itFloorPict = \_ -> (,) emptySH $ onLayer FlItLayer $ translate 0 (-5) $ pictures 
 --        [color (greyN 0.1) $ thickArc 0        (pi/2) 10 5
 --        ,color (greyN 0.1) $ thickArc (3*pi/2) (2*pi) 10 5
@@ -65,7 +72,7 @@ frontArmour = defaultEquipment
 flatShield :: Item
 flatShield = defaultEquipment
     { _itEquipPict = pictureWeaponAim flatShieldEquipSPic
-    , _itEffect = effectOnOffEquip createShieldWall removeShieldWall
+    , _itEffect = effectOnOffHeld createShieldWall removeShieldWall
         -- the above seems to work, but I am not sure why: it may break on edge
         -- cases
     , _itName   = "FLATSHIELD"
@@ -150,11 +157,11 @@ removeShieldWall cr invid w = case _itEffectID $ _itEffect it of
     crid = _crID cr
     it = _crInv (_creatures w IM.! crid) IM.! invid
 
-effectOnOffEquip 
+effectOnOffHeld 
-    :: (Creature -> Int -> World -> World)     -- ^ effect when equiped
+    :: (Creature -> Int -> World -> World)     -- ^ effect when held
-    -> (Creature -> Int -> World -> World)     -- ^ effect when not equiped
+    -> (Creature -> Int -> World -> World)     -- ^ effect when not held
     -> ItEffect
-effectOnOffEquip f f' = ItInvEffectID
+effectOnOffHeld f f' = ItInvEffectID
     { _itInvEffect = g
     , _itEffectID = Nothing
     }

src/Dodge/Item/Weapon/SonicGuns.hs

@@ -112,15 +112,15 @@ mvSonicWave w pt
     dosplit :: [Maybe ((Point2,Float),(Bool,Bool))] -> [[(Point2,Float)]]
     dosplit (x:xs) = case x of
         Nothing -> [] : dosplit xs
-        Just (pair,(True,True))  -> onHead (pair:) $ dosplit xs
+        Just (pair,(True,True))  -> overHead (pair:) $ dosplit xs
-        Just (pair,(False,True)) -> [] : onHead (pair:) (dosplit xs)
+        Just (pair,(False,True)) -> [] : overHead (pair:) (dosplit xs)
         Just (pair,(True,False)) -> [pair] : dosplit xs
         Just (_,(False,False)) -> [] : dosplit xs
     dosplit [] = [[]]
 
-onHead :: (a -> a) -> [a] -> [a]
+overHead :: (a -> a) -> [a] -> [a]
-onHead f (x:xs) = f x: xs
+overHead f (x:xs) = f x: xs
-onHead _ [] = []
+overHead _ [] = []
         
         
 reflectShockLine :: Wall -> Point2 -> Point2 -> Point2 -> Maybe ((Point2,Float),(Bool,Bool))