Tweak led attachment orientation

src/Dodge/Item/Draw.hs

@@ -2,6 +2,7 @@
 
 module Dodge.Item.Draw (itemEquipPict) where
 
+import Dodge.Item.Draw.SPicTree
 import Control.Lens
 import Dodge.Creature.HandPos
 import Dodge.Data.ComposedItem

src/Dodge/Item/Draw/SPic.hs

@@ -1,34 +1,18 @@
 {-# LANGUAGE LambdaCase #-}
 
-module Dodge.Item.Draw.SPic (
-    itemSPic,
-    itemTreeSPic,
-) where
+module Dodge.Item.Draw.SPic (itemSPic) where
 
 import Color
 import Data.Maybe
 import Data.Strict.Tuple
-import Dodge.Data.ComposedItem
-import Dodge.Data.DoubleTree
 import Dodge.Data.Item
 import Dodge.Item.MaxAmmo
-import Dodge.Item.Orientation
 import Geometry
 import LensHelp
-import qualified Linear.Quaternion as Q
---import qualified Linear.Quaternion as Q
 import Picture
 import Shape
 import ShapePicture
 
-itemTreeSPic :: DTree CItem -> SPic
-itemTreeSPic (DT (itm, _) l r) = itemSPic itm <> foldMap (itemRotTreeSPic itm) (l <> r)
-
-itemRotTreeSPic :: Item -> DTree CItem -> SPic
-itemRotTreeSPic par t = translateSP p . overPosSP (Q.rotate q) $ itemTreeSPic t
-  where
-    (p, q) = orientAttachment par itm
-    itm = t ^. dtValue
 
 itemSPic :: Item -> SPic
 itemSPic it = case it ^. itType of

src/Dodge/Item/Orientation.hs

@@ -3,6 +3,10 @@ module Dodge.Item.Orientation (
     propagateOrientation,
 ) where
 
+import Shape.Data
+import Control.Lens
+import Linear
+import Dodge.Item.Draw.SPic
 import Dodge.Data.ComposedItem
 import Dodge.Data.DoubleTree
 import Dodge.Data.Item
@@ -12,7 +16,8 @@ import qualified Quaternion as Q
 
 orientChild :: Item -> Point3Q
 orientChild itm = case _itType itm of
-    HELD LED -> (V3 0 5 0, Q.qID)
+    --HELD LED -> (V3 0 5 0, Q.qID)
+    HELD LED -> (V3 (-x) (y-1) 0, Q.qID)
     --HELD LASER -> (V3 15 (-5) 0, Q.qID)
     LASER -> (V3 15 (-5) 0, Q.qID)
     ATTACH UNDERBARRELSLOT -> (V3 10 (-8) 0, r)
@@ -20,18 +25,35 @@ orientChild itm = case _itType itm of
   where
     --r = Q.axisAngle (V3 0 0 1) (-pi/4)
     r = Q.qID
+    y = itemShapeY itm
+    x = itemShapeX itm
 
 orientByParentChSF :: Item -> ItemSF -> Point3Q
 orientByParentChSF itm lt = case (_itType itm, lt) of
     (HELD FLAMETHROWER, AmmoMagSF{}) -> (V3 4 (-6) 0, Q.qID)
     (HELD _, AmmoMagSF{}) -> (V3 7 (-4) 0, Q.qID)
     (HELD _, WeaponScopeSF) -> (V3 5 0 5, Q.qID)
+    (HELD _, TorchSF) -> (V3 x y 5, Q.qID)
     _ -> (0, Q.qID)
+  where
+    x = itemShapeX itm
+    y = itemShapeY itm
+
+itemShapeX :: Item -> Float
+itemShapeX = f . (^. _1) . itemSPic
+  where
+    f = maximum . fmap (\sf -> maximum $ fmap (^. _1) (sf ^. sfVs))
+
+itemShapeY :: Item -> Float
+itemShapeY = f . (^. _1) . itemSPic
+  where
+    f = maximum . fmap (\sf -> maximum $ fmap (^. _2) (sf ^. sfVs))
 
 orientAttachment :: Item -> CItem -> Point3Q
 orientAttachment par (ch,chsf) = case (_itType par, chsf) of
     (ATTACH UNDERBARRELSLOT, _) -> (V3 (-5) (-8) 0, Q.qID)
     (_,LaserWeaponSF) -> (V3 2 8 0, Q.qID)
+--    (_,TorchSF) -> (V3 2 8 0, Q.qID)
     --    (HELD BURSTRIFLE, _, HELD TORCH) -> (V3 20 0 0, Q.axisAngle (V3 0 0 1) (pi/2))
     --    (HELD LAUNCHER, _, HELD TORCH) -> (V3 0 20 0, Q.axisAngle (V3 0 0 1) (pi/4))
     _ -> (t1 + Q.rotate q1 t2, q1 * q2)