Improve possible manipulation of equipment

src/Dodge/Combine/Data.hs

@@ -78,6 +78,8 @@ data CombineType
     | MAGSHIELD
     | FLAMESHIELD
     | FRONTARMOUR
+    | WRISTARMOUR
+    | BRAINHAT
     | POWERLEGS
     | SPEEDLEGS
     | JUMPLEGS

src/Dodge/Creature.hs

@@ -174,14 +174,14 @@ inventoryA = IM.fromList $ zip [0..]
 testInventory :: IM.IntMap Item
 testInventory = IM.fromList $ zip [0..] 
     [ makeTypeCraftNum 9 PIPE
+    , brainHat
     , autoSonar
     , autoRadar
     , magShield
     , frontArmour
-    , flameShield
+    , wristArmour
+    , flatShield
     , makeTypeCraftNum 1 MOTOR
-    , speedLegs
-    , jumpLegs
     , makeModule INCENDIARYMODULE
     , makeModule STATICMODULE
     , makeModule CONCUSSMODULE

src/Dodge/Creature/HandPos.hs

@@ -1,9 +1,9 @@
 module Dodge.Creature.HandPos where
 import Dodge.Data
 import Dodge.Creature.Test
-import Shape
+--import Shape
 import ShapePicture
-import Geometry
+--import Geometry
 
 import Control.Lens
 import Data.Maybe
@@ -65,12 +65,23 @@ translateToRightLeg cr = rotateSP (_crMvDir cr - _crDir cr) . case cr ^? crStanc
     Just (Walking sa RightForward) -> translateSPf ( f sa) (-off)
     _ -> translateSPf 0 (-off)
   where
-    aFoot :: Shape
-    aFoot = upperPrismPoly 10 $ polyCirc 3 4
     off = 5
     sLen = _strideLength $ _crStance cr
     f i = 6 * fromIntegral (sLen - i) / fromIntegral sLen
 
+translateToHead :: Creature -> SPic -> SPic
+translateToHead cr
+    | twists cr = translateSPz 20 . translateSPf 0 5 . rotateSP (-1) . translateSPf (negate 2.5) 0.25 
+    | oneH   cr = translateSPz 20 . rotateSP 0.5 . translateSPf 2.5 0 
+    | otherwise = translateSPz 20 . translateSPf 2.5 0 
+
+translateToChest :: Creature -> SPic -> SPic
+translateToChest cr
+    | oneH cr   = rotateSP 0.5
+--    | twists cr = translateSPf 0 5 . rotateSP (-1)
+    | twists cr = rotateSP (-1)
+    | otherwise = id
+
 oneH :: Creature -> Bool
 oneH = crInStance OneHand
 

src/Dodge/Creature/Picture.hs

@@ -184,9 +184,9 @@ arms cr = fst $ translateToRightHand cr aHand
   where
     aHand :: SPic
     aHand = noPic $ translateSHz (-4) . upperPrismPolyHalf 4 $ polyCirc 3 4
-    off = 8
+--    off = 8
-    sLen = _strideLength $ _crStance cr
+--    sLen = _strideLength $ _crStance cr
-    f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
+--    f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
 
 scalp :: Creature -> Shape
 {-# INLINE scalp #-}
@@ -209,8 +209,8 @@ crInStance as cr = crIsAiming' cr -- || (_posture (_crStance cr) == Reloading &&
 oneH :: Creature -> Bool
 oneH = crInStance OneHand
 
-twoFlat :: Creature -> Bool
+--twoFlat :: Creature -> Bool
-twoFlat = crInStance TwoHandFlat
+--twoFlat = crInStance TwoHandFlat
 
 twists :: Creature -> Bool
 twists = crInStance TwoHandTwist
@@ -248,8 +248,8 @@ upperBody col cr = colorSH (light4 col) $ mconcat
 
 shoulderSH :: Shape -> Shape
 shoulderSH = translateSHz 20
-waistSH :: Shape -> Shape
+--waistSH :: Shape -> Shape
-waistSH = translateSHz 10
+--waistSH = translateSHz 10
 
 light4 :: Color -> Color
 light4 = light . light . light . light

src/Dodge/Creature/Property.hs

@@ -4,6 +4,7 @@ module Dodge.Creature.Property
     , crNearPoint
     ) where
 import Dodge.Data
+import Dodge.Creature.HandPos
 import Geometry
 
 import Data.Maybe
@@ -13,18 +14,21 @@ import Control.Lens
 -- previous frame
 -- Not sure if it is a good idea
 crIsArmouredFrom :: Point2 -> Creature -> Bool
-crIsArmouredFrom p cr 
+crIsArmouredFrom p cr = hasFrontArmour p cr
-    = p /= _crOldPos cr 
-        -- && any (\it -> it ^? itType == Just FRONTARMOUR) (_crInv cr)
-        && hasFrontArmour cr
-        && angleVV (unitVectorAtAngle $ _crDir cr) (p -.- _crOldPos cr) < pi/2
--- even though angleVV can generate NaN, the comparison seems to deal with it
 
-hasFrontArmour :: Creature -> Bool
+hasFrontArmour :: Point2 -> Creature -> Bool
-hasFrontArmour cr = fromMaybe False $ do
+hasFrontArmour p cr = fromMaybe False $ do
     invid <- cr ^? crEquipment . ix OnChest
     ittype <- cr ^? crInv . ix invid . itType
     return $ FRONTARMOUR == ittype
+        && p /= _crOldPos cr 
+        && angleVV (unitVectorAtAngle (_crDir cr + frontarmdirection)) (p -.- _crOldPos cr) < pi/2
+-- even though angleVV can generate NaN, the comparison seems to deal with it
+  where
+    frontarmdirection
+        | crInStance OneHand cr = 0.5
+        | crInStance TwoHandTwist cr = negate 1
+        | otherwise = 0
 
 --crOnSeg :: Point2 -> Point2 -> Creature -> Bool
 --crOnSeg p1 p2 cr = circOnSeg p1 p2 (_crPos cr) (_crRad cr)

src/Dodge/Data.hs

@@ -383,6 +383,8 @@ data ItemUse
         }
     | EquipUse
         { _eqUse        :: Creature -> Int -> World -> World
+        , _eqOnEquip    :: Creature -> Int -> World -> World
+        , _eqOnRemove   :: Creature -> Int -> World -> World
         , _eqSite       :: EquipSite
         }
     | NoUse

src/Dodge/Default.hs

@@ -160,6 +160,8 @@ defaultEquipment = Item
     , _itConsumption = NoConsumption
     , _itUse = EquipUse 
         {_eqUse = \_ _ -> id
+        ,_eqOnEquip = \_ _ -> id
+        ,_eqOnRemove = \_ _ -> id
         ,_eqSite = GoesOnSpecial
         }
     , _itScroll = \ _ _ -> id

src/Dodge/Item/Equipment.hs

@@ -20,11 +20,12 @@ magShield :: Item
 magShield = defaultEquipment
     { _itType = MAGSHIELD
     , _itName = "MAGSHIELD"
-    , _itUse = EquipUse useMagShield GoesOnWrist
     , _itEquipPict = \_ _ -> (,) emptySH blank
     , _itID = Nothing
     , _itAttachment = ItMInt Nothing
     }
+    & itUse . eqUse .~ useMagShield 
+    & itUse . eqSite .~ GoesOnWrist
 useMagShield :: Creature -> Int -> World -> World
 useMagShield cr invid w = w & magnets . at mgid ?~ themagnet
   where
@@ -43,29 +44,42 @@ 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
-    }
+    } & itUse . eqSite .~ GoesOnChest
 {- | Slows you down, blocks forward projectiles. -}
 frontArmour :: Item
 frontArmour = defaultEquipment
     { _itType = FRONTARMOUR
     , _itName = "FARMOUR"
-    , _itUse = EquipUse 
-        {_eqUse = \_ _ -> id
-        ,_eqSite = GoesOnChest
-        }
     , _itEquipPict = pictureOnEquip (emptySH , setDepth 20 $ pictures
-        [color (greyN 0.1) $ thickArc 0        (pi/2) 10 5
+        [color thecol $ thickArc 0        (pi/2) 10 5
-        ,color (greyN 0.1) $ thickArc (3*pi/2) (2*pi) 10 5
+        ,color thecol $ thickArc (3*pi/2) (2*pi) 10 5
         ])
     , _itEffect = NoItEffect
     , _itID = Nothing
     }
+    & itUse . eqSite .~ GoesOnChest
+  where
+    thecol = yellow -- (greyN 0.1)
+
+wristArmour :: Item
+wristArmour = defaultEquipment
+    { _itType = WRISTARMOUR
+    , _itName = "WRISTARMOUR"
+    , _itEquipPict = spicForWrist (emptySH , setDepth 20 $ pictures
+        [color thecol $ thickArc 0        (pi/2) 10 5
+        ,color thecol $ thickArc (3*pi/2) (2*pi) 10 5
+        ])
+    , _itEffect = NoItEffect
+    , _itID = Nothing
+    }
+    & itUse . eqSite .~ GoesOnWrist
+  where
+    thecol = yellow -- (greyN 0.1)
+
+spicForWrist :: SPic -> Creature -> Item -> SPic
+spicForWrist = pictureOnEquip . translateSP (V3 0 4 (-4))
 pictureOnEquip :: SPic -> Creature -> Item -> SPic
 pictureOnEquip sp cr itm = fromMaybe mempty $ do
     i <- _itInvPos itm
@@ -77,6 +91,8 @@ equipPosition epos cr sh = case epos of
     OnRightWrist -> translateToRightHand cr $ mirrorSPxz sh
     OnLegs -> translateToLeftLeg cr sh <> 
         translateToRightLeg cr (mirrorSPxz sh)
+    OnHead -> translateToHead cr sh
+    OnChest -> translateToChest cr sh
     _ -> sh
 
 flatShield :: Item
@@ -191,20 +207,27 @@ jetPack = defaultEquipment
         $ pictures [color yellow $ polygon $ rectNSEW 5 (-5) (-3) (-11) ]
     , _itEffect = NoItEffect
     , _itID = Nothing
+    }   & itUse . eqSite .~ GoesOnBack
+
+brainHat :: Item
+brainHat = defaultEquipment
+    { _itType = BRAINHAT
+    , _itName = "BRAINHAT"
+    , _itEquipPict = pictureOnEquip (noPic $ colorSH yellow $ upperPrismPoly 3 $ rectWH 4 4)
+    , _itEffect = NoItEffect
+    , _itID = Nothing
     }
+    & itUse . eqSite .~ GoesOnHead
 
 powerLegs :: Item
 powerLegs = defaultEquipment
     { _itType = POWERLEGS
     , _itName = "POWERLEGS"
-    , _itUse = EquipUse 
-        {_eqUse = \_ _ -> id
-        ,_eqSite = GoesOnLegs
-        }
     , _itEquipPict = pictureOnEquip (noPic $ translateSH (V3 0 4 0) $ colorSH yellow $ upperPrismPoly 3 $ rectWH 2 2)
     , _itEffect = NoItEffect
     , _itID = Nothing
     }
+    & itUse . eqSite .~ GoesOnLegs
 speedLegs :: Item
 speedLegs = powerLegs
     { _itType = SPEEDLEGS

src/ShapePicture.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE TupleSections #-}
 module ShapePicture
     ( emptyBlank
+    , translateSP
     , translateSPf
     , translateSPz
     , rotateSP
@@ -41,6 +42,9 @@ translateSPf x y = bimap (translateSH (V3 x y 0)) (translate x y)
 translateSPz :: Float -> SPic -> SPic
 translateSPz z  = bimap (translateSH (V3 0 0 z)) (translate3 (V3 0 0 z))
 
+translateSP :: Point3 -> SPic -> SPic
+translateSP v = bimap (translateSH v) (translate3 v)
+
 rotateSP :: Float -> SPic -> SPic
 rotateSP a = bimap (rotateSH a) (rotate a)