Allow item structure to determine if subtree is attachable

src/Dodge/Data/ComposedItem.hs

@@ -5,6 +5,7 @@
 
 module Dodge.Data.ComposedItem where
 
+import Dodge.Data.DoubleTree
 import Control.Lens
 import Data.Aeson
 import Data.Aeson.TH
@@ -59,9 +60,11 @@ data ItemLink = ILink
     , _iatOrient :: Item -> ComposeLinkType -> Item -> (Point3, Quaternion Float)
     }
 
+-- this should possibly use a full item structure tree rather than a
+-- ComposedItem as arguments
 data LinkTest = LTest
-    { _tryLeftLink :: ComposedItem -> Maybe LinkUpdate
+    { _tryLeftLink :: LabelDoubleTree ItemLink ComposedItem -> Maybe LinkUpdate
-    , _tryRightLink :: ComposedItem -> Maybe LinkUpdate
+    , _tryRightLink :: LabelDoubleTree ItemLink ComposedItem -> Maybe LinkUpdate
     }
 
 data LinkUpdate = LUpdate

src/Dodge/Item/Grammar.hs

@@ -17,7 +17,7 @@ import Dodge.DoubleTree
 import Dodge.Item.Orientation
 import LensHelp
 import ListHelp
-import qualified Data.Set as S
+--import qualified Data.Set as S
 
 tryAttachItems ::
     LabelDoubleTree ItemLink ComposedItem ->
@@ -39,11 +39,11 @@ useBreakListsLinkTest ::
     LinkTest
 useBreakListsLinkTest llist rlist = LTest ltest rtest
   where
-    ltest (_, sf, _) = do
+    ltest (LDT (_, sf, _) _ _) = do
         let xs = dropWhile ((/= sf) . fst) llist
         (_, linktype) <- safeHead xs
         return $ LUpdate linktype (set _3 (useBreakListsLinkTest (tail xs) rlist)) id
-    rtest (_, sf, _) = do
+    rtest (LDT (_, sf, _) _ _) = do
         let xs = dropWhile ((/= sf) . fst) rlist
         (_, linktype) <- safeHead xs
         return $ LUpdate linktype (set _3 (useBreakListsLinkTest llist (tail xs))) id
@@ -127,10 +127,10 @@ itemToFunction itm = case itm ^. itType of
     ATTACH SHELLPAYLOAD{} -> AmmoPayloadSF LauncherAmmo
     _ -> NoSF
 
-structureToPotentialFunction 
+--structureToPotentialFunction 
-    :: LabelDoubleTree ComposedItem ItemLink 
+--    :: LabelDoubleTree ComposedItem ItemLink 
-    -> S.Set ItemStructuralFunction
+--    -> S.Set ItemStructuralFunction
-structureToPotentialFunction _ = mempty
+--structureToPotentialFunction _ = mempty
 
 baseCI :: Item -> ComposedItem
 baseCI itm = (itm, itemToFunction itm, itemBaseConnections itm)
@@ -144,14 +144,14 @@ itemBaseConnections itm = case _itType itm of
 laserLinkTest :: Item -> LinkTest
 laserLinkTest itm = LTest (llleft itm) (llright itm)
 
-llleft :: Item -> ComposedItem -> Maybe LinkUpdate
+llleft :: Item -> LabelDoubleTree ItemLink ComposedItem -> Maybe LinkUpdate
 llleft itm =
     _tryLeftLink
         . uncurry useBreakL
         $ itemToBreakLists itm WeaponTargetingSF
 
-llright :: Item -> ComposedItem -> Maybe LinkUpdate
+llright :: Item -> LabelDoubleTree ItemLink ComposedItem -> Maybe LinkUpdate
-llright itm pci = case pci ^. _1 . itType of
+llright itm pci = case pci ^. ldtValue . _1 . itType of
     CRAFT TRANSFORMER -> Just (toLasgunUpdate itm)
     _ -> _tryRightLink (uncurry useBreakL $ itemToBreakLists itm WeaponTargetingSF) pci
 
@@ -164,7 +164,7 @@ toLasgunUpdate itm =
 
 springLinkTest :: LinkTest
 springLinkTest = LTest (const Nothing) $
-    \ci -> case ci ^. _1 . itType of
+    \ci -> case ci ^. ldtValue . _1 . itType of
         CRAFT HARDWARE ->
             Just
                 ( LUpdate
@@ -182,14 +182,14 @@ type LDTComb a b = LabelDoubleTree b a -> LabelDoubleTree b a -> Maybe (LabelDou
 
 leftIsParentCombine :: LDTComb ComposedItem ItemLink
 leftIsParentCombine ltree rtree = do
-    lu <- (ltree ^. ldtValue . _3 . tryRightLink) (rtree ^. ldtValue)
+    lu <- (ltree ^. ldtValue . _3 . tryRightLink) rtree --(rtree ^. ldtValue)
     return $
         ltree & ldtValue %~ (lu ^. luParentUpdate)
             & ldtRight %~ (++ [(lu ^. luLinkType, rtree & ldtValue %~ (lu ^. luChildUpdate))])
 
 rightIsParentCombine :: LDTComb ComposedItem ItemLink
 rightIsParentCombine ltree rtree = do
-    lu <- (rtree ^. ldtValue . _3 . tryLeftLink) (ltree ^. ldtValue)
+    lu <- (rtree ^. ldtValue . _3 . tryLeftLink) ltree -- (ltree ^. ldtValue)
     return $
         rtree & ldtValue %~ (lu ^. luParentUpdate)
             & ldtLeft .:~ (lu ^. luLinkType, ltree & ldtValue %~ (lu ^. luChildUpdate))
@@ -200,9 +200,7 @@ leftRightCombine ::
     LabelDoubleTree b a ->
     LabelDoubleTree b a ->
     Maybe (LabelDoubleTree b a)
-leftRightCombine f f' t1 t2 =
+leftRightCombine f f' t1 t2 = f t1 t2 <|> checkdepth t1 t2
-    f t1 t2
-        <|> checkdepth t1 t2
   where
     checkdepth t t'@(LDT x ls rs) = fromMaybe (checktop t t') $ do
         (lab, t'') <- safeHead ls