Improve possible manipulation of equipment

2022-05-23 10:18:36 +01:00
parent 295c50f0d9
commit 46123de69c
9 changed files with 88 additions and 40 deletions
@@ -78,6 +78,8 @@ data CombineType
    | MAGSHIELD
    | FLAMESHIELD
    | FRONTARMOUR
+    | WRISTARMOUR
+    | BRAINHAT
    | POWERLEGS
    | SPEEDLEGS
    | JUMPLEGS
@@ -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
@@ -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

@@ -184,9 +184,9 @@ arms cr = fst $ translateToRightHand cr aHand
  where
    aHand :: SPic
    aHand = noPic $ translateSHz (-4) . upperPrismPolyHalf 4 $ polyCirc 3 4
-    off = 8
-    sLen = _strideLength $ _crStance cr
-    f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
+--    off = 8
+--    sLen = _strideLength $ _crStance cr
+--    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 = crInStance TwoHandFlat
+--twoFlat :: Creature -> Bool
+--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 = translateSHz 10
+--waistSH :: Shape -> Shape
+--waistSH = translateSHz 10

 light4 :: Color -> Color
 light4 = light . light . light . light
@@ -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 
-    = 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
+crIsArmouredFrom p cr = hasFrontArmour p cr

-hasFrontArmour :: Creature -> Bool
-hasFrontArmour cr = fromMaybe False $ do
+hasFrontArmour :: Point2 -> Creature -> Bool
+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)
@@ -382,8 +382,10 @@ data ItemUse
        { _cUse :: Item -> Creature -> World -> World
        }
    | EquipUse
-        { _eqUse :: Creature -> Int -> World -> World
-        , _eqSite :: EquipSite
+        { _eqUse        :: Creature -> Int -> World -> World
+        , _eqOnEquip    :: Creature -> Int -> World -> World
+        , _eqOnRemove   :: Creature -> Int -> World -> World
+        , _eqSite       :: EquipSite
        }
    | NoUse
 data EquipSite
@@ -160,6 +160,8 @@ defaultEquipment = Item
    , _itConsumption = NoConsumption
    , _itUse = EquipUse 
        {_eqUse = \_ _ -> id
+        ,_eqOnEquip = \_ _ -> id
+        ,_eqOnRemove = \_ _ -> id
        ,_eqSite = GoesOnSpecial
        }
    , _itScroll = \ _ _ -> id
@@ -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 (greyN 0.1) $ thickArc (3*pi/2) (2*pi) 10 5
+        [color thecol $ thickArc 0        (pi/2) 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
@@ -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)