justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Migrate LDTs to DTs

Browse Source
This commit is contained in:
justin
2025-07-10 22:13:47 +01:00
parent 9543c2c789
commit cd46f34787
9 changed files with 169 additions and 95 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/State.hs
+2 -2
View File
@@ -315,7 +315,7 @@ shineTargetLaser cr loc w = fromMaybe (w & pointittarg . itTgPos .~ Nothing) $ d
, _lpType = TargetingLaser (_itID itm)
}
where
o = locOrient loc cr
o = locOrient (locLDTToLocDT loc) cr
itmtree = loc ^. locLDT
(p, q) = o `Q.comp` (V3 5 0 0, Q.qID)
x = 1
@@ -341,7 +341,7 @@ shineTorch cr loc = fromMaybe id $ do
. (cWorld . lWorld . creatures . ix (_crID cr) . crInv . ix invid . itConsumables . _Just -~ x)
where
itmtree = loc ^. locLDT
(p, q) = locOrient loc cr
(p, q) = locOrient (locLDTToLocDT loc) cr
x = 10
isammolink AmmoInLink{} = True
isammolink _ = False
src/Dodge/Creature/Test.hs
+2 -1
View File
@@ -24,6 +24,7 @@ module Dodge.Creature.Test (
crSafeDistFromTarg,
) where
import Dodge.DoubleTree
import Dodge.Item.Grammar
import Dodge.Creature.Radius
import Dodge.Data.Equipment.Misc
@@ -97,7 +98,7 @@ crInAimStance as cr = crIsAiming cr && mitstance == Just as
i <- cr ^? crManipulation . manObject . imRootSelectedItem
--itm <- invRootTrees' (cr ^. crInv) ^? ix i
itm <- fmap (fmap (\(a,b,_) -> (a,b))) $ invRootTrees (cr ^. crInv) ^? ix i
return $ aimStance itm
return $ aimStance $ ldtToDT itm
--cr ^? crInv . ix i . itUse . heldAim . aimStance
oneH :: Creature -> Bool
src/Dodge/Data/DoubleTree.hs
+21 -1
View File
@@ -98,7 +98,7 @@ data ContextDT a
, _cdtCloseRight :: [DTree a]
}
data LocationDT b a = LocDT
data LocationDT a = LocDT
{ _locDtContext :: ContextDT a
, _locDT :: DTree a
}
@@ -107,10 +107,15 @@ makeLenses ''DTree
makeLenses ''LDTree
makeLenses ''LocationLDT
makeLenses ''ContextLDT
makeLenses ''LocationDT
makeLenses ''ContextDT
instance Functor (LocationLDT b) where
fmap f (LocLDT c t) = LocLDT (fmap f c) (fmap f t)
instance Functor (LocationDT) where
fmap f (LocDT c t) = LocDT (fmap f c) (fmap f t)
instance Functor (ContextLDT b) where
fmap f = \case
TopLDT -> TopLDT
@@ -128,5 +133,20 @@ instance Functor (ContextLDT b) where
l
(fmap (fmap (fmap f)) cr)
instance Functor (ContextDT) where
fmap f = \case
TopDT -> TopDT
LeftwardDT u cl p cr fr -> LeftwardDT
(fmap f u)
(fmap (fmap ( f)) cl)
(f p)
(fmap (fmap ( f)) cr)
(fmap (fmap ( f)) fr)
RightwardDT u fl cl p cr -> RightwardDT (fmap f u)
(fmap (fmap ( f)) fl)
(fmap (fmap ( f)) cl)
(f p)
(fmap (fmap ( f)) cr)
--deriveJSON defaultOptions ''DoubleTree
--deriveJSON defaultOptions ''LabelDoubleTree
src/Dodge/DoubleTree.hs
+37 -1
View File
@@ -1,10 +1,11 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.DoubleTree where
import Dodge.Data.DoubleTree
import Control.Lens
import Data.Bifunctor
import qualified Data.IntMap.Strict as IM
import Data.Monoid
import Dodge.Data.DoubleTree
singleDT :: a -> DTree a
singleDT x = DT x [] []
@@ -15,6 +16,25 @@ singleLDT x = LDT x [] []
ldtToDT :: LDTree b a -> DTree a
ldtToDT (LDT x l r) = DT x (map (ldtToDT . snd) l) (map (ldtToDT . snd) r)
locLDTToLocDT :: LocationLDT b a -> LocationDT a
locLDTToLocDT (LocLDT con t) = LocDT (conLDTToConDT con) (ldtToDT t)
conLDTToConDT :: ContextLDT b a -> ContextDT a
conLDTToConDT = \case
TopLDT -> TopDT
LeftwardLDT u cl p _ cr fr -> LeftwardDT
(conLDTToConDT u)
(map (ldtToDT . snd) cl)
p
(map (ldtToDT . snd) cr)
(map (ldtToDT . snd) fr)
RightwardLDT u fl cl p _ cr -> RightwardDT
(conLDTToConDT u)
(map (ldtToDT . snd) fl)
(map (ldtToDT . snd) cl)
p
(map (ldtToDT . snd) cr)
dtStartPropagate :: (a -> c) -> (c -> a -> c) -> DTree a -> DTree c
dtStartPropagate g f (DT x l r) = DT z
(fmap (\(t) -> (dtPropagate' z f t)) l)
@@ -265,6 +285,22 @@ locUp (LocLDT c@RightwardLDT{} t) =
locToTop :: LocationLDT b a -> LocationLDT b a
locToTop loc = maybe loc locToTop $ locUp loc
locUp' :: LocationDT a -> Maybe (LocationDT a)
locUp' (LocDT TopDT _) = Nothing
locUp' (LocDT c@LeftwardDT{} t) =
Just $
LocDT
(_cdtUp c)
(DT (_cdtParent c) (_cdtCloseLeft c ++ (( t) : _cdtCloseRight c)) (_cdtFarRight c))
locUp' (LocDT c@RightwardDT{} t) =
Just $
LocDT
(_cdtUp c)
(DT (_cdtParent c) (_cdtFarLeft c) (_cdtCloseLeft c ++ (( t) : _cdtCloseRight c)))
locToTop' :: LocationDT a -> LocationDT a
locToTop' loc = maybe loc locToTop' $ locUp' loc
--locToTop = fix $ \x -> fromMaybe x $ locUp x
locLeftmost :: LocationLDT b a -> LocationLDT b a
src/Dodge/HeldUse.hs
+7 -6
View File
@@ -8,6 +8,7 @@ module Dodge.HeldUse (
heldEffectMuzzles,
) where
import Dodge.DoubleTree
import Color
import Control.Applicative
import Control.Monad
@@ -498,7 +499,7 @@ applyRecoil loc cr =
+~ rotateV (_crDir cr + Q.qToAng q) (V2 ((- recoilAmount itm) / crMass (_crType cr)) 0)
where
itm = loc ^. locLDT . ldtValue . _1
(_, q) = locOrient loc cr
(_, q) = locOrient (locLDTToLocDT loc) cr
recoilAmount :: Item -> Float
recoilAmount itm
@@ -704,7 +705,7 @@ makeMuzzleFlare mz loc cr = case mz ^. mzFlareType of
TeslaGunFlare -> cWorld . lWorld . lights .:~ LSParam (pos `v2z` 10) 100 (V3 0 0 1)
where
(V3 x y _, q) =
locOrient loc cr
locOrient (locLDTToLocDT loc) cr
`Q.comp` (_mzPos mz `v2z` 0, Q.axisAngle (V3 0 0 1) (_mzRot mz))
pos = _crPos cr + rotateV (_crDir cr) (V2 x y)
dir = _crDir cr + Q.qToAng q
@@ -881,7 +882,7 @@ creatureShootLaser loc cr mz w =
itmtree = loc ^. locLDT
istree = fmap (\(i, _, _) -> i) itmtree
(V3 x y _, q) =
locOrient loc cr
locOrient (locLDTToLocDT loc) cr
`Q.comp` ((_mzPos mz + V2 0 offset) `v2z` 0, Q.axisAngle (V3 0 0 1) (_mzRot mz))
pos = _crPos cr + rotateV (_crDir cr) (V2 x y)
dir = _crDir cr + Q.qToAng q + a
@@ -991,7 +992,7 @@ shootBullet :: Bullet -> LocationLDT ItemLink OItem -> Creature -> Muzzle -> Wor
shootBullet bu loc cr mz w = makeBullet bu itm bulpos dir . (randGen .~ g) $ w
where
(V3 x y _, q) =
locOrient loc cr
locOrient (locLDTToLocDT loc) cr
`Q.comp` ((_mzPos mz + V2 0 offset) `v2z` 0, Q.axisAngle (V3 0 0 1) (_mzRot mz))
itm = loc ^. locLDT . ldtValue . _1
bulpos = _crPos cr + rotateV (_crDir cr) (V2 x y)
@@ -1134,7 +1135,7 @@ useGasParams mmagid mz loc cr w =
fueltype <- cr ^? crInv . ix magid >>= magAmmoParams >>= (^? ampCreateGas)
gasType hit fueltype
(V3 x y _, q) =
locOrient loc cr
locOrient (locLDTToLocDT loc) cr
`Q.comp` ((_mzPos mz + V2 0 offset) `v2z` 0, Q.axisAngle (V3 0 0 1) (_mzRot mz))
-- (moff, mrot) = heldItemOrient2D itm cr (_mzPos mz) (_mzRot mz)
pos = _crPos cr + rotateV (_crDir cr) (V2 x y)
@@ -1231,7 +1232,7 @@ shootTeslaArc loc cr mz w =
invid = itm ^?! itLocation . ilInvID
(w', ip) = makeTeslaArc (itm ^. itParams) pos dir w
(V3 x y _, q) =
locOrient loc cr
locOrient (locLDTToLocDT loc) cr
`Q.comp` ((_mzPos mz + V2 0 offset) `v2z` 0, Q.axisAngle (V3 0 0 1) (_mzRot mz))
pos = _crPos cr + rotateV (_crDir cr) (V2 x y)
dir = _crDir cr + Q.qToAng q
src/Dodge/Item/AimStance.hs
+5 -5
View File
@@ -7,13 +7,13 @@ import Dodge.Data.DoubleTree
import Control.Lens
import Dodge.Data.AimStance
aimStance :: LDTree ItemLink CItem -> AimStance
aimStance ldt
aimStance :: DTree CItem -> AimStance
aimStance dt
| islasweapon = TwoHandFlat
| otherwise = itemBaseStance $ ldt ^. ldtValue . _1
| otherwise = itemBaseStance $ dt ^. dtValue . _1
where
islasweapon = ldt ^. ldtValue . _1 . itType == CRAFT TRANSFORMER
&& ldt ^? ldtRight . ix 0 . _2 . ldtValue . _2 == Just LaserWeaponSF
islasweapon = dt ^. dtValue . _1 . itType == CRAFT TRANSFORMER
&& dt ^? dtRight . ix 0 . dtValue . _2 == Just LaserWeaponSF
itemBaseStance :: Item -> AimStance
itemBaseStance itm = case itm ^. itType of
src/Dodge/Item/Grammar.hs
+6
View File
@@ -1,5 +1,6 @@
{-# LANGUAGE TupleSections #-}
module Dodge.Item.Grammar (
invDT,
invLDT,
invLDT',
invAdj,
@@ -239,6 +240,11 @@ invLDT =
joinItemsInList tryAttachItems . IM.elems
. fmap (singleLDT . baseCI)
invDT :: IM.IntMap Item -> [DTree CItem]
invDT = fmap ldtToDT .
joinItemsInList tryAttachItems . IM.elems
. fmap (singleLDT . baseCI)
invLDT' :: IM.IntMap Item -> [LDTree ItemLink OItem]
invLDT' = fmap propagateOrientation . invLDT
src/Dodge/Item/HeldOffset.hs
+11 -9
View File
@@ -29,8 +29,8 @@ transToHandle itm = (-.-.- V3 x y 0)
where
V2 x y = handlePos itm
handleOrient :: LocationLDT ItemLink CItem -> Point3Q
handleOrient loc = case loc ^. locLDT . ldtValue . _1 . itType of
handleOrient :: LocationDT CItem -> Point3Q
handleOrient loc = case loc ^. locDT . dtValue . _1 . itType of
HELD FLAMETHROWER -> (V3 (-1) 0 0, Q.qID)
_ -> (V3 (-3) 0 0, Q.qID)
@@ -54,20 +54,22 @@ handOrient cr = case cr ^. crStance . posture of
f i = 0.1 * fromIntegral (sLen - i) / fromIntegral sLen
sLen = _strideLength $ _crStance cr
locOrient :: LocationLDT ItemLink OItem -> Creature -> Point3Q
locOrient :: LocationDT OItem -> Creature -> Point3Q
locOrient loc cr =
handHandleOrient (fmap (\(x, y, _) -> (x, y)) $ locToTop loc) cr
`Q.comp` (loc ^. locLDT . ldtValue . _3)
handHandleOrient (fmap (\(x, y, _) -> (x, y)) $ locToTop' loc) cr
`Q.comp` (loc ^. locDT . dtValue . _3)
heldItemOffset :: LocationLDT ItemLink CItem -> Creature -> Point3 -> Point3
heldItemOffset loc cr p = x + Q.rotate q p
where
(x, q) = handHandleOrient loc cr
(x, q) = handHandleOrient (locLDTToLocDT loc) cr
handHandleOrient :: LocationLDT ItemLink CItem -> Creature -> Point3Q
handHandleOrient :: LocationDT CItem -> Creature -> Point3Q
handHandleOrient loc cr =
handOrient cr (aimStance (loc ^. locLDT))
`Q.comp` handleOrient loc
handOrient cr (aimStance (loc' ^. locDT))
`Q.comp` handleOrient loc'
where
loc' = locToTop' loc
shoulderHeight :: Float
shoulderHeight = 18