Working (but slow) shadow shapes

src/Dodge/Creature/Picture.hs

@@ -22,6 +22,8 @@ import Dodge.Item.Data
 import Dodge.Clock
 import Picture
 import Geometry
+import Shape
+import ShapePicture
 --import Geometry.Vector3D
 
 import Control.Lens
@@ -32,11 +34,10 @@ basicCrPict
     :: Color    -- ^ Creature color
     -> Creature 
     -> World
-    -> Picture
-basicCrPict col cr w = pictures $
+    -> SPic
+basicCrPict col cr w = SPic (basicCrShape col cr w) $ pictures $
     targetingPic ++
-    [ tr . dm . rotdir $ scalp cr
-    , tr . dm . rotdir $ upperBody col cr
+    [ tr . dm . rotdir $ upperBody col cr
     , tr . dm . rotmdir $ feet cr
     , tr . rotdir $ drawEquipment cr
     , creatureDisplayText w cr
@@ -51,6 +52,24 @@ basicCrPict col cr w = pictures $
         . setDepth 1 
         . color (greyN 0.3)
 
+basicCrShape 
+    :: Color    -- ^ Creature color
+    -> Creature 
+    -> World
+    -> Shape
+basicCrShape col cr w = mconcat
+    [ tr . translateSHz 25 . dm . rotdir $ scalp cr
+    ]
+  where 
+    dm = damageModSH cr
+    targetingPic = IM.elems $ IM.mapMaybeWithKey f $ _crInv cr
+    f invid it = fmap ((\g -> g invid it cr w) . snd) (it ^? itTargeting . _Just)
+    tr = uncurryV translateSHf (_crPos cr)
+    rotdir = rotateSH (_crDir cr)
+    rotmdir = rotate (_crMvDir cr)
+        . setDepth 1 
+        . color (greyN 0.3)
+
 creatureDisplayText :: World -> Creature -> Picture
 creatureDisplayText w cr 
     = setLayer 4 
@@ -109,6 +128,8 @@ damageMod cr pic = piercingMod $ bluntScale pic
     piercingMod = case fmap argV piercingDam of
         Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a)
         _   -> id
+damageModSH :: Creature -> Shape -> Shape
+damageModSH cr = id
 
 feet :: Creature -> Picture
 feet cr = case cr ^? crStance . carriage of
@@ -148,14 +169,14 @@ arms cr
     sLen = _strideLength $ _crStance cr
     f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
 
-scalp :: Creature -> Picture
+scalp :: Creature -> Shape
 scalp cr
-    | twists cr = translate 0 (0.5*crad) . rotate (-1) $ translate (negate 0.25 * crad) 0.25 fhead
-    | oneH   cr = rotate 0.5 $ translate (0.25 * crad) 0 fhead
-    | otherwise = translate (0.25 * crad) 0 fhead
+    | twists cr = translateSHf 0 (0.5*crad) . rotateSH (-1) $ translateSHf (negate 0.25 * crad) 0.25 fhead
+    | oneH   cr = rotateSH 0.5 $ translateSHf (0.25 * crad) 0 fhead
+    | otherwise = translateSHf (0.25 * crad) 0 fhead
     
   where
-    fhead = setDepth 22 $ circleSolid $ crad * 0.5
+    fhead = colorSH (greyN 0.9) . prismPoly 5 . polyCirc $ crad * 0.5
     crad = _crRad cr
 
 oneH :: Creature -> Bool
@@ -232,10 +253,10 @@ drawEquipment cr = pictures $ map f $ IM.toList (_crInv cr)
 circLine :: Float -> Picture
 circLine x = line [V2 0 0,V2 x 0]
 
-picAtCrPos :: Picture -> Creature -> World -> Picture
+picAtCrPos :: Picture -> Creature -> World -> SPic
 --{-# INLINE picAtCrPos #-}
-picAtCrPos thePic cr _ = tranRot (_crPos cr) (_crDir cr) thePic
+picAtCrPos thePic cr _ = SPic empty $ tranRot (_crPos cr) (_crDir cr) thePic
 
-picAtCrPosNoRot :: Picture -> Creature -> World -> Picture
+picAtCrPosNoRot :: Picture -> Creature -> World -> SPic
 --{-# INLINE picAtCrPos #-}
-picAtCrPosNoRot thePic cr _ = uncurryV translate (_crPos cr) thePic
+picAtCrPosNoRot thePic cr _ = SPic empty $ uncurryV translate (_crPos cr) thePic