Add roots and parents to adjacency function from Double Trees

src/Dodge/Creature/State.hs

@@ -6,14 +6,14 @@ module Dodge.Creature.State (
 import Dodge.Item.Display -- this should not really be imported... TODO move canAttachTargetingBelow
 import Control.Applicative
 import Data.Foldable
-import Data.Maybe
+--import Data.Maybe
 import Dodge.Base
 import Dodge.Corpse.Make
 import Dodge.Creature.Action
 import Dodge.Creature.Damage
 import Dodge.Creature.Impulse.Movement
 import Dodge.Creature.State.WalkCycle
-import Dodge.Creature.Test
+--import Dodge.Creature.Test
 import Dodge.Damage
 import Dodge.Data.World
 import Dodge.EnergyBall
@@ -62,20 +62,20 @@ stateUpdate f =
         , updateInv -- upInv must be called before invSideEff 22.05.23
         , invSideEff
         , equipmentEffects
-        , heldItemEffects
-        , heldAimEffects
+--        , heldItemEffects
+--        , heldAimEffects
         ]
 
-heldItemEffects :: Creature -> World -> World
-heldItemEffects _ = id
+--heldItemEffects :: Creature -> World -> World
+--heldItemEffects _ = id
 
-heldAimEffects :: Creature -> World -> World
-heldAimEffects cr = fromMaybe id $ do
-    guard (crIsAiming cr)
-    ipos <- cr ^? crManipulation . manObject . inInventory . ispItem
-    itm <- cr ^? crInv . ix ipos
-    f <- itm ^? itEffect . ieWhileAiming
-    return $ doInvEffect f itm cr
+--heldAimEffects :: Creature -> World -> World
+--heldAimEffects cr = fromMaybe id $ do
+--    guard (crIsAiming cr)
+--    ipos <- cr ^? crManipulation . manObject . inInventory . ispItem
+--    itm <- cr ^? crInv . ix ipos
+--    f <- itm ^? itEffect . ieWhileAiming
+--    return $ doInvEffect f itm cr
 
 checkDeath :: Creature -> World -> World
 checkDeath cr w

src/Dodge/Data/Item/Effect.hs

@@ -13,7 +13,6 @@ data ItEffect = ItEffect
     { _ieInv :: ItInvEffect --Item -> Creature -> World -> World
     , _ieOnInsert :: ItInvEffect
     , _ieOnDrop :: ItInvEffect --Item -> Creature -> World -> World
-    , _ieWhileAiming :: ItInvEffect
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 

src/Dodge/Default/Item/Effect.hs

@@ -8,5 +8,4 @@ defaultItEffect =
         { _ieInv = NoInvEffect
         , _ieOnInsert = NoInvEffect
         , _ieOnDrop = NoInvEffect
-        , _ieWhileAiming = NoInvEffect
         }

src/Dodge/DoubleTree.hs

@@ -3,6 +3,13 @@ module Dodge.DoubleTree where
 import Dodge.Data.DoubleTree
 import qualified Data.IntMap.Strict as IM
 
+singleDT :: a -> DoubleTree a
+singleDT x = DT x [] []
+
+singleLDT :: a -> LabelDoubleTree b a
+singleLDT x = LDT x [] []
+
+
 ldtToDT :: LabelDoubleTree b a -> DoubleTree a
 ldtToDT (LDT x l r) = DT x (map (ldtToDT . snd) l) (map (ldtToDT . snd) r)
 
@@ -31,6 +38,21 @@ dtToUpDownAdj f (DT x l r) = IM.insert (f x) (map g l , map g r)
   where 
     g = f . _dtValue
 
+-- returns an adjacency map with oldest ancestor and direct parent if they exist
+-- and any left and right children
+dtToLRAdj :: (a -> Int) -> DoubleTree a -> IM.IntMap (Maybe (Int,Int),[Int],[Int])
+dtToLRAdj f (DT x l r) = IM.insert i (Nothing,map g l , map g r) 
+    . IM.unions $ map (dtToAdjRootParent i i f) $ l <> r
+  where 
+    i = f x
+    g = f . _dtValue
+
+dtToAdjRootParent :: Int -> Int -> (a -> Int) -> DoubleTree a -> IM.IntMap (Maybe (Int,Int),[Int],[Int])
+dtToAdjRootParent root par f (DT x l r) = IM.insert (f x) (Just (root,par),map g l , map g r) 
+    . IM.unions $ map (dtToAdjRootParent root (f x) f) $ l <> r
+  where 
+    g = f . _dtValue
+
 ldtToIM :: (a -> Int) -> LabelDoubleTree b a -> IM.IntMap (LabelDoubleTree b a)
 ldtToIM f t@(LDT x l r) = IM.insert (f x) t $ IM.unions $ map (ldtToIM f . snd) $  l <> r
 

src/Dodge/HeldUse.hs

@@ -7,7 +7,7 @@ module Dodge.HeldUse
 
 import Dodge.Base.Collide
 import Dodge.Inventory.Lock
-import Dodge.WorldEvent.Cloud
+--import Dodge.WorldEvent.Cloud
 import Dodge.LightSource
 import qualified SDL
 --import Dodge.Base.You
@@ -15,7 +15,7 @@ import Dodge.Data.MuzzleEffect
 import ListHelp
 import Dodge.Data.ComposedItem
 import Dodge.Data.DoubleTree
-import Color
+--import Color
 import Data.Maybe
 --import Data.Traversable
 import Dodge.Base.Coordinate
@@ -158,20 +158,20 @@ basicMuzFlare pos dir = makeTlsTimeRadColPos 2 100 (V3 1 1 0.5) (pos `v2z` 20)
         . muzFlareAt (V4 10 10 1 3) (pos `v2z` 20) dir
         . muzFlareAt (V4 10 10 1 3) (pos `v2z` 20) dir 
 
--- need to add these to muzzle flare
-makeMuzzleSmoke :: Muzzle -> Item -> Creature -> World -> World
-makeMuzzleSmoke mz itm cr w = case mz ^. mzFlareType of
-    DefaultFlareType -> w
-    PistolFlare -> foldl' (flip $ smokeCloudAt (greyN 0.5) 5 400 5 . (+.+.+ pos) . (* 8)) w ps
-    MiniGunFlare -> smokeCloudAt (greyN 0.5) 5 400 5 pos w
-    HeavySmokeFlare -> foldl' (flip $ smokeCloudAt black 20 400 5 . (+.+.+ pos) . (* 8)) w ps'
-    LasGunFlare -> w
-    TeslaGunFlare -> w
-  where
-    ps = replicateM 2 randOnUnitSphere & evalState $ _randGen w
-    ps' = replicateM 4 randOnUnitSphere & evalState $ _randGen w
-    pos = addZ 10 $ _crPos cr + rotateV (_crDir cr) (_mzPos mz + aimingWeaponZeroPos cr itm)
---        , withSmoke 1 black 20 200 5
+---- need to add these to muzzle flare?
+--makeMuzzleSmoke :: Muzzle -> Item -> Creature -> World -> World
+--makeMuzzleSmoke mz itm cr w = case mz ^. mzFlareType of
+--    DefaultFlareType -> w
+--    PistolFlare -> foldl' (flip $ smokeCloudAt (greyN 0.5) 5 400 5 . (+.+.+ pos) . (* 8)) w ps
+--    MiniGunFlare -> smokeCloudAt (greyN 0.5) 5 400 5 pos w
+--    HeavySmokeFlare -> foldl' (flip $ smokeCloudAt black 20 400 5 . (+.+.+ pos) . (* 8)) w ps'
+--    LasGunFlare -> w
+--    TeslaGunFlare -> w
+--  where
+--    ps = replicateM 2 randOnUnitSphere & evalState $ _randGen w
+--    ps' = replicateM 4 randOnUnitSphere & evalState $ _randGen w
+--    pos = addZ 10 $ _crPos cr + rotateV (_crDir cr) (_mzPos mz + aimingWeaponZeroPos cr itm)
+----        , withSmoke 1 black 20 200 5
 
 isAmmoIntLink :: Int -> ComposeLinkType -> Bool
 isAmmoIntLink i (AmmoInLink j _) = i == j
@@ -186,7 +186,7 @@ useLoadedAmmo itm cr (cme,w) (mzid,(mz,x,mid)) = (,) (cme & cmeSound .~ True) $
     MuzzleLaser -> shootLaser' itm cr mz w
     MuzzleTesla -> shootTeslaArc itm cr mz w
     MuzzleTractor -> shootTractorBeam itm cr w
-    MuzzleLauncher -> createProjectile' mid mz itm cr w 
+    MuzzleLauncher -> createProjectile mid mz itm cr w 
     MuzzleNozzle {} -> useGasParams mid mz itm cr $ walkNozzle mzid mz itm cr w
     MuzzleShatter -> shootShatter itm cr w
     MuzzleForceField -> useForceFieldGun itm cr w
@@ -375,15 +375,6 @@ useHeld hu = case hu of
 --    maxa = _nzMaxWalkAngle nz
 --    wa = min maxa $ max (negate maxa) (_nzCurrentWalkAngle nz + walkamount)
 
-getAmmoMagazine :: Item -> Creature -> Maybe ItemUse
-getAmmoMagazine itm cr = do
-    invid <- itm ^? itLocation . ipInvID
-    amtype <- itm ^? itUse . heldAmmoTypes . ix 0
-    mag <- cr ^? crInv . ix (invid + 1) . itUse
-    magtype <- mag ^? amagType
-    guard $ amtype == magtype
-    return mag
-
 useGasParams :: Maybe Int -> Muzzle -> Item -> Creature -> World -> World
 useGasParams mmagid mz itm cr w =
     createGas

src/Dodge/Item/Grammar.hs

@@ -1,7 +1,8 @@
 module Dodge.Item.Grammar
---    (invTree
---    , indentInv
---    )
+    (invTrees
+    , invIndentIM
+    , invAdj
+    )
     where
 import Control.Applicative
 import Data.Maybe
@@ -22,12 +23,6 @@ type CIL = (ComposedItem,[(ComposeLinkType,ComposedItem)], [(ComposeLinkType,Com
 cisToItem :: ComposedItemStructure -> Item
 cisToItem (x,_,_,_) = x
 
-singleDT :: a -> DoubleTree a
-singleDT x = DT x [] []
-
-singleLDT :: a -> LabelDoubleTree b a
-singleLDT x = LDT x [] []
-
 baseComposedItem :: ItemBaseType -> Item -> CIL
 baseComposedItem ibt itm = case ibt of
     HELD hit -> heldComposedItem itm hit
@@ -56,9 +51,6 @@ baseCIS :: Item -> ComposedItemStructure
 baseCIS itm = let (a,b,c) = baseComposedItem (itm ^. itType . iyBase) itm
   in (itm, a, b, c)
 
-type LDTTest a b = LabelDoubleTree b a -> LabelDoubleTree b a -> Maybe b
-type LDTCombine a b = LabelDoubleTree b a -> LabelDoubleTree b a -> b -> LabelDoubleTree b a
-
 type LDTComb a b = LabelDoubleTree b a -> LabelDoubleTree b a -> Maybe (LabelDoubleTree b a)
 
 -- the following imposes a strict ordering on the possible attachments
@@ -100,8 +92,8 @@ invLDT :: IM.IntMap Item -> [LabelDoubleTree ComposeLinkType ComposedItemStructu
 invLDT = joinItemsInList (leftRightCombine leftIsParentCombine rightIsParentCombine) . IM.elems .
     fmap (singleLDT . baseCIS)
 
-invAdj :: IM.IntMap Item -> IM.IntMap ([Int],[Int])
-invAdj = IM.unions . fmap (dtToUpDownAdj getid . ldtToDT) . invLDT
+invAdj :: IM.IntMap Item -> IM.IntMap (Maybe (Int,Int),[Int],[Int])
+invAdj = IM.unions . fmap (dtToLRAdj getid . ldtToDT) . invLDT
   where
     getid (itm, _,_,_) = fromMaybe (error "invAdj attempt to find item not in inventory") $
         itm ^? itLocation . ipInvID
@@ -109,10 +101,7 @@ invAdj = IM.unions . fmap (dtToUpDownAdj getid . ldtToDT) . invLDT
 invIndentIM :: IM.IntMap Item -> IM.IntMap (Item,Int, LabelDoubleTreeNodeType ComposeLinkType )
 invIndentIM = IM.fromAscList . zip [0..] . reverse . map (over _1 cisToItem) . concatMap ldtToIndentList . invLDT
 
---invTrees :: IM.IntMap Item -> [(LabelDoubleTree ComposeLinkType Item)]
 invTrees :: IM.IntMap Item -> IM.IntMap (LabelDoubleTree ComposeLinkType Item)
---invTrees = map (ldtToIM getindex) . map (fmap cisToItem) . invLDT
---invTrees = map (ldtToIM getindex) . map (fmap cisToItem) . invLDT
 invTrees = IM.unions . map (ldtToIM getindex) . map (fmap cisToItem) . invLDT
   where
     getindex :: Item -> Int

src/Dodge/Projectile/Create.hs

@@ -1,4 +1,6 @@
-module Dodge.Projectile.Create where
+module Dodge.Projectile.Create 
+    ( createProjectile
+    ) where
 
 import Dodge.SoundLogic
 import Control.Monad
@@ -9,9 +11,8 @@ import qualified IntMapHelp as IM
 import LensHelp
 import qualified SDL
 
-
-createProjectile' :: Maybe Int -> Muzzle -> Item -> Creature -> World -> World
-createProjectile' mmagid muz itm cr = fromMaybe failsound $ do
+createProjectile :: Maybe Int -> Muzzle -> Item -> Creature -> World -> World
+createProjectile mmagid muz itm cr = fromMaybe failsound $ do
     magid <- mmagid
     ammoitem <- cr ^? crInv . ix magid
     matype <- ammoitem ^? itUse . amagType

src/Dodge/Render/HUD.hs

@@ -183,8 +183,9 @@ examineInventoryExtra mtweaki cfig = fromMaybe mempty $ do
             translate subInvX (-71) $
                 listCursorChooseBorderScale 0 1 [North, South, West] tweaki 0 white 10 1
 
-inventoryExtra :: SelectionSections () ->  Configuration -> World -> IM.IntMap ([Int],[Int]) -> Picture
-inventoryExtra sss cfig w is = translate (negate 5) 0 $ IM.foldMapWithKey (inventoryExtraH sss cfig w) $ fmap (\(a,b) -> a<>b) is
+inventoryExtra :: SelectionSections () ->  Configuration -> World 
+    -> IM.IntMap (Maybe (Int,Int),[Int],[Int]) -> Picture
+inventoryExtra sss cfig w is = translate (negate 5) 0 $ IM.foldMapWithKey (inventoryExtraH sss cfig w) $ fmap (\(_,a,b) -> a<>b) is
 
 inventoryExtraH :: SelectionSections () ->  Configuration -> World -> Int -> [Int] -> Picture
 inventoryExtraH sss cfig w i is = fromMaybe mempty $ do