Use function on location to determine laser orientation
This commit is contained in:
@@ -3,6 +3,8 @@ module Dodge.Creature.State (
|
||||
doDamage,
|
||||
) where
|
||||
|
||||
import Data.Bifunctor
|
||||
import Dodge.Data.DoubleTree
|
||||
import Dodge.Item.Orientation
|
||||
import Dodge.Item.UseDelay
|
||||
import Control.Applicative
|
||||
@@ -20,7 +22,7 @@ import Dodge.Creature.Test
|
||||
import Dodge.Damage
|
||||
import Dodge.Data.ComposedItem
|
||||
import Dodge.Data.Damage.Type
|
||||
import Dodge.Data.DoubleTree
|
||||
--import Dodge.Data.DoubleTree
|
||||
import Dodge.Data.World
|
||||
import Dodge.DoubleTree
|
||||
import Dodge.Euse
|
||||
@@ -308,7 +310,8 @@ updateItemWithOrientation ::
|
||||
updateItemWithOrientation cr m loc@(LocLDT _ itmtree) w =
|
||||
case (ci ^. _1 . itType, ci ^. _2) of
|
||||
(HELD TORCH, _) -> shineTorch cr itmtree m w
|
||||
(HELD LASER, WeaponTargetingSF) -> shineTargetLaser cr itmtree m w
|
||||
--(HELD LASER, WeaponTargetingSF) -> shineTargetLaser cr itmtree m w
|
||||
(HELD LASER, WeaponTargetingSF) -> shineTargetLaser' cr loc w
|
||||
(TARGETING tt, _) -> updateItemTargeting tt cr itm w
|
||||
(ARHUD, _) -> drawARHUD loc w
|
||||
_ -> w
|
||||
@@ -324,13 +327,12 @@ drawARHUD (LocLDT con _) w = fromMaybe w $ do
|
||||
<>~ fold
|
||||
(drawTargetingAR itm w <|> drawMapperAR itm w)
|
||||
|
||||
shineTargetLaser ::
|
||||
shineTargetLaser' ::
|
||||
Creature ->
|
||||
LDTree ItemLink CItem ->
|
||||
(Point3, Q.Quaternion Float) ->
|
||||
LocationLDT ItemLink CItem ->
|
||||
World ->
|
||||
World
|
||||
shineTargetLaser cr itmtree (p, q) w = fromMaybe (w & pointittarg . itTgPos .~ Nothing) $ do
|
||||
shineTargetLaser' cr loc w = fromMaybe (w & pointittarg . itTgPos .~ Nothing) $ do
|
||||
guard (crIsAiming cr)
|
||||
(_, mag) <- find (isammolink . fst) (itmtree ^. ldtLeft)
|
||||
i <- mag ^. ldtValue . _1 . itConsumables
|
||||
@@ -354,6 +356,8 @@ shineTargetLaser cr itmtree (p, q) w = fromMaybe (w & pointittarg . itTgPos .~ N
|
||||
, _lpType = TargetingLaser (_itID itm)
|
||||
}
|
||||
where
|
||||
itmtree = loc ^. locLDT
|
||||
(p,q) = orientLocation $ fmap fst loc
|
||||
x = 1
|
||||
isammolink AmmoInLink{} = True
|
||||
isammolink _ = False
|
||||
@@ -365,6 +369,47 @@ shineTargetLaser cr itmtree (p, q) w = fromMaybe (w & pointittarg . itTgPos .~ N
|
||||
invid = _ilInvID $ _itLocation itm
|
||||
col = blue -- mixColors reloadFrac (1-reloadFrac) blue red
|
||||
|
||||
--shineTargetLaser ::
|
||||
-- Creature ->
|
||||
-- LDTree ItemLink CItem ->
|
||||
-- (Point3, Q.Quaternion Float) ->
|
||||
-- World ->
|
||||
-- World
|
||||
--shineTargetLaser cr itmtree (p, q) w = fromMaybe (w & pointittarg . itTgPos .~ Nothing) $ do
|
||||
-- guard (crIsAiming cr)
|
||||
-- (_, mag) <- find (isammolink . fst) (itmtree ^. ldtLeft)
|
||||
-- i <- mag ^. ldtValue . _1 . itConsumables
|
||||
-- guard $ i >= x
|
||||
-- maginvid <- mag ^? ldtValue . _1 . itLocation . ilInvID
|
||||
-- return $
|
||||
-- w
|
||||
-- & worldEventFlags . at InventoryChange ?~ ()
|
||||
-- & cWorld . lWorld . creatures . ix (_crID cr)
|
||||
-- . crInv
|
||||
-- . ix maginvid
|
||||
-- . itConsumables
|
||||
-- . _Just
|
||||
-- -~ x
|
||||
-- & cWorld . lWorld . lasers
|
||||
-- .:~ Laser
|
||||
-- { _lpPhaseV = 1
|
||||
-- , _lpDir = _crDir cr + argV (Q.qToV2 q)
|
||||
-- , _lpPos = pos
|
||||
-- , _lpColor = col
|
||||
-- , _lpType = TargetingLaser (_itID itm)
|
||||
-- }
|
||||
-- where
|
||||
-- x = 1
|
||||
-- isammolink AmmoInLink{} = True
|
||||
-- isammolink _ = False
|
||||
-- pos = _crPos cr + xyV3 (rotate3 cdir (p + V3 5 0 0))
|
||||
-- cdir = _crDir cr
|
||||
-- itm = itmtree ^. ldtValue . _1
|
||||
-- pointittarg = cWorld . lWorld . creatures . ix cid . crInv . ix invid . itTargeting
|
||||
-- cid = _crID cr
|
||||
-- invid = _ilInvID $ _itLocation itm
|
||||
-- col = blue -- mixColors reloadFrac (1-reloadFrac) blue red
|
||||
|
||||
shineTorch ::
|
||||
Creature ->
|
||||
LDTree ItemLink CItem ->
|
||||
|
||||
@@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
--{-# LANGUAGE StrictData #-}
|
||||
@@ -79,9 +80,52 @@ instance Bifunctor LDTree where
|
||||
(map (bimap f (first f)) l)
|
||||
(map (bimap f (first f)) r)
|
||||
|
||||
|
||||
data ContextDT a
|
||||
= TopDT
|
||||
| LeftwardDT
|
||||
{ _cdtUp :: ContextDT a
|
||||
, _cdtCloseLeft :: [DoubleTree a]
|
||||
, _cdtParent :: a
|
||||
, _cdtCloseRight :: [DoubleTree a]
|
||||
, _cdtFarRight :: [DoubleTree a]
|
||||
}
|
||||
| RightwardDT
|
||||
{ _cdtUp :: ContextDT a
|
||||
, _cdtFarLeft :: [ DoubleTree a]
|
||||
, _cdtCloseLeft :: [DoubleTree a]
|
||||
, _cdtParent :: a
|
||||
, _cdtCloseRight :: [DoubleTree a]
|
||||
}
|
||||
|
||||
data LocationDT b a = LocDT
|
||||
{ _locDtContext :: ContextDT a
|
||||
, _locDT :: DoubleTree a
|
||||
}
|
||||
|
||||
makeLenses ''DoubleTree
|
||||
makeLenses ''LDTree
|
||||
makeLenses ''LocationLDT
|
||||
makeLenses ''ContextLDT
|
||||
|
||||
instance Functor (LocationLDT b) where
|
||||
fmap f (LocLDT c t) = LocLDT (fmap f c) (fmap f t)
|
||||
|
||||
instance Functor (ContextLDT b) where
|
||||
fmap f = \case
|
||||
TopLDT -> TopLDT
|
||||
LeftwardLDT u cl p l cr fr -> LeftwardLDT (fmap f u)
|
||||
(fmap (fmap (fmap f)) cl)
|
||||
(f p)
|
||||
l
|
||||
(fmap (fmap (fmap f)) cr)
|
||||
(fmap (fmap (fmap f)) fr)
|
||||
RightwardLDT u fl cl p l cr -> RightwardLDT (fmap f u)
|
||||
(fmap (fmap (fmap f)) fl)
|
||||
(fmap (fmap (fmap f)) cl)
|
||||
(f p)
|
||||
l
|
||||
(fmap (fmap (fmap f)) cr)
|
||||
|
||||
--deriveJSON defaultOptions ''DoubleTree
|
||||
--deriveJSON defaultOptions ''LabelDoubleTree
|
||||
|
||||
+177
-129
@@ -1,10 +1,10 @@
|
||||
module Dodge.DoubleTree where
|
||||
|
||||
import Dodge.Data.DoubleTree
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import Control.Lens
|
||||
import Data.Bifunctor
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import Data.Monoid
|
||||
import Dodge.Data.DoubleTree
|
||||
|
||||
singleDT :: a -> DoubleTree a
|
||||
singleDT x = DT x [] []
|
||||
@@ -17,172 +17,203 @@ ldtToDT (LDT x l r) = DT x (map (ldtToDT . snd) l) (map (ldtToDT . snd) r)
|
||||
|
||||
-- propagate 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
|
||||
-> LDTree b a -> LDTree c a
|
||||
ldtPropagate ::
|
||||
(c -> b -> c) ->
|
||||
(c -> b -> c) ->
|
||||
c ->
|
||||
LDTree b a ->
|
||||
LDTree 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
|
||||
-> LDTree 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
|
||||
ldtPropagateFold ::
|
||||
(c -> a -> b -> a -> c) ->
|
||||
(c -> a -> b -> a -> c) ->
|
||||
(c -> a -> d -> d) ->
|
||||
c ->
|
||||
LDTree 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
|
||||
|
||||
-- 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-tree, the updated value is used to update a final value (of type d).
|
||||
ldtPropagateFoldTree :: (c -> a -> b -> a -> c)
|
||||
-> (c -> a -> b -> a -> c)
|
||||
-> (c -> LDTree b a -> d -> d)
|
||||
-> c
|
||||
-> LDTree b a
|
||||
-> d
|
||||
-> d
|
||||
ldtPropagateFoldTree lf rf up x t@(LDT v l r) =
|
||||
alaf Endo foldMap (\(s,y) -> ldtPropagateFoldTree lf rf up (rf x v s (_ldtValue y)) y) r
|
||||
. alaf Endo foldMap (\(s,y) -> ldtPropagateFoldTree lf rf up (lf x v s (_ldtValue y)) y) l
|
||||
. up x t
|
||||
ldtPropagateFoldTree ::
|
||||
(c -> a -> b -> a -> c) ->
|
||||
(c -> a -> b -> a -> c) ->
|
||||
(c -> LDTree b a -> d -> d) ->
|
||||
c ->
|
||||
LDTree b a ->
|
||||
d ->
|
||||
d
|
||||
ldtPropagateFoldTree lf rf up x t@(LDT v l r) =
|
||||
alaf Endo foldMap (\(s, y) -> ldtPropagateFoldTree lf rf up (rf x v s (_ldtValue y)) y) r
|
||||
. alaf Endo foldMap (\(s, y) -> ldtPropagateFoldTree lf rf up (lf x v s (_ldtValue y)) y) l
|
||||
. up x t
|
||||
|
||||
ildtPropagate :: (Int -> c -> b -> c) -> (Int -> c -> b -> c)
|
||||
-> c
|
||||
-> LDTree b a -> LDTree c a
|
||||
ildtPropagate ::
|
||||
(Int -> c -> b -> c) ->
|
||||
(Int -> c -> b -> c) ->
|
||||
c ->
|
||||
LDTree b a ->
|
||||
LDTree 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)
|
||||
go f y i (z, t) = (f i y z, ildtPropagate lf rf (f i y z) t)
|
||||
|
||||
ldtPropagateIndices :: LDTree b a -> LDTree b (a, [Either Int Int])
|
||||
ldtPropagateIndices (LDT x l r) = LDT (x,[]) (imap (f Left) l) (imap (f Right) r)
|
||||
ldtPropagateIndices (LDT x l r) = LDT (x, []) (imap (f Left) l) (imap (f Right) r)
|
||||
where
|
||||
f e i (y,t) = (y, second (e i:) <$> ldtPropagateIndices t)
|
||||
f e i (y, t) = (y, second (e i :) <$> ldtPropagateIndices t)
|
||||
|
||||
-- conceptually, in a tree growing from left to right,
|
||||
-- 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
|
||||
doubleTreeToIndentList :: DoubleTree a -> [(a,Int,DoubleTreeNodeType)]
|
||||
doubleTreeToIndentList :: DoubleTree a -> [(a, Int, DoubleTreeNodeType)]
|
||||
doubleTreeToIndentList = dtIL DTRootNode
|
||||
|
||||
dtIL :: DoubleTreeNodeType -> DoubleTree a -> [(a,Int,DoubleTreeNodeType)]
|
||||
dtIL nt (DT x l r) = map doindent (concat (headMap (dtIL DTBottomNode) (dtIL DTMidBelowNode) l))
|
||||
++ [(x,0,nt)]
|
||||
++ map doindent (concat (lastMap (dtIL DTTopNode) (dtIL DTMidAboveNode) r))
|
||||
dtIL :: DoubleTreeNodeType -> DoubleTree a -> [(a, Int, DoubleTreeNodeType)]
|
||||
dtIL nt (DT x l r) =
|
||||
map doindent (concat (headMap (dtIL DTBottomNode) (dtIL DTMidBelowNode) l))
|
||||
++ [(x, 0, nt)]
|
||||
++ map doindent (concat (lastMap (dtIL DTTopNode) (dtIL DTMidAboveNode) r))
|
||||
where
|
||||
doindent (a,b,c) = (a,b+1,c)
|
||||
doindent (a, b, c) = (a, b + 1, c)
|
||||
|
||||
dtToAdjacency :: (a -> Int) -> DoubleTree a -> IM.IntMap [Int]
|
||||
dtToAdjacency f (DT x l r) = IM.insert (f x) (map g l <> map g r)
|
||||
. IM.unions $ map (dtToAdjacency f) $ l <> r
|
||||
where
|
||||
dtToAdjacency f (DT x l r) =
|
||||
IM.insert (f x) (map g l <> map g r)
|
||||
. IM.unions
|
||||
$ map (dtToAdjacency f) $ l <> r
|
||||
where
|
||||
g = f . _dtValue
|
||||
|
||||
dtToIntMapWithRoot :: (a -> Int) -> DoubleTree a -> IM.IntMap (Maybe Int, DoubleTree a)
|
||||
dtToIntMapWithRoot f t@(DT x l r) = IM.insert (f x) (Nothing, t) $
|
||||
foldMap (dtToRootIntMap' (f x) f) $ l <> r
|
||||
dtToIntMapWithRoot f t@(DT x l r) =
|
||||
IM.insert (f x) (Nothing, t) $
|
||||
foldMap (dtToRootIntMap' (f x) f) $ l <> r
|
||||
|
||||
dtToRootIntMap' :: Int -> (a -> Int) -> DoubleTree a -> IM.IntMap (Maybe Int, DoubleTree a)
|
||||
dtToRootIntMap' root f t@(DT x l r) = IM.insert (f x) (Just root, t) $
|
||||
foldMap (dtToRootIntMap' root f) $ l <> r
|
||||
dtToRootIntMap' root f t@(DT x l r) =
|
||||
IM.insert (f x) (Just root, t) $
|
||||
foldMap (dtToRootIntMap' root f) $ l <> r
|
||||
|
||||
dtToUpDownAdj :: (a -> Int) -> DoubleTree a -> IM.IntMap ([Int],[Int])
|
||||
dtToUpDownAdj f (DT x l r) = IM.insert (f x) (map g l , map g r)
|
||||
. IM.unions $ map (dtToUpDownAdj f) $ l <> r
|
||||
where
|
||||
dtToUpDownAdj :: (a -> Int) -> DoubleTree a -> IM.IntMap ([Int], [Int])
|
||||
dtToUpDownAdj f (DT x l r) =
|
||||
IM.insert (f x) (map g l, map g r)
|
||||
. IM.unions
|
||||
$ map (dtToUpDownAdj f) $ l <> 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
|
||||
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
|
||||
|
||||
-- returns an adjacency map with oldest ancestor and direct parent if they exist
|
||||
-- and any left and right children
|
||||
-- allows to propagate failure in the index discovery
|
||||
dtToLRAdjEither :: (a -> Either String Int) -> DoubleTree a
|
||||
-> Either String (IM.IntMap (Maybe (Int,Int),[Int],[Int]))
|
||||
dtToLRAdjEither ::
|
||||
(a -> Either String Int) ->
|
||||
DoubleTree a ->
|
||||
Either String (IM.IntMap (Maybe (Int, Int), [Int], [Int]))
|
||||
dtToLRAdjEither f (DT x l r) = do
|
||||
i <- f x
|
||||
l' <- mapM g l
|
||||
r' <- mapM g r
|
||||
childrenasnodes <- mapM (dtToAdjRootParentEither i i f) $ l <> r
|
||||
return $ IM.insert i (Nothing,l' , r')
|
||||
$ IM.unions childrenasnodes
|
||||
where
|
||||
return $
|
||||
IM.insert i (Nothing, l', r') $
|
||||
IM.unions childrenasnodes
|
||||
where
|
||||
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
|
||||
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
|
||||
|
||||
dtToAdjRootParentEither :: Int -> Int
|
||||
-> (a -> Either String Int) -> DoubleTree a -> Either String (IM.IntMap (Maybe (Int,Int),[Int],[Int]))
|
||||
dtToAdjRootParentEither ::
|
||||
Int ->
|
||||
Int ->
|
||||
(a -> Either String Int) ->
|
||||
DoubleTree a ->
|
||||
Either String (IM.IntMap (Maybe (Int, Int), [Int], [Int]))
|
||||
dtToAdjRootParentEither root par f (DT x l r) = do
|
||||
i <- f x
|
||||
l' <- mapM g l
|
||||
r' <- mapM g r
|
||||
childrenasnodes <- mapM (dtToAdjRootParentEither root i f) $ l <> r
|
||||
return $ IM.insert i (Just (root,par),l' , r') $ IM.unions childrenasnodes
|
||||
where
|
||||
return $ IM.insert i (Just (root, par), l', r') $ IM.unions childrenasnodes
|
||||
where
|
||||
g = f . _dtValue
|
||||
|
||||
ldtToIM :: (a -> Int) -> LDTree b a -> IM.IntMap (LDTree b a)
|
||||
ldtToIM f t@(LDT x l r) = IM.insert (f x) t $ IM.unions $ map (ldtToIM f . snd) $ l <> r
|
||||
ldtToIM f t@(LDT x l r) = IM.insert (f x) t $ IM.unions $ map (ldtToIM f . snd) $ l <> r
|
||||
|
||||
ldtToIndentList :: LDTree b a -> [(a,Int,LabelDoubleTreeNodeType b)]
|
||||
ldtToIndentList :: LDTree b a -> [(a, Int, LabelDoubleTreeNodeType b)]
|
||||
ldtToIndentList = ldtIL LDTRootNode
|
||||
|
||||
ldtIL :: LabelDoubleTreeNodeType b -> LDTree b a -> [(a,Int,LabelDoubleTreeNodeType b)]
|
||||
ldtIL nt (LDT x l r) = map doindent
|
||||
(concat
|
||||
(headMap
|
||||
(\(lab,c) -> ldtIL (LDTBottomNode lab) c)
|
||||
(\(lab,c) -> ldtIL (LDTMidBelowNode lab) c)
|
||||
l
|
||||
)
|
||||
)
|
||||
++ [(x,0,nt)]
|
||||
++ map doindent
|
||||
(concat
|
||||
(lastMap
|
||||
(\(lab,c) -> ldtIL (LDTTopNode lab) c)
|
||||
(\(lab,c) -> ldtIL (LDTMidAboveNode lab) c)
|
||||
r
|
||||
ldtIL :: LabelDoubleTreeNodeType b -> LDTree b a -> [(a, Int, LabelDoubleTreeNodeType b)]
|
||||
ldtIL nt (LDT x l r) =
|
||||
map
|
||||
doindent
|
||||
( concat
|
||||
( headMap
|
||||
(\(lab, c) -> ldtIL (LDTBottomNode lab) c)
|
||||
(\(lab, c) -> ldtIL (LDTMidBelowNode lab) c)
|
||||
l
|
||||
)
|
||||
)
|
||||
++ [(x, 0, nt)]
|
||||
++ map
|
||||
doindent
|
||||
( concat
|
||||
( lastMap
|
||||
(\(lab, c) -> ldtIL (LDTTopNode lab) c)
|
||||
(\(lab, c) -> ldtIL (LDTMidAboveNode lab) c)
|
||||
r
|
||||
)
|
||||
)
|
||||
where
|
||||
doindent (a,b,c) = (a,b+1,c)
|
||||
doindent (a, b, c) = (a, b + 1, c)
|
||||
|
||||
headMap :: (a -> b) -> (a -> b) -> [a] -> [b]
|
||||
headMap f g (x:xs) = f x : map g xs
|
||||
headMap f g (x : xs) = f x : map g xs
|
||||
headMap _ _ [] = []
|
||||
|
||||
lastMap :: (a -> b) -> (a -> b) -> [a] -> [b]
|
||||
lastMap _ _ [] = []
|
||||
lastMap f _ [x] = [f x]
|
||||
lastMap f g (x:xs) = g x : lastMap f g xs
|
||||
lastMap f g (x : xs) = g x : lastMap f g xs
|
||||
|
||||
prettyDT :: (a -> String) -> DoubleTree a -> [String]
|
||||
prettyDT f (DT x l r) = concatMap (map ('/':) . prettyDT f) r
|
||||
++ (f x : concatMap (map ('\\':) . prettyDT f) l)
|
||||
prettyDT f (DT x l r) =
|
||||
concatMap (map ('/' :) . prettyDT f) r
|
||||
++ (f x : concatMap (map ('\\' :) . prettyDT f) l)
|
||||
|
||||
prettyLDT :: (a -> String) -> LDTree b a -> [String]
|
||||
prettyLDT f (LDT x l r) = concatMap (map ('/':) . prettyLDT f . snd) r
|
||||
++ (f x : concatMap (map ('\\':) . prettyLDT f . snd) l)
|
||||
prettyLDT f (LDT x l r) =
|
||||
concatMap (map ('/' :) . prettyLDT f . snd) r
|
||||
++ (f x : concatMap (map ('\\' :) . prettyLDT f . snd) l)
|
||||
|
||||
ldtToLoc :: LDTree b a -> LocationLDT b a
|
||||
ldtToLoc = LocLDT TopLDT
|
||||
@@ -190,13 +221,20 @@ ldtToLoc = LocLDT TopLDT
|
||||
-- should probably do tests for these
|
||||
locUp :: LocationLDT b a -> Maybe (LocationLDT b a)
|
||||
locUp (LocLDT TopLDT _) = Nothing
|
||||
locUp (LocLDT c@LeftwardLDT{} t) = Just $ LocLDT (_cldtUp c)
|
||||
(LDT (_cldtParent c) (_cldtCloseLeft c ++ ((_cldtLink c,t):_cldtCloseRight c)) (_cldtFarRight c))
|
||||
locUp (LocLDT c@RightwardLDT{} t) = Just $ LocLDT (_cldtUp c)
|
||||
(LDT (_cldtParent c) (_cldtFarLeft c) (_cldtCloseLeft c ++ ((_cldtLink c,t):_cldtCloseRight c)))
|
||||
locUp (LocLDT c@LeftwardLDT{} t) =
|
||||
Just $
|
||||
LocLDT
|
||||
(_cldtUp c)
|
||||
(LDT (_cldtParent c) (_cldtCloseLeft c ++ ((_cldtLink c, t) : _cldtCloseRight c)) (_cldtFarRight c))
|
||||
locUp (LocLDT c@RightwardLDT{} t) =
|
||||
Just $
|
||||
LocLDT
|
||||
(_cldtUp c)
|
||||
(LDT (_cldtParent c) (_cldtFarLeft c) (_cldtCloseLeft c ++ ((_cldtLink c, t) : _cldtCloseRight c)))
|
||||
|
||||
locToTop :: LocationLDT b a -> LocationLDT b a
|
||||
locToTop loc = maybe loc locToTop $ locUp loc
|
||||
|
||||
--locToTop = fix $ \x -> fromMaybe x $ locUp x
|
||||
|
||||
locLeftmost :: LocationLDT b a -> LocationLDT b a
|
||||
@@ -207,52 +245,62 @@ locRightmost loc = maybe loc locRightmost $ alaf Last foldMap Just $ locGoRight
|
||||
|
||||
-- should probably do tests for these
|
||||
locGoLeft :: LocationLDT b a -> [LocationLDT b a]
|
||||
locGoLeft (LocLDT c (LDT v l r)) =
|
||||
[ LocLDT (LeftwardLDT c closel v link closer r) t | (closel,(link,t),closer) <- locGoHelp id l]
|
||||
locGoLeft (LocLDT c (LDT v l r)) =
|
||||
[LocLDT (LeftwardLDT c closel v link closer r) t | (closel, (link, t), closer) <- locGoHelp id l]
|
||||
|
||||
-- should probably do tests for these
|
||||
locGoRight :: LocationLDT b a -> [LocationLDT b a]
|
||||
locGoRight (LocLDT c (LDT v l r)) =
|
||||
[ LocLDT (RightwardLDT c l closel v link closer) t | (closel,(link,t),closer) <- locGoHelp id r]
|
||||
locGoRight (LocLDT c (LDT v l r)) =
|
||||
[LocLDT (RightwardLDT c l closel v link closer) t | (closel, (link, t), closer) <- locGoHelp id r]
|
||||
|
||||
-- this seems like it might be very inefficient for large lists
|
||||
-- difference lists?
|
||||
locGoHelp :: (a -> b) -> [a] -> [([a],b,[a])]
|
||||
locGoHelp :: (a -> b) -> [a] -> [([a], b, [a])]
|
||||
locGoHelp f = go []
|
||||
where
|
||||
go cleft (y:ys) = (cleft,f y, ys) : go (cleft <> [y]) ys
|
||||
go cleft (y : ys) = (cleft, f y, ys) : go (cleft <> [y]) ys
|
||||
go _ [] = []
|
||||
|
||||
-- Propgates a value (of type c) down the branches of the ContextLDT.
|
||||
-- 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 context node, the updated value is used to update a final value (of type d).
|
||||
cldtPropagateFold :: (c -> a -> b -> a -> c)
|
||||
-> (c -> a -> b -> a -> c)
|
||||
-> (c -> LocationLDT b a -> d -> d)
|
||||
-> c
|
||||
-> LocationLDT b a
|
||||
-> d
|
||||
-> d
|
||||
cldtPropagateFold lf rf up x loc =
|
||||
alaf Endo foldMap
|
||||
(\(LocLDT con' t') -> cldtPropagateFold
|
||||
lf
|
||||
rf
|
||||
up
|
||||
(lf x (_cldtParent con') (_cldtLink con') (_ldtValue t'))
|
||||
(LocLDT con' t'))
|
||||
cldtPropagateFold ::
|
||||
(c -> a -> b -> a -> c) ->
|
||||
(c -> a -> b -> a -> c) ->
|
||||
(c -> LocationLDT b a -> d -> d) ->
|
||||
c ->
|
||||
LocationLDT b a ->
|
||||
d ->
|
||||
d
|
||||
cldtPropagateFold lf rf up x loc =
|
||||
alaf
|
||||
Endo
|
||||
foldMap
|
||||
( \(LocLDT con' t') ->
|
||||
cldtPropagateFold
|
||||
lf
|
||||
rf
|
||||
up
|
||||
(lf x (_cldtParent con') (_cldtLink con') (_ldtValue t'))
|
||||
(LocLDT con' t')
|
||||
)
|
||||
(locGoLeft loc)
|
||||
. alaf Endo foldMap
|
||||
(\(LocLDT con' t') -> cldtPropagateFold
|
||||
lf
|
||||
rf
|
||||
up
|
||||
(rf x (_cldtParent con') (_cldtLink con') (_ldtValue t'))
|
||||
(LocLDT con' t'))
|
||||
(locGoRight loc)
|
||||
. up x loc
|
||||
. alaf
|
||||
Endo
|
||||
foldMap
|
||||
( \(LocLDT con' t') ->
|
||||
cldtPropagateFold
|
||||
lf
|
||||
rf
|
||||
up
|
||||
(rf x (_cldtParent con') (_cldtLink con') (_ldtValue t'))
|
||||
(LocLDT con' t')
|
||||
)
|
||||
(locGoRight loc)
|
||||
. up x loc
|
||||
|
||||
reduceLocLDT :: Monoid m => (LocationLDT b a -> m) -> LocationLDT b a -> m
|
||||
reduceLocLDT f x =foldMap (reduceLocLDT f) (locGoLeft x) <> f x
|
||||
<> foldMap (reduceLocLDT f) (locGoRight x)
|
||||
reduceLocLDT f x =
|
||||
foldMap (reduceLocLDT f) (locGoLeft x) <> f x
|
||||
<> foldMap (reduceLocLDT f) (locGoRight x)
|
||||
|
||||
@@ -1,7 +1,11 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
module Dodge.Item.Orientation (
|
||||
orientAttachment,
|
||||
orientLocation,
|
||||
) where
|
||||
|
||||
import Dodge.DoubleTree
|
||||
import Dodge.Data.DoubleTree
|
||||
import Dodge.Data.ComposedItem
|
||||
import Dodge.Data.Item
|
||||
import Geometry.Data
|
||||
@@ -11,6 +15,7 @@ orientChild :: Item -> (Point3, Q.Quaternion Float)
|
||||
orientChild itm = case _itType itm of
|
||||
HELD TORCH -> (V3 0 5 0, Q.qID)
|
||||
HELD LASER -> (V3 15 (-5) 0, Q.qID)
|
||||
ATTACH UNDERBARRELSLOT -> (V3 10 (-8) 0, Q.qID)
|
||||
_ -> (0, Q.qID)
|
||||
|
||||
orientByLink :: Item -> ItemLink -> (Point3, Q.Quaternion Float)
|
||||
@@ -22,9 +27,18 @@ orientByLink itm lt = case (_itType itm, lt) of
|
||||
|
||||
orientAttachment :: Item -> ItemLink -> Item -> (Point3, Q.Quaternion Float)
|
||||
orientAttachment par lnk ch = case (_itType par, lnk, _itType ch) of
|
||||
(ATTACH UNDERBARRELSLOT, _, _) -> (V3 (-5) (-8) 0, Q.qID)
|
||||
-- (HELD BURSTRIFLE, _, HELD TORCH) -> (V3 20 0 0, Q.axisAngle (V3 0 0 1) (pi/2))
|
||||
-- (HELD LAUNCHER, _, HELD TORCH) -> (V3 0 20 0, Q.axisAngle (V3 0 0 1) (pi/4))
|
||||
_ -> (t1 + Q.rotate q1 t2, q1 * q2)
|
||||
where
|
||||
(t1, q1) = orientByLink par lnk
|
||||
(t2, q2) = orientChild ch
|
||||
|
||||
orientLocation :: LocationLDT ItemLink Item -> (Point3, Q.Quaternion Float)
|
||||
orientLocation = \case
|
||||
(LocLDT TopLDT _) -> (0, Q.qID)
|
||||
(LocLDT c t) -> (p + Q.rotate q p1, q * q1)
|
||||
where
|
||||
(p,q) = orientLocation (LocLDT (_cldtUp c) (singleLDT (_cldtParent c)))
|
||||
(p1,q1) = orientAttachment (_cldtParent c) (_cldtLink c) (_ldtValue t)
|
||||
|
||||
Reference in New Issue
Block a user