Allow shadow fidelity option, fix bug in rendering box shadows

src/Dodge/Creature/Impulse/UseItem.hs

@@ -1,6 +1,6 @@
 module Dodge.Creature.Impulse.UseItem (
     useItem,
-    useLeftItem,
+    doTopInvLeftClick,
     itemEffect,
 ) where
 
@@ -106,7 +106,7 @@ toggleEquipmentAt rbops invid cr w = case rbops ^? opAllocateEquipment of
             & crpoint . crEquipment . at oldp .~ Nothing
             & crpoint . crInvEquipped . at invid .~ Nothing
             & onremove itm cr
-    Nothing -> error "tried to toggle equipment whilst not prepared"
+    Nothing -> error "tried to toggle equipment when not prepared"
   where
     crpoint = cWorld . lWorld . creatures . ix (_crID cr)
     itmat i = _crInv cr IM.! i
@@ -115,27 +115,40 @@ toggleEquipmentAt rbops invid cr w = case rbops ^? opAllocateEquipment of
     onequip itm' = useE ((_eeOnEquip . _equipEffect . _itUse) itm') itm'
     onremove itm' = useE ((_eeOnRemove . _equipEffect . _itUse) itm') itm'
 
-useLeftItem :: Int -> World -> World
-useLeftItem cid w = fromMaybe w $ do
-    cr <- w ^? cWorld . lWorld . creatures . ix cid
+doTopInvLeftClick :: Creature -> World -> World
+doTopInvLeftClick cr w = fromMaybe w $ do
     guard . not $ _crInvLock cr
-    let mitRef = cr ^? crManipulation . manObject . inInventory . ispItem
-        itmIsConsumable = isJust $ do
-            itRef <- mitRef
-            cr ^? crInv . ix itRef . itUse . cUse
-        itmIsEquipable = isJust $ do
-            itRef <- mitRef
-            guard $ cr ^. crLeftInvSel . lisMPos == Just itRef
-            cr ^? crInv . ix itRef . itUse . equipEffect . eeUse
-    if itmIsConsumable || itmIsEquipable
-        then return $ useItem cr w -- I believe this ONLY sets equipment options
-        else do
-            invid <- cr ^. crLeftInvSel . lisMPos
-            itm <- cr ^? crInv . ix invid
-            f <- cr ^? crInv . ix invid . itUse . leftUse
-            return
-                . (runIdentity . pointerToItemLocation (_itLocation itm) (return . (itUse . leftHammer .~ HammerDown)))
-                . useL f itm cr
-                $ w
+    return $ doTopInvLeftClick' cr w
+
+doTopInvLeftClick' :: Creature -> World -> World
+doTopInvLeftClick' cr w = fromMaybe (doTopInvLeftClickSearch cr w) $ do
+    invid <- cr ^? crManipulation . manObject . inInventory . ispItem
+    ituse <- cr ^? crInv . ix invid . itUse
+    case ituse of
+        ConsumeUse{} -> return $ useItem cr w
+        EquipUse{} -> return $ useItem cr w
+        LeftUse{} -> return $ equipAndUse (_leftUseOnEquip ituse) invid cr w
+        _ -> Nothing
+
+equipAndUse :: Bool -> Int -> Creature -> World -> World
+equipAndUse useonequip invid cr w = case cr ^? crInvEquipped . ix invid of
+    Nothing | useonequip -> tryUseL (_crID cr) invid $ useItem cr w
+        | otherwise -> useItem cr w
+    _ -> tryUseL (_crID cr) invid w
+
+doTopInvLeftClickSearch :: Creature -> World -> World
+doTopInvLeftClickSearch cr w = fromMaybe w $ do
+    invid <- cr ^. crLeftInvSel . lisMPos
+    return $ tryUseL (_crID cr) invid w
+
+tryUseL :: Int -> Int -> World -> World
+tryUseL crid invid w = fromMaybe w $ do
+    cr <- w ^? cWorld . lWorld . creatures . ix crid
+    itm <- cr ^? crInv . ix invid
+    luse <- itm ^? itUse . leftUse
+    return $
+        w
+            & cWorld . lWorld . creatures . ix crid . crInv . ix invid . itUse . leftHammer .~ HammerDown
+            & useL luse itm cr
 
 -- TODO determine itmShouldBeUsed with reference to config options

src/Dodge/Creature/Picture.hs

@@ -68,35 +68,36 @@ feet cr = case cr ^? crStance . carriage of
             ]
   where
     aFoot :: Shape
-    aFoot = upperPrismPoly 10 $ polyCirc 3 4
+    aFoot = upperPrismPolyST 10 $ polyCirc 3 4
     off = 5
     sLen = _strideLength $ _crStance cr
     f i = 6 * fromIntegral (sLen - i) / fromIntegral sLen
 
 deadFeet :: Creature -> Shape
 {-# INLINE deadFeet #-}
-deadFeet cr = case cr ^? crStance . carriage of
-    Just (Walking sa LeftForward) ->
-        mconcat
-            [ translateSHxy (f sa) off aFoot
-            , translateSHxy (- f sa) (- off) aFoot
-            ]
-    Just (Walking sa RightForward) ->
-        mconcat
-            [ translateSHxy (- f sa) off aFoot
-            , translateSHxy (f sa) (- off) aFoot
-            ]
-    _ ->
-        mconcat
-            [ translateSHxy 0 off aFoot
-            , translateSHxy 0 (- off) aFoot
-            ]
-  where
-    aFoot :: Shape
-    aFoot = upperPrismPoly 3 $ polyCirc 3 4
-    off = 5
-    sLen = _strideLength $ _crStance cr
-    f i = 6 * fromIntegral (sLen - i) / fromIntegral sLen
+deadFeet = feet 
+--cr = case cr ^? crStance . carriage of
+--    Just (Walking sa LeftForward) ->
+--        mconcat
+--            [ translateSHxy (f sa) off aFoot
+--            , translateSHxy (- f sa) (- off) aFoot
+--            ]
+--    Just (Walking sa RightForward) ->
+--        mconcat
+--            [ translateSHxy (- f sa) off aFoot
+--            , translateSHxy (f sa) (- off) aFoot
+--            ]
+--    _ ->
+--        mconcat
+--            [ translateSHxy 0 off aFoot
+--            , translateSHxy 0 (- off) aFoot
+--            ]
+--  where
+--    aFoot :: Shape
+--    aFoot = upperPrismPolyT 3 $ polyCirc 3 4
+--    off = 5
+--    sLen = _strideLength $ _crStance cr
+--    f i = 6 * fromIntegral (sLen - i) / fromIntegral sLen
 
 arms :: Creature -> Shape
 {-# INLINE arms #-}
@@ -105,7 +106,7 @@ arms cr =
         translateToRightHand cr aHand
             <> translateToLeftHand cr aHand
   where
-    aHand = noPic $ translateSHz (-4) . upperPrismPolyHalf 4 $ polyCirc 3 4
+    aHand = noPic $ translateSHz (-4) . upperPrismPolyHalfST 4 $ polyCirc 3 4
 
 deadScalp :: Creature -> Shape
 deadScalp cr = deadRot cr . translateSHz 10 . scalp $ cr
@@ -126,7 +127,7 @@ scalp cr
     | oneH cr = rotateSH 0.5 $ translateSHxy 2.5 0 fhead
     | otherwise = translateSHxy 2.5 0 fhead
   where
-    fhead = colorSH (greyN 0.9) . upperPrismPolyHalf 5 $ polyCirc 3 5
+    fhead = colorSH (greyN 0.9) . upperPrismPolyHalfST 5 $ polyCirc 3 5
 
 torso :: Creature -> Shape
 {-# INLINE torso #-}
@@ -156,7 +157,7 @@ deadUpperBody cr = deadRot cr . translateSHz (negate 10) . upperBody $ cr
 
 baseShoulder :: Shape
 {-# INLINE baseShoulder #-}
-baseShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPolyHalf 10 $ polyCirc 3 1
+baseShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPolyHalfMI 10 $ polyCirc 3 1
 
 upperBody :: Creature -> Shape
 {-# INLINE upperBody #-}

src/Dodge/Creature/YourControl.hs

@@ -118,7 +118,7 @@ mouseActionsCr pkeys cr
 pressedMBEffectsTopInventory :: M.Map SDL.MouseButton Bool -> World -> World
 pressedMBEffectsTopInventory pkeys w
     | isDown SDL.ButtonLeft && isDown SDL.ButtonRight && inTopInv = useItem (you w) w
-    | isDown SDL.ButtonLeft && inTopInv = useLeftItem 0 w
+    | isDown SDL.ButtonLeft && inTopInv = doTopInvLeftClick (you w) w
     | isDown SDL.ButtonMiddle =
         w & cWorld . cwCamPos . camRot -~ rotation
             & input . clickMousePos .~ _mousePos (_input w)