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

Work on orienting positions for attachment items

Browse Source
This commit is contained in:
justin
2024-10-02 00:30:52 +01:00
parent 8df6b31062
commit 7ce5225491
10 changed files with 314 additions and 161 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/State.hs
+81 -46
View File
@@ -3,6 +3,13 @@ module Dodge.Creature.State (
doDamage,
) where
import Dodge.WorldEvent.Flash
import Dodge.Data.DoubleTree
import Dodge.Item.HeldOffset
import Dodge.DoubleTree
import Dodge.Data.ComposedItem
import qualified Quaternion as Q
import Dodge.Item.Grammar
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Monoid
@@ -236,12 +243,45 @@ equipmentEffects cr = alaf Endo foldMap (useEquipment cr) (IM.keys $ _crInvEquip
-- a loop going over all inventory items
invSideEff :: Creature -> World -> World
invSideEff cr = alaf Endo foldMap f (_crInv cr)
. updateRootItem cr
where
-- be careful with side effects that affect creature targeting
f it =
itemInvSideEffect cr it
. maybe id (\g -> doInvEffect g it cr) (it ^? itEffect . ieInv)
updateRootItem :: Creature -> World -> World
updateRootItem cr = fromMaybe id $ do
invid <- cr ^? crManipulation . manObject . imRootItem
itmtree <- invTrees' (_crInv cr) ^? ix invid
return $ updateRootItem' itmtree cr
-- need to check rotation
chainLinkOrientation
:: Maybe (Point3, Q.Quaternion Float)
-> Item
-> ItemLink
-> Item
-> Maybe (Point3,Q.Quaternion Float)
chainLinkOrientation mo par (ILink lt f) child = do
(p,q) <- mo
(p1,q1) <- f par lt child
return (p + Q.rotate q p1, q * q1)
updateRootItem' :: LabelDoubleTree ItemLink Item -> Creature -> World -> World
updateRootItem' itmtree cr = ldtPropagateFold chainLinkOrientation chainLinkOrientation
(updateItemWithOrientation cr)
(Just (heldItemRelativeOrient (_ldtValue itmtree) cr (0,Q.qID)))
itmtree
updateItemWithOrientation :: Creature -> Maybe (Point3, Q.Quaternion Float) -> Item -> World -> World
updateItemWithOrientation cr m itm = case _itType itm of
HELD TORCH -> testtorch cr m
_ -> id
testtorch :: Creature -> Maybe (Point3, Q.Quaternion Float) -> World -> World
testtorch cr = maybe id $ \(pos,_) -> muzFlareAt yellow (_crPos cr `v2z` 0 + rotate3z (_crDir cr) pos) (_crDir cr)
itemInvSideEffect :: Creature -> Item -> World -> World
itemInvSideEffect cr itm = case _itType itm of
TARGETING tt -> updateItemTargeting tt cr itm
@@ -259,55 +299,50 @@ itemInvSideEffect cr itm = case _itType itm of
-- attachoff = it ^?! itDimension . dimAttachPos
updateItemTargeting :: TargetingType -> Creature -> Item -> World -> World
updateItemTargeting tt cr itm w =
w & case tt of
_
| not isattached ->
cWorld . lWorld . creatures . ix (_crID cr) . crInv . ix (_ilInvID $ _itLocation itm) . itUse
%~ ( (tgPos .~ Nothing)
. (tgActive .~ False)
)
TARGETLASER
| crIsAiming cr ->
cWorld . lWorld . lasers
.:~ LaserStart
{ _lpPhaseV = 1
, _lpDir = _crDir cr
, _lpPos = sp
, _lpColor = col
, _lpType = TargetingLaser (_itID itm)
}
TARGETLASER ->
cWorld . lWorld . creatures . ix (_crID cr) . crInv . ix (_ilInvID $ _itLocation itm)
. itUse
. tgPos
.~ Nothing
TargetRBPress
| rbpressed ->
cWorld . lWorld . creatures . ix (_crID cr) . crInv . ix (_ilInvID $ _itLocation itm) . itUse
%~ ( (tgPos %~ maybe (Just $ mouseWorldPos (w ^. input) (w ^. wCam)) Just)
. (tgActive .~ True)
)
TargetRBPress ->
updateItemTargeting tt cr itm w = w & case tt of
_ | not isattached ->
cWorld . lWorld . creatures . ix (_crID cr) . crInv . ix (_ilInvID $ _itLocation itm) . itUse
%~ ( (tgPos .~ Nothing)
. (tgActive .~ False)
. (tgActive .~ False))
TARGETLASER | crIsAiming cr ->
cWorld . lWorld . lasers
.:~ LaserStart
{ _lpPhaseV = 1
, _lpDir = _crDir cr
, _lpPos = sp
, _lpColor = col
, _lpType = TargetingLaser (_itID itm)
}
TARGETLASER ->
cWorld . lWorld . creatures . ix (_crID cr) . crInv . ix (_ilInvID $ _itLocation itm)
. itUse
. tgPos
.~ Nothing
TargetRBPress | rbpressed ->
cWorld . lWorld . creatures . ix (_crID cr) . crInv . ix (_ilInvID $ _itLocation itm) . itUse
%~ ( (tgPos %~ maybe (Just $ mouseWorldPos (w ^. input) (w ^. wCam)) Just)
. (tgActive .~ True)
)
TargetRBCreature ->
cWorld . lWorld . creatures . ix (_crID cr)
. crInv
. ix (_ilInvID $ _itLocation itm)
. itUse
%~ setRBCreatureTargeting cr w
TargetCursor ->
cWorld . lWorld . creatures . ix (_crID cr)
. crInv
. ix (_ilInvID $ _itLocation itm)
. itUse
.~ TargetingUse
(Just (mouseWorldPos (w ^. input) (w ^. wCam)))
Nothing
True
TargetRBPress ->
cWorld . lWorld . creatures . ix (_crID cr) . crInv . ix (_ilInvID $ _itLocation itm) . itUse
%~ ( (tgPos .~ Nothing)
. (tgActive .~ False)
)
TargetRBCreature ->
cWorld . lWorld . creatures . ix (_crID cr)
. crInv
. ix (_ilInvID $ _itLocation itm)
. itUse
%~ setRBCreatureTargeting cr w
TargetCursor ->
cWorld . lWorld . creatures . ix (_crID cr)
. crInv
. ix (_ilInvID $ _itLocation itm)
. itUse
.~ TargetingUse
(Just (mouseWorldPos (w ^. input) (w ^. wCam)))
Nothing
True
where
isattached = itm ^?! itLocation . ilIsAttached
rbpressed = SDL.ButtonRight `M.member` _mouseButtons (_input w)
src/Dodge/Data/Creature/Shape.hs
-2
View File
@@ -1,2 +0,0 @@
module Dodge.Data.Creature.Shape where
src/Dodge/Data/DoubleTree.hs
+28
View File
@@ -40,6 +40,34 @@ data LabelDoubleTree b a = LDT {_ldtValue :: a, _ldtLeft :: [(b,LabelDoubleTree
,_ldtRight :: [(b,LabelDoubleTree b a)]}
deriving (Eq,Ord,Show,Read)
-- I am not sure about the double use of records here
data ContextLDT b a = TopLDT
{ _cldtValue :: a}
| LeftwardLDT
{ _cldtUp :: ContextLDT b a
, _cldtCloseLeft :: [LabelDoubleTree b a]
, _cldtLink :: b
, _cldtValue :: a
, _cldtCloseRight :: [LabelDoubleTree b a]
, _cldtFarRight :: [LabelDoubleTree b a]
}
| RightwardLDT
{ _cldtUp :: ContextLDT b a
, _cldtFarLeft :: [LabelDoubleTree b a]
, _cldtCloseLeft :: [LabelDoubleTree b a]
, _cldtLink :: b
, _cldtValue :: a
, _cldtCloseRight :: [LabelDoubleTree b a]
}
-- this is not quite right, it duplicates the value when the context is at the
-- top
data LocationLDT b a = LocLDT
{ _locLdtContext :: ContextLDT b a
, _locLdtLeft :: [LabelDoubleTree b a]
, _locLdtRight :: [LabelDoubleTree b a]
}
instance Functor DoubleTree where
fmap f (DT x l r) = DT (f x) (fmap (fmap f) l) (fmap (fmap f) r)
src/Dodge/DoubleTree.hs
+38 -1
View File
@@ -2,6 +2,9 @@ module Dodge.DoubleTree where
import Dodge.Data.DoubleTree
import qualified Data.IntMap.Strict as IM
import Control.Lens
import Data.Bifunctor
import Data.Monoid
singleDT :: a -> DoubleTree a
singleDT x = DT x [] []
@@ -9,10 +12,44 @@ 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)
-- propogate two functions down the links of an LDT tree
-- which function is chosen depends on whether it is a left or right branch
ldtPropagate :: (c -> b -> c) -> (c -> b -> c)
-> c
-> LabelDoubleTree b a -> LabelDoubleTree c a
ldtPropagate lf rf = ildtPropagate (const lf) (const rf)
-- Propgates a value (of type c) down the branches of the LDT.
-- The value is updated according a "left" or "right" function (lf or rf),
-- that acts on the parent value, the link, and the child value.
-- For each node, the updated value is used to update a final value (of type d).
ldtPropagateFold :: (c -> a -> b -> a -> c)
-> (c -> a -> b -> a -> c)
-> (c -> a -> d -> d)
-> c
-> LabelDoubleTree b a
-> d
-> d
ldtPropagateFold lf rf up x (LDT v l r) =
alaf Endo foldMap (\(s,y) -> ldtPropagateFold lf rf up (rf x v s (_ldtValue y)) y) r
. alaf Endo foldMap (\(s,y) -> ldtPropagateFold lf rf up (lf x v s (_ldtValue y)) y) l
. up x v
ildtPropagate :: (Int -> c -> b -> c) -> (Int -> c -> b -> c)
-> c
-> LabelDoubleTree b a -> LabelDoubleTree c a
ildtPropagate lf rf x (LDT v l r) = LDT v (imap (go lf x) l) (imap (go rf x) r)
where
go f y i (z,t) = (f i y z, ildtPropagate lf rf (f i y z) t)
ldtPropagateIndices :: LabelDoubleTree b a -> LabelDoubleTree b (a, [Either Int Int])
ldtPropagateIndices (LDT x l r) = LDT (x,[]) (imap (f Left) l) (imap (f Right) r)
where
f e i (y,t) = (y, fmap (second (e i:)) $ ldtPropagateIndices t)
-- conceptually, in a tree growing from left to right,
-- bottom -> top is equated with left -> right.
-- this does not match with thinking of a list as top -> bottom, so take care
src/Dodge/Item/Grammar.hs
+10
View File
@@ -1,5 +1,6 @@
module Dodge.Item.Grammar (
invLDT,
invTrees',
invTrees,
invIndentIM,
invAdj,
@@ -168,3 +169,12 @@ invTrees = IM.unions . map (ldtToIM getindex . fmap (^. _1)) . map (bimap _iatTy
getindex i =
fromMaybe (error "in invTrees try to get non-inventory item tree") $
i ^? itLocation . ilInvID
-- returns an intmap with trees for all root items
invTrees' :: IM.IntMap Item -> IM.IntMap (LabelDoubleTree ItemLink Item)
invTrees' = IM.unions . map (ldtToIM getindex . fmap (^. _1)) . map (bimap id (\(x, y, _) -> (x, y))) . invLDT
where
getindex :: Item -> Int
getindex i =
fromMaybe (error "in invTrees try to get non-inventory item tree") $
i ^? itLocation . ilInvID
src/Dodge/Item/Orientation.hs
+1 -1
View File
@@ -9,7 +9,7 @@ import qualified Linear.Quaternion as Q
orientChild :: Item -> (Point3, Q.Quaternion Float)
orientChild itm = case _itType itm of
HELD {} -> (0,Q.axisAngle (V3 1 0 0) 0)
HELD TORCH -> (V3 5 0 0,Q.axisAngle (V3 1 0 0) 0)
_ -> (0,Q.axisAngle (V3 1 0 0) 0)
orientByLink :: Item -> ComposeLinkType -> (Point3, Q.Quaternion Float)
src/Dodge/LightSource/Torch.hs
+1 -1
View File
@@ -9,7 +9,7 @@ import Geometry
import LensHelp
createTorchLightOffset :: Creature -> Item -> Point3 -> World -> World
createTorchLightOffset cr it off = muzFlareAt yellow pos (_crDir cr) .
createTorchLightOffset cr it off =
(cWorld . lWorld . tempLightSources
.:~ tlsTimeRadColPos
1
src/SimpleTrie.hs
+27 -21
View File
@@ -1,42 +1,48 @@
{-# LANGUAGE TemplateHaskell #-}
module SimpleTrie where
import qualified Data.Map.Strict as M
import Control.Lens
import qualified Data.Map.Strict as M
data Trie a b = Trie
{ _trieMVal :: Maybe b
{ _trieMVal :: Maybe b
, _trieChildren :: M.Map a (Trie a b)
}
makeLenses ''Trie
emptyTrie :: Trie a b
emptyTrie = Trie Nothing M.empty
singletonTrie :: Ord a => [a] -> b -> Trie a b
singletonTrie (k:ks) x = Trie Nothing $ M.singleton k $ singletonTrie ks x
singletonTrie (k : ks) x = Trie Nothing $ M.singleton k $ singletonTrie ks x
singletonTrie [] x = Trie (Just x) M.empty
insertInTrie :: Ord a => [a] -> b -> Trie a b -> Trie a b
insertInTrie [] x = trieMVal ?~ x
insertInTrie (k:ks) x = trieChildren %~ M.insertWith f k (singletonTrie ks x)
insertInTrie [] x = trieMVal ?~ x
insertInTrie (k : ks) x = trieChildren %~ M.insertWith f k (singletonTrie ks x)
where
f _ = insertInTrie ks x
lookupTrie :: Ord a => [a] -> Trie a b -> Maybe b
lookupTrie (k:ks) t = _trieChildren t M.!? k >>= lookupTrie ks
lookupTrie [] t = _trieMVal t
lookupTrie (k : ks) t = _trieChildren t M.!? k >>= lookupTrie ks
lookupTrie [] t = _trieMVal t
multiLookupTrie :: Ord a => [a] -> Trie a b -> [([a],b)]
multiLookupTrie xs t@(Trie my ch)
| null xs || null ch = maybe [] (\y -> [([],y)]) my
| otherwise = let (z:zs) = xs in
case M.lookup z ch of
Nothing -> multiLookupTrie zs t
Just t' -> map (_1 %~ (z:)) (multiLookupTrie zs t') ++ multiLookupTrie zs t
multiLookupTrie :: Ord a => [a] -> Trie a b -> [([a], b)]
multiLookupTrie xs t@(Trie my ch)
| null xs || null ch = maybe [] (\y -> [([], y)]) my
| otherwise =
let (z : zs) = xs
in case M.lookup z ch of
Nothing -> multiLookupTrie zs t
Just t' -> map (_1 %~ (z :)) (multiLookupTrie zs t') ++ multiLookupTrie zs t
multiLookupTrieI :: Ord a => [(a,c)] -> Trie a b -> [([c],b)]
multiLookupTrieI xs t@(Trie my ch)
| null xs || null ch = maybe [] (\y -> [([],y)]) my
| otherwise = let ((z1,z2):zs) = xs in
case M.lookup z1 ch of
Nothing -> multiLookupTrieI zs t
Just t' -> map (_1 %~ (z2:)) (multiLookupTrieI zs t') ++ multiLookupTrieI zs t
multiLookupTrieI :: Ord a => [(a, c)] -> Trie a b -> [([c], b)]
multiLookupTrieI xs t@(Trie my ch)
| null xs || null ch = maybe [] (\y -> [([], y)]) my
| otherwise =
let ((z1, z2) : zs) = xs
in case M.lookup z1 ch of
Nothing -> multiLookupTrieI zs t
Just t' -> map (_1 %~ (z2 :)) (multiLookupTrieI zs t') ++ multiLookupTrieI zs t