Allow for assigning attach items orientations

src/Dodge/Creature/Picture.hs

@@ -173,4 +173,4 @@ shoulderSH = translateSHz 20
 
 drawEquipment :: Creature -> SPic
 {-# INLINE drawEquipment #-}
-drawEquipment cr = foldMap (itemEquipPict cr) (invLDT $ _crInv cr)
+drawEquipment cr = foldMap (itemEquipPict cr) (invLDT' $ _crInv cr)

src/Dodge/Data/ComposedItem.hs

@@ -41,8 +41,9 @@ data ItemStructuralFunction
     deriving (Eq, Ord, Show, Read)
 
 type PartiallyComposedItem lt = (Item, ItemStructuralFunction, LinkTest lt)
+type ComposedItem = (Item, ItemStructuralFunction)
 
-data ItemAttachment = IAttach
+data ItemLink = ILink
     { _iatType :: ComposeLinkType
     , _iatOrient :: Item -> Item -> Maybe (Point3, Quaternion Float)
     }
@@ -58,6 +59,7 @@ data LinkUpdate lt = LUpdate
     , _luChildUpdate :: PartiallyComposedItem lt -> PartiallyComposedItem lt
     }
 
+makeLenses ''ItemLink
 makeLenses ''LinkTest
 makeLenses ''LinkUpdate
 deriveJSON defaultOptions ''ComposeLinkType

src/Dodge/Data/DoubleTree.hs

@@ -49,6 +49,11 @@ instance Foldable DoubleTree where
 instance Functor (LabelDoubleTree b) where
     fmap f (LDT x l r) = LDT (f x) (fmap (second $ fmap f) l) (fmap (second $ fmap f) r)
 
+instance Bifunctor LabelDoubleTree where
+    second = fmap
+    first f (LDT x l r) = LDT x (map (first f . second (first f)) l)
+        (map (first f . second (first f)) r)
+
 makeLenses ''DoubleTree
 makeLenses ''LabelDoubleTree
 deriveJSON defaultOptions ''DoubleTree

src/Dodge/Item/Draw.hs

@@ -16,7 +16,7 @@ import Dodge.Item.Draw.SPic
 import Dodge.Item.HeldOffset
 import ShapePicture
 
-itemEquipPict :: Creature -> LabelDoubleTree ComposeLinkType (PartiallyComposedItem ComposeLinkType)
+itemEquipPict :: Creature -> LabelDoubleTree ComposeLinkType ComposedItem
     -> SPic
 itemEquipPict cr itmtree = case itm ^. itUse of
     UseHeld{} | itm ^? itLocation . ilIsRoot == Just True 

src/Dodge/Item/Draw/SPic.hs

@@ -26,7 +26,7 @@ import ShapePicture
 --    hit <- itm ^? itType . iyBase . ibtHeld
 --    return mempty
 
-itemSPic :: LabelDoubleTree ComposeLinkType (PartiallyComposedItem ComposeLinkType) -> SPic
+itemSPic :: LabelDoubleTree ComposeLinkType ComposedItem -> SPic
 itemSPic itmtree = case it ^. itType of
     CRAFT _ -> defSPic
     HELD ht -> heldItemSPic ht it

src/Dodge/Item/Grammar.hs

@@ -1,5 +1,5 @@
 module Dodge.Item.Grammar (
-    invLDT,
+    invLDT',
     invTrees,
     invIndentIM,
     invAdj,
@@ -9,7 +9,7 @@ module Dodge.Item.Grammar (
 import qualified Linear.Quaternion as Q
 import Geometry.Data
 import Control.Applicative
---import TreeHelp
+import Data.Bifunctor
 
 import LensHelp
 import qualified Data.IntMap.Strict as IM
@@ -60,6 +60,53 @@ basePartiallyComposedItem itm = case itm ^. itType of
     nolinks x = (itm,x, LTest (const Nothing) (const Nothing))
     isolate = (itm,UncomposableIsolateSF, LTest (const Nothing) (const Nothing))
 
+basePartiallyComposedItem' :: Item -> PartiallyComposedItem ItemLink
+basePartiallyComposedItem' itm = case itm ^. itType of
+    HELD _ -> (itm, WeaponPlatformSF, useBreakListsLinkTest 
+        (map (\(i,a) -> (AmmoMagSF a, ILink (AmmoInLink i a) (c (V3 5 2 0) lhs)))
+            (IM.toList $ itm ^. itUse . heldAmmoTypes))
+        [noa WeaponTargetingSF WeaponTargetingLink, noa WeaponScopeSF WeaponScopeLink]
+        )
+    AMMOMAG _ -> ammoComposedItem' itm
+    TARGETING {} -> (itm,WeaponTargetingSF, useBreakListsLinkTest [noa AugmentedHUDSF AugmentedHUDLink] [])
+    ATTACH ZOOMSCOPE -> (itm,WeaponScopeSF, LTest (const Nothing) (const Nothing))
+    ATTACH HOMINGMODULE -> (itm,AmmoTargetingSF ProjectileAmmo, LTest (const Nothing) (const Nothing))
+    ATTACH AUGMENTEDHUD -> nolinks AugmentedHUDSF
+    BULLETMOD BulletModTrajectory {} -> nolinks $ AmmoTargetingSF BulletAmmo
+    BULLETMOD BulletModPayload {} -> nolinks $ AmmoPayloadSF BulletAmmo
+    BULLETMOD BulletModEffect {} -> nolinks $ AmmoEffectSF BulletAmmo
+    ATTACH REMOTESCREEN -> nolinks RemoteScreenSF
+    ATTACH BULLETSYNTHESIZER -> (itm,AmmoModifierSF BulletAmmo, LTest (const Nothing) (const Nothing))
+    LEFT {} -> isolate
+    EQUIP {} -> isolate
+    CONSUMABLE {} -> isolate
+    CRAFT {} -> isolate
+--    _ -> 
+  where
+    noa x y = (x, ILink y (const (const Nothing)))
+    c x y _ _ = Just (x,y)
+    lhs = Q.axisAngle (V3 1 0 0) pi
+--    rhs = Q.axisAngle (V3 1 0 0) 0
+    nolinks x = (itm,x, LTest (const Nothing) (const Nothing))
+    isolate = (itm,UncomposableIsolateSF, LTest (const Nothing) (const Nothing))
+
+ammoComposedItem' :: Item -> PartiallyComposedItem ItemLink
+ammoComposedItem' itm = fromMaybe (error "in ammoComposedItem, wrong item") $ do
+    atype <- itm ^? itUse . amagType
+    return (itm
+        , AmmoMagSF atype
+        , useBreakListsLinkTest 
+            [noa (AmmoModifierSF atype) AmmoModLink
+            ,noa (AmmoTargetingSF atype) AmmoTargetingLink
+            ,noa (AmmoPayloadSF atype) AmmoPayloadLink
+            ,noa (AmmoEffectSF atype) AmmoEffectLink
+            ,noa (RemoteScreenSF) RemoteScreenLink
+            ] 
+            []
+        )
+  where
+    noa x y = (x, ILink y (const (const Nothing)))
+
 ammoComposedItem :: Item -> PartiallyComposedItem ComposeLinkType
 ammoComposedItem itm = fromMaybe (error "in ammoComposedItem, wrong item") $ do
     atype <- itm ^? itUse . amagType
@@ -119,12 +166,21 @@ invLDT =
     joinItemsInList (leftRightCombine leftIsParentCombine rightIsParentCombine) . IM.elems
         . fmap (singleLDT . basePartiallyComposedItem)
 
+invLDT'' :: IM.IntMap Item -> [LabelDoubleTree ItemLink (PartiallyComposedItem ItemLink)]
+invLDT'' = 
+    joinItemsInList (leftRightCombine leftIsParentCombine rightIsParentCombine) . IM.elems
+        . fmap (singleLDT . basePartiallyComposedItem')
+
+invLDT' :: IM.IntMap Item -> [LabelDoubleTree ComposeLinkType ComposedItem]
+--invLDT' = map (fmap (\(x,y,_) -> (x,y))) . invLDT
+invLDT' = map (first _iatType . second (\(x,y,_) -> (x,y))) . invLDT''
+
 -- this assumes the creature inventory is well formed, specifically the
 -- location ids
 -- consider explicitly reseting the inventory ids (but this probably really
 -- should be done upstream anyway in the actually creature inventory)
 invRootMap :: IM.IntMap Item -> IM.IntMap (Maybe Int, DoubleTree Item)
-invRootMap = foldMap (dtToIntMapWithRoot (^?! itLocation . ilInvID) . fmap (^. _1) . ldtToDT) . invLDT
+invRootMap = foldMap (dtToIntMapWithRoot (^?! itLocation . ilInvID) . fmap (^. _1) . ldtToDT) . invLDT''
 
 --invRootMap = foldMap (dtToRootIntMap g . ldtToDT) . invLDT
 --  where
@@ -136,7 +192,7 @@ invRootMap = foldMap (dtToIntMapWithRoot (^?! itLocation . ilInvID) . fmap (^. _
 -- should be done upstream anyway in the actually creature inventory)
 invAdj :: IM.IntMap Item -> Either String (IM.IntMap (Maybe (Int, Int), [Int], [Int]))
 invAdj im = do
-    l <- mapM g $ invLDT im
+    l <- mapM g $ invLDT'' im
     return $ IM.unions l
   where
     g = dtToLRAdjEither getid . ldtToDT
@@ -148,11 +204,11 @@ invAdj im = do
 
 invIndentIM :: IM.IntMap Item -> IM.IntMap (Item, Int, LabelDoubleTreeNodeType ComposeLinkType)
 invIndentIM = IM.fromAscList . zip [0 ..] . reverse . map (over _1 (^. _1)) 
-    . concatMap ldtToIndentList . invLDT
+    . concatMap ldtToIndentList . invLDT'
 
 -- returns an intmap with trees for all items, including non-roots
 invTrees :: IM.IntMap Item -> IM.IntMap (LabelDoubleTree ComposeLinkType Item)
-invTrees = IM.unions . map (ldtToIM getindex . fmap (^. _1)) . invLDT
+invTrees = IM.unions . map (ldtToIM getindex . fmap (^. _1)) . invLDT'
   where
     getindex :: Item -> Int
     getindex i =

src/Dodge/Machine/Draw.hs

@@ -63,7 +63,7 @@ drawTurret :: Turret -> Machine -> SPic
 drawTurret tu mc = overPosSP (turretItemOffset itm tu mc) (itemSPic ittree)
   where
     itm = _tuWeapon tu
-    ittree = singleLDT (itm,UncomposableIsolateSF,LTest (const Nothing) (const Nothing))
+    ittree = singleLDT (itm,UncomposableIsolateSF)
 
 sensorSPic :: (PaletteColor, DecorationShape) -> Machine -> SPic
 sensorSPic (pc, ds) mc =

src/Dodge/Render/ShapePicture.hs

@@ -164,7 +164,7 @@ floorItemSPic :: FloorItem -> SPic
 floorItemSPic flit =
     uncurryV translateSPxy (_flItPos flit) $
         rotateSP (_flItRot flit) 
-            (itemSPic $ singleLDT ((_flIt flit),UncomposableIsolateSF,LTest (const Nothing) (const Nothing)))
+            (itemSPic $ singleLDT ((_flIt flit),UncomposableIsolateSF))
 
 btSPic :: Button -> SPic
 btSPic bt =