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

Tweak use location

Browse Source
This commit is contained in:
justin
2025-06-30 01:02:27 +01:00
parent d88aed10c7
commit 8a00450e3f
9 changed files with 226 additions and 210 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/Impulse/UseItem.hs
+11 -17
View File
@@ -1,16 +1,14 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.Creature.Impulse.UseItem (
useItem,
) where
module Dodge.Creature.Impulse.UseItem (useItem) where
import Dodge.Equipment
import Control.Lens
import Data.Maybe
import Dodge.Data.ComposedItem
import Dodge.Data.DoubleTree
import Dodge.Data.World
import Dodge.DoubleTree
import Dodge.Equipment
import Dodge.HeldUse
import Dodge.Inventory
import Dodge.Item.Grammar
@@ -21,25 +19,21 @@ useItem :: Int -> PressType -> World -> Maybe World
useItem invid pt w = fmap (worldEventFlags . at InventoryChange ?~ ()) $ do
cr <- w ^? cWorld . lWorld . creatures . ix 0
itmloc <- allInvLocs (_crInv cr) ^? ix invid . _2
let usedloc = useLocation itmloc
let usedloc = chooseUseLocation itmloc
useItemLoc cr usedloc pt w
useItemLoc :: Creature ->
LocationLDT ItemLink OItem ->
PressType ->
World ->
Maybe World
useItemLoc :: Creature -> LocationLDT ItemLink OItem -> PressType -> World -> Maybe World
useItemLoc cr loc pt w
| HeldPlatformSF <- sf
, fromMaybe False $ loc ^? locLDT . ldtValue . _1 . itLocation . ilIsRoot
, Aiming {} <- cr ^. crStance . posture =
return $ heldEffect pt (bimap id id ldt) cr w
, Aiming{} <- cr ^. crStance . posture =
return $ gadgetEffect pt loc cr w
| GadgetPlatformSF <- sf =
return $ gadgetEffect pt loc cr w
| UnderBarrelPlatformSF <- sf
, fromMaybe False $ loc ^? locLDT . ldtValue . _1 . itLocation . ilIsAttached
, Aiming {} <- cr ^. crStance . posture =
return $ heldEffect pt (bimap id id ldt) cr w
, Aiming{} <- cr ^. crStance . posture =
return $ gadgetEffect pt loc cr w
| RemoteDetonatorSF <- sf
, pt == InitialPress =
return $ activateDetonator ldt w
@@ -62,15 +56,15 @@ useItemLoc cr loc pt w
ldt = loc ^. locLDT
itm = ldt ^. ldtValue . _1
useLocation :: LocationLDT ItemLink OItem -> LocationLDT ItemLink OItem
useLocation loc
chooseUseLocation :: LocationLDT ItemLink OItem -> LocationLDT ItemLink OItem
chooseUseLocation loc
| isJust $ loc ^? locLDT . ldtValue . _1 . itType . ibtEquip = loc
| isJust $ loc ^? locLDT . ldtValue . _1 . itUse . uaParams . apProjectiles . ix 0 =
loc
| sf <- loc ^. locLDT . ldtValue . _2
, structureUseAtLoc sf =
loc
| otherwise = locToTop loc
| otherwise = maybe loc chooseUseLocation $ locUp loc
structureUseAtLoc :: ItemStructuralFunction -> Bool
structureUseAtLoc = \case
src/Dodge/Creature/State.hs
+1 -2
View File
@@ -3,7 +3,6 @@ module Dodge.Creature.State (
doDamage,
) where
import Data.Bifunctor
import Dodge.Data.DoubleTree
import Dodge.Item.Orientation
import Dodge.Item.UseDelay
@@ -218,7 +217,7 @@ doAnyEquipmentEffect loc cr = case itm ^? itLocation . ilEquipSite . _Just of
tryUseParent :: LocationLDT ItemLink OItem -> World -> World
tryUseParent loc w = fromMaybe w $ do
t <- locUp loc
let t' = bimap id id $ t ^. locLDT
let t' = t ^. locLDT
cr <- w ^? cWorld . lWorld . creatures . ix 0
return $ heldEffectNoHammerCheck t' cr w
src/Dodge/HeldUse.hs
-1
View File
@@ -3,7 +3,6 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.HeldUse (
heldEffect,
gadgetEffect,
heldEffectNoHammerCheck,
mcUseHeld,
src/Dodge/Item/Orientation.hs
+17 -21
View File
@@ -13,7 +13,7 @@ import Dodge.DoubleTree
import Geometry.Data
import qualified Quaternion as Q
orientChild :: Item -> (Point3, Q.Quaternion Float)
orientChild :: Item -> Point3Q
orientChild itm = case _itType itm of
HELD TORCH -> (V3 0 5 0, Q.qID)
--HELD LASER -> (V3 15 (-5) 0, Q.qID)
@@ -23,14 +23,14 @@ orientChild itm = case _itType itm of
where
r = Q.axisAngle (V3 0 0 1) (-pi/4)
orientByLink :: Item -> ItemLink -> (Point3, Q.Quaternion Float)
orientByLink :: Item -> ItemLink -> Point3Q
orientByLink itm lt = case (_itType itm, lt) of
(HELD FLAMETHROWER, AmmoInLink{}) -> (V3 4 (-6) 0, Q.qID)
(HELD _, AmmoInLink{}) -> (V3 7 (-2) 0, Q.qID)
(HELD _, WeaponScopeLink) -> (V3 5 0 5, Q.qID)
_ -> (0, Q.qID)
orientAttachment :: Item -> ItemLink -> Item -> (Point3, Q.Quaternion Float)
orientAttachment :: Item -> ItemLink -> Item -> Point3Q
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))
@@ -40,32 +40,28 @@ orientAttachment par lnk ch = case (_itType par, lnk, _itType ch) of
(t1, q1) = orientByLink par lnk
(t2, q2) = orientChild ch
orientLocation' ::
(Point3, Q.Quaternion Float) ->
LocationLDT ItemLink Item ->
(Point3, Q.Quaternion Float)
orientLocation' :: Point3Q -> LocationLDT ItemLink Item -> Point3Q
orientLocation' x = \case
(LocLDT TopLDT _) -> x
(LocLDT c t) -> (p + Q.rotate q p1, q * q1)
where
(p, q) = orientLocation' x (LocLDT (_cldtUp c) (singleLDT (_cldtParent c)))
(p1, q1) = orientAttachment (_cldtParent c) (_cldtLink c) (_ldtValue t)
(LocLDT c t) -> orientLocation' x (LocLDT (_cldtUp c) (singleLDT (_cldtParent c)))
`Q.comp` orientAttachment (_cldtParent c) (_cldtLink c) (_ldtValue t)
-- (LocLDT c t) -> (p + Q.rotate q p1, q * q1)
-- where
-- (p, q) = orientLocation' x (LocLDT (_cldtUp c) (singleLDT (_cldtParent c)))
-- (p1, q1) = orientAttachment (_cldtParent c) (_cldtLink c) (_ldtValue t)
orientLocation ::
(Point3, Q.Quaternion Float) ->
LocationLDT ItemLink Item ->
(Point3, Q.Quaternion Float) ->
(Point3, Q.Quaternion Float)
orientLocation x loc (p1, q1) = (p + Q.rotate q p1, q * q1)
where
(p, q) = orientLocation' x loc
orientLocation :: Point3Q -> LocationLDT ItemLink Item -> Point3Q -> Point3Q
orientLocation x = Q.comp . orientLocation' x
--orientLocation x loc (p1, q1) = (p + Q.rotate q p1, q * q1)
-- where
-- (p, q) = orientLocation' x loc
propagateOrientation :: LDTree ItemLink CItem -> LDTree ItemLink OItem
propagateOrientation = ldtStartPropagate g f
where
g (x,y) = (x,y,(V3 0 0 0,Q.qID))
f (x,_,(p,q)) i (y,y1) = let (p1,q1) = orientAttachment x i y
in (y,y1,(p + Q.rotate q p1, q * q1))
f (x,_,pq) i (y,y1) = (y,y1,Q.comp pq $ orientAttachment x i y)
--propagateOrientation' :: LDTree ItemLink Item
-- -> LDTree ItemLink (Item, (Point3, Q.Quaternion Float))
src/Dodge/Projectile/Create.hs
-3
View File
@@ -3,9 +3,6 @@ module Dodge.Projectile.Create (
PJStabiliser (..),
) where
--import Dodge.Data.ComposedItem
--import Dodge.Data.DoubleTree
import qualified Quaternion as Q
import Dodge.Data.Muzzle
import Data.Maybe
src/Dodge/WorldEffect.hs
+1 -2
View File
@@ -45,8 +45,7 @@ doWdWd we = case we of
UseInvItem invid pt -> \w -> fromMaybe w (useItem invid pt w)
WdWdBurstFireRepetition cid invid -> \w -> fromMaybe w $ do
cr <- w ^? cWorld . lWorld . creatures . ix cid
itree <- bimap id id <$>
allInvLocs (cr ^. crInv) ^? ix invid . _2 . locLDT
itree <- allInvLocs (cr ^. crInv) ^? ix invid . _2 . locLDT
return $ heldEffectMuzzles itree cr w
accessTerminal :: Maybe Int -> World -> World
src/Geometry/Data.hs
+41 -20
View File
@@ -1,47 +1,67 @@
--{-# LANGUAGE DeriveGeneric #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{- |
WARNING: orphan instances concerning Aeson classes and Linear.Vx datatypes have been introduced.
The warnings have been disabled.
-}
module Geometry.Data
( module Geometry.Data
, V2 (..)
, V3 (..)
, V4 (..)
)
where
module Geometry.Data (
module Geometry.Data,
V2 (..),
V3 (..),
V4 (..),
) where
import Data.Aeson
import qualified Linear.Quaternion as Q
import Linear.V2
import Linear.V3
import Linear.V4
type Int2 = V2 Int
type Int2 = V2 Int
type Point2 = V2 Float
instance ToJSON a => ToJSON (V2 a) where
toEncoding = genericToEncoding defaultOptions
toEncoding = genericToEncoding defaultOptions
instance FromJSON a => FromJSON (V2 a)
instance ToJSON a => ToJSONKey (V2 a)
instance FromJSON a => FromJSONKey (V2 a)
type Point3 = V3 Float
instance ToJSON a => ToJSON (V3 a) where
toEncoding = genericToEncoding defaultOptions
toEncoding = genericToEncoding defaultOptions
instance FromJSON a => FromJSON (V3 a)
type Point4 = V4 Float
instance ToJSON a => ToJSON (V4 a) where
toEncoding = genericToEncoding defaultOptions
toEncoding = genericToEncoding defaultOptions
instance FromJSON a => FromJSON (V4 a)
type DPoint2 = (Point2,Float)
type DPoint2 = (Point2, Float)
toV2 :: (a,a) -> V2 a
toV2 (a,b) = V2 a b
toV3 :: (a,a,a) -> V3 a
toV3 (a,b,c) = V3 a b c
toV4 :: (a,a,a,a) -> V4 a
toV4 (a,b,c,d) = V4 a b c d
type QFloat = Q.Quaternion Float
fromV3 :: V3 a -> (a,a,a)
fromV3 (V3 a b c) = (a,b,c)
type Point3Q = (Point3, QFloat)
toV2 :: (a, a) -> V2 a
toV2 (a, b) = V2 a b
toV3 :: (a, a, a) -> V3 a
toV3 (a, b, c) = V3 a b c
toV4 :: (a, a, a, a) -> V4 a
toV4 (a, b, c, d) = V4 a b c d
fromV3 :: V3 a -> (a, a, a)
fromV3 (V3 a b c) = (a, b, c)
uncurryV :: (a -> a -> b) -> V2 a -> b
{-# INLINE uncurryV #-}
@@ -49,5 +69,6 @@ uncurryV f (V2 x y) = f x y
fstV2 :: V2 a -> a
fstV2 (V2 x _) = x
sndV2 :: V2 a -> a
sndV2 (V2 _ x) = x
src/Quaternion.hs
+6
View File
@@ -15,6 +15,7 @@ module Quaternion (
qToV2,
rotateToZ,
vToQuat,
comp,
module Linear.Quaternion,
) where
@@ -54,4 +55,9 @@ qToV2 = (\(V3 x y _) -> V2 x y) . qToV3
qID :: Q.Quaternion Float
qID = Q.axisAngle (V3 1 0 0) 0
comp :: (Point3, Q.Quaternion Float)
-> (Point3, Q.Quaternion Float)
-> (Point3, Q.Quaternion Float)
comp (p,q) (p1,q1) = (p + Q.rotate q p1, q * q1)
--deriving instance (Flat a => Flat (Quaternion a))