Continue to refactor body/equipment positionings

2025-08-27 14:40:13 +01:00
parent 9d2a2e6730
commit 86696deb56
14 changed files with 151 additions and 189 deletions
@@ -1,14 +1,10 @@
 {-# LANGUAGE LambdaCase #-}
 module Dodge.Creature.HandPos (
+    equipSitePQ,
    translatePointToLeftHand,
    translatePointToRightHand,
-    translatePointToHead,
-    translateToLeftWrist,
-    translateToRightWrist,
    translateToLeftLeg,
    translateToRightLeg,
-    translateToHead,
-    translateToChest,
    translateToLeftHand,
    translateToRightHand,
    backPQ,
@@ -17,7 +13,6 @@ module Dodge.Creature.HandPos (
 ) where

 import Dodge.Data.Equipment.Misc
-import qualified Data.IntMap.Strict as IM
 import qualified Quaternion as Q
 import Control.Lens
 import Dodge.Creature.Test
@@ -35,11 +30,8 @@ equipSitePQ = \case
    OnHead -> headPQ
    OnChest -> chestPQ
    OnBack -> backPQ
-    OnLegs -> legsPQ
-
-legsPQ :: a
-legsPQ = undefined
-
+    OnLeftLeg -> leftLegPQ
+    OnRightLeg -> rightLegPQ

 translatePointToRightHand :: Creature -> Point3 -> Point3
 translatePointToRightHand cr p =  fst (rightHandPQ cr `Q.comp` (p,Q.qID))
@@ -70,10 +62,6 @@ rightHandPQ cr
 translateToRightHand :: Creature -> SPic -> SPic
 translateToRightHand = overPosSP . translatePointToRightHand

-translateToRightWrist :: Creature -> SPic -> SPic
-translateToRightWrist cr =  overPosSP
-    (\p -> fst $ rightHandPQ cr `Q.comp` (V3 0 (-4) (-4)+p, Q.qID))
-
 rightWristPQ :: Creature -> Point3Q
 rightWristPQ cr = rightHandPQ cr `Q.comp` (V3 0 (-4) (-4), Q.qID)

@@ -95,13 +83,10 @@ leftHandPQ cr
 translatePointToLeftHand :: Creature -> Point3 -> Point3
 translatePointToLeftHand cr p = fst (leftHandPQ cr `Q.comp` (p,Q.qID))

-translateToLeftHand :: IM.IntMap Item -> Creature -> SPic -> SPic
-translateToLeftHand m = overPosSP . translatePointToLeftHand
-
-translateToLeftWrist :: Creature -> SPic -> SPic
-translateToLeftWrist cr = overPosSP 
-    (\p -> fst $ leftHandPQ cr `Q.comp` (V3 0 4 (-4)+p, Q.qID))
+translateToLeftHand :: Creature -> SPic -> SPic
+translateToLeftHand = overPosSP . translatePointToLeftHand

+leftWristPQ :: Creature -> Point3Q
 leftWristPQ cr = leftHandPQ cr `Q.comp` (V3 0 4 (-4), Q.qID)

 leftLegPQ :: Creature -> Point3Q
@@ -135,24 +120,18 @@ rightLegPQ cr = Q.comp (0,Q.qz (_crMvDir cr - _crDir cr))
 translateToRightLeg :: Creature -> SPic -> SPic
 translateToRightLeg cr = overPosSP (\p -> fst (rightLegPQ cr `Q.comp` (p,Q.qID)))

-translateToHead :: IM.IntMap Item -> Creature -> SPic -> SPic
-translateToHead m cr = overPosSP (\p -> fst (headPQ cr `Q.comp` (p,Q.qID)))
-
 headPQ :: Creature -> Point3Q
 headPQ cr
    | twists cr = (V3 0 2 20, Q.qz (-1)) `Q.comp` (V3 (negate 2.5) 0.25 0, Q.qz 1)
    | oneH cr = (V3 0 0 20, Q.qz 0.5) `Q.comp` (V3 2.5 0 0, Q.qz (-0.5))
    | otherwise = (V3 2.5 0 20, Q.qID)

-translatePointToHead :: IM.IntMap Item -> Creature -> Point3 -> Point3
-translatePointToHead m cr p = fst (headPQ cr `Q.comp` (p,Q.qID))
+--translatePointToHead :: IM.IntMap Item -> Creature -> Point3 -> Point3
+--translatePointToHead m cr p = fst (headPQ cr `Q.comp` (p,Q.qID))

 chestPQ :: Creature -> Point3Q
 chestPQ cr = backPQ cr `Q.comp` (0,Q.qz pi)

-translateToChest :: IM.IntMap Item -> Creature -> SPic -> SPic
-translateToChest m cr = overPosSP (\p -> fst $ chestPQ cr `Q.comp` (p,Q.qID))
-
 backPQ :: Creature -> Point3Q
 backPQ cr
    | oneH cr = (V3 0 0 10, Q.qz 0.5)
@@ -9,6 +9,7 @@ module Dodge.Creature.Picture (
    deadFeet,
 ) where

+import Dodge.Data.Equipment.Misc
 import Dodge.Creature.HandPos
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
@@ -27,19 +28,19 @@ import Shape
 import ShapePicture

 basicCrPict :: IM.IntMap Item -> Creature -> SPic
-basicCrPict m cr = drawEquipment m cr <> noPic (basicCrShape m cr)
+basicCrPict m cr = drawEquipment m cr <> noPic (basicCrShape cr)

 crCamouflage :: Creature -> CamouflageStatus
 crCamouflage _ = FullyVisible

-basicCrShape :: IM.IntMap Item -> Creature -> Shape
-basicCrShape m cr
+basicCrShape :: Creature -> Shape
+basicCrShape cr
    | crCamouflage cr == Invisible = mempty
    | otherwise =
        scaleSH (V3 crsize crsize crsize) $
            mconcat
-                [ colorSH (_skinHead cskin) $ scalp m cr
-                , colorSH (_skinUpper cskin) $ upperBody m cr
+                [ colorSH (_skinHead cskin) $ scalp cr
+                , colorSH (_skinUpper cskin) $ upperBody cr
                , rotmdir $ colorSH (_skinLower cskin) $ feet cr
                ]
  where
@@ -68,17 +69,17 @@ deadFeet :: Creature -> Shape
 {-# INLINE deadFeet #-}
 deadFeet = feet

-arms :: IM.IntMap Item -> Creature -> Shape
+arms :: Creature -> Shape
 {-# INLINE arms #-}
-arms m cr =
+arms cr =
    (^. _1) $
        translateToRightHand cr aHand
-            <> translateToLeftHand m cr aHand
+            <> translateToLeftHand cr aHand
  where
    aHand = noPic $ translateSHz (-4) . upperPrismPolyHalfST 4 $ polyCirc 3 4

-deadScalp :: IM.IntMap Item -> Creature -> Shape
-deadScalp m cr = deadRot cr . translateSHz 10 . scalp m $ cr
+deadScalp :: Creature -> Shape
+deadScalp cr = deadRot cr . translateSHz 10 . scalp $ cr

 deadRot :: Creature -> Shape -> Shape
 deadRot cr = overPosSH (Q.rotateToZ d)
@@ -89,9 +90,9 @@ deadRot cr = overPosSH (Q.rotateToZ d)
            (addZ 0 . unitVectorAtAngle . subtract (_crDir cr + pi))
            (damageDirection $ _crDamage cr)

-scalp :: IM.IntMap Item -> Creature -> Shape
+scalp :: Creature -> Shape
 {-# INLINE scalp #-}
-scalp m cr = overPosSH (\p -> fst (headPQ cr `Q.comp` (p,Q.qID))) fhead
+scalp cr = overPosSH (translateToES cr OnHead) fhead
 --    | twists cr = translateSHxy 0 5 . rotateSH (-1) $ translateSHxy (negate 2.5) 0.25 fhead
 --    | oneH cr = rotateSH 0.5 $ translateSHxy 2.5 0 fhead
 --    | otherwise = translateSHxy 2.5 0 fhead
@@ -100,15 +101,7 @@ scalp m cr = overPosSH (\p -> fst (headPQ cr `Q.comp` (p,Q.qID))) fhead

 torso :: Creature -> Shape
 {-# INLINE torso #-}
-torso cr = overPosSH (\p -> fst (backPQ cr `Q.comp` (p,Q.qID))) tsh
--    | oneH cr = rotateSH 0.5 tsh
--    | twists cr =
--        translateSHxy 0 3 . rotateSH (-1.3) $ tsh
----            mconcat
----                [ rotateSH (negate 0.2) . translateSHxy 2 3 . rotateSH (negate 0.4) $ aShoulder
----                , rotateSH (negate 0.2) . translateSHxy 0 (negate 3) . rotateSH 0.2 $ aShoulder
----                ]
--    | otherwise = tsh
+torso cr = overPosSH (translateToES cr OnBack) tsh
  where
    tsh = 
        mconcat
@@ -117,20 +110,20 @@ torso cr = overPosSH (\p -> fst (backPQ cr `Q.comp` (p,Q.qID))) tsh
            ]
    aShoulder = scaleSH (V3 10 10 1) baseShoulder

-deadUpperBody :: IM.IntMap Item -> Creature -> Shape
-deadUpperBody m cr = deadRot cr . translateSHz (negate 10) . upperBody m $ cr
+deadUpperBody :: Creature -> Shape
+deadUpperBody cr = deadRot cr . translateSHz (negate 10) . upperBody $ cr

 baseShoulder :: Shape
 {-# INLINE baseShoulder #-}
 baseShoulder = translateSHz (-20) . scaleSH (V3 0.5 1 1) . upperPrismPolyHalfMI 10 $ polyCirc 3 1

-upperBody :: IM.IntMap Item -> Creature -> Shape
+upperBody :: Creature -> Shape
 {-# INLINE upperBody #-}
-upperBody m cr = arms m cr <> shoulderSH (torso cr)
+upperBody cr = arms cr <> shoulderSH (torso cr)

 shoulderSH :: Shape -> Shape
 shoulderSH = translateSHz 20

 drawEquipment :: IM.IntMap Item -> Creature -> SPic
 {-# INLINE drawEquipment #-}
-drawEquipment m cr = foldMap (itemEquipPict m cr) (invDT . fmap (\i -> m ^?! ix i) $ _crInv cr)
+drawEquipment m cr = foldMap (itemEquipPict cr) (invDT . fmap (\i -> m ^?! ix i) $ _crInv cr)
@@ -26,11 +26,9 @@ module Dodge.Creature.Test (

 import NewInt
 import qualified Data.IntMap.Strict as IM
-import Dodge.Item.Grammar
 import Dodge.Creature.Radius
 import Dodge.Data.Equipment.Misc
 import Dodge.Data.AimStance
-import Dodge.Item.AimStance
 import Control.Lens
 import Data.List (find)
 import Data.Maybe
@@ -107,7 +107,7 @@ corpseOrGib cr w = w & case cr ^? crDamage . to maxDamageType . _Just . _1 of
    _ -> addcorpse thecorpse
  where
    addcorpse ctype = plNew (cWorld . lWorld . corpses) cpID ctype
-    thecorpse = makeCorpse (w ^. cWorld . lWorld . items) cr
+    thecorpse = makeCorpse cr

 scorchSPic :: SPic -> SPic
 scorchSPic = _1 %~ overColSH (mixColors 0.9 0.1 black . normalizeColor)