Move towards being able to orient positions on attached items

ghcidOutput

@@ -1,99 +1 @@
-/home/justin/Haskell/loop/src/Dodge/Item/Grammar.hs:25:9: warning: [-Wname-shadowing]
+All good (605 modules, at 20:13:06)
-    This binding for ‘x’ shadows the existing binding
-      bound at /home/justin/Haskell/loop/src/Dodge/Item/Grammar.hs:23:12
-   |
-25 |     noa x y = (x, ILink y orientAttachment)
-   |         ^
-/home/justin/Haskell/loop/src/Dodge/Item/Grammar.hs:25:11: warning: [-Wname-shadowing]
-    This binding for ‘y’ shadows the existing binding
-      bound at /home/justin/Haskell/loop/src/Dodge/Item/Grammar.hs:23:14
-   |
-25 |     noa x y = (x, ILink y orientAttachment)
-   |           ^
-/home/justin/Haskell/loop/src/Dodge/Item/Grammar.hs:93:5-7: warning: [-Wunused-local-binds]
-    Defined but not used: ‘noa’
-   |
-93 |     noa x y = (x, ILink y orientAttachment)
-   |     ^^^
-/home/justin/Haskell/loop/src/Dodge/Item/Grammar.hs:94:5-11: warning: [-Wunused-local-binds]
-    Defined but not used: ‘nolinks’
-   |
-94 |     nolinks x = (itm, x, LTest (const Nothing) (const Nothing))
-   |     ^^^^^^^
-/home/justin/Haskell/loop/src/Dodge/Item/Grammar.hs:95:5-11: warning: [-Wunused-local-binds]
-    Defined but not used: ‘isolate’
-   |
-95 |     isolate = (itm, UncomposableIsolateSF, LTest (const Nothing) (const Nothing))
-   |     ^^^^^^^
-/home/justin/Haskell/loop/src/Dodge/Item/Grammar.hs:98:1-17: warning: [-Wunused-top-binds]
-    Defined but not used: ‘ammoComposedItem'’
-   |
-98 | ammoComposedItem' itm = fromMaybe (error "in ammoComposedItem, wrong item") $ do
-   | ^^^^^^^^^^^^^^^^^
-/home/justin/Haskell/loop/src/Dodge/Item/HeldOffset.hs:26:1: warning: [-Wunused-top-binds]
-    Defined but not used: ‘heldItemRelativeOrient’
-   |
-26 | heldItemRelativeOrient itm cr (p,q)
-   | ^^^^^^^^^^^^^^^^^^^^^^
-/home/justin/Haskell/loop/src/Dodge/Item/HeldOffset.hs:44:5: warning: [-Wunused-local-binds]
-    Defined but not used: ‘handD’
-   |
-44 |     handD = 15
-   |     ^^^^^
-/home/justin/Haskell/loop/src/Dodge/Item/HeldOffset.hs:44:13: warning: [-Wtype-defaults]
-    • Defaulting the following constraint to type ‘Integer’
-        Num p0 arising from the literal ‘15’
-    • In the expression: 15
-      In an equation for ‘handD’: handD = 15
-      In an equation for ‘heldItemRelativeOrient’:
-          heldItemRelativeOrient itm cr (p, q)
-            | _posture (_crStance cr) == Aiming = (p, q)
-            | isTwoHandFlat = (p, q)
-            | isOneHand = (p, q)
-            | otherwise = (p, q)
-            where
-                handD = 15
-                handPos
-                  = case cr ^? crStance . carriage of
-                      Just (Walking x LeftForward) -> f x * 50
-                      _ -> 0
-                isOneHand
-                  = itm ^? itUseAimStance == Just OneHand
-                      || isNothing (itm ^? itUseAimStance)
-                isTwoHandFlat = itm ^? itUseAimStance == Just TwoHandFlat
-                ....
-   |
-44 |     handD = 15
-   |             ^^
-/home/justin/Haskell/loop/src/Dodge/Item/HeldOffset.hs:45:5: warning: [-Wunused-local-binds]
-    Defined but not used: ‘handPos’
-   |
-45 |     handPos = case cr ^? crStance . carriage of
-   |     ^^^^^^^
-/home/justin/Haskell/loop/src/Dodge/Item/HeldOffset.hs:46:45: warning: [-Wtype-defaults]
-    • Defaulting the following constraints to type ‘Double’
-        (Num a0)
-          arising from a use of ‘*’
-          at /home/justin/Haskell/loop/src/Dodge/Item/HeldOffset.hs:46:45
-        (Fractional a0)
-          arising from a use of ‘f’
-          at /home/justin/Haskell/loop/src/Dodge/Item/HeldOffset.hs:46:41-43
-    • In the expression: f x * 50
-      In a case alternative: Just (Walking x LeftForward) -> f x * 50
-      In the expression:
-        case cr ^? crStance . carriage of
-          Just (Walking x LeftForward) -> f x * 50
-          _ -> 0
-   |
-46 |         Just (Walking x LeftForward) -> f x * 50
-   |                                             ^
-/home/justin/Haskell/loop/src/Dodge/Item/HeldOffset.hs:53:5: warning: [-Wunused-local-binds]
-    Defined but not used: ‘f’
-   |
-53 |     f i = 0.1 * fromIntegral (sLen - i) / fromIntegral sLen
-   |     ^
-/home/justin/Haskell/loop/src/Dodge/Item/HeldOffset.hs:54:5: warning: [-Wunused-local-binds]
-    Defined but not used: ‘sLen’
-   |
-54 |     sLen = _strideLength $ _crStance cr
-   |     ^^^^

src/Dodge/Data/Item/Effect.hs

@@ -26,6 +26,7 @@ data ItInvEffect
     | CreateShieldWall
     | RemoveShieldWall
     | EffectWhileRoot ItInvEffect
+    | EffectWhileAttached ItInvEffect
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 data ItFloorEffect = NoFloorEffect

src/Dodge/ItEffect.hs

@@ -17,6 +17,7 @@ doInvEffect iie = case iie of
     CreateShieldWall -> createShieldWall
     RemoveShieldWall -> removeShieldWall
     EffectWhileRoot f -> rootNotrootEff f NoInvEffect
+    EffectWhileAttached f -> effectWhileAttached f
 
 doFloorEffect :: ItFloorEffect -> Int -> World -> World
 doFloorEffect NoFloorEffect = const id
@@ -26,6 +27,11 @@ rootNotrootEff f g it
     | it ^? itLocation . ilIsRoot == Just True = doInvEffect f it
     | otherwise = doInvEffect g it
 
+effectWhileAttached :: ItInvEffect -> Item -> Creature -> World -> World
+effectWhileAttached f it
+    | it ^? itLocation . ilIsAttached == Just True = doInvEffect f it
+    | otherwise = const id
+
 --timeScrollEffect :: Item -> Creature -> World -> World
 --timeScrollEffect itm _ w = w & timeFlow .~ ScrollTimeFlow
 --    { _scrollSmoothing = 0
@@ -58,14 +64,5 @@ chargeIfEquipped itm cr
     ptrWpCharge = cWorld . lWorld . creatures . ix (_crID cr) . crInv . ix invid . itUse . leftConsumption . wpCharge
     maxcharge = itm ^?! itUse . leftConsumption . wpMaxCharge
 
---resetAttachmentEffect :: Item -> Creature -> World -> World
---resetAttachmentEffect itm cr w
---    | _ieCounter iteff < 0 = w & pointToIt . itAttachment .~ NoItAttachment
---    | otherwise = w & pointToIt . itEffect . ieCounter -~ 1
---  where
---    iteff = _itEffect itm
---    invid = _ipInvID $ _itLocation itm
---    pointToIt = cWorld . creatures . ix (_crID cr) . crInv . ix invid
-
 createHeldLight :: Item -> Creature -> World -> World
 createHeldLight itm cr = createTorchLightOffset cr itm 0

src/Dodge/Item/Grammar.hs

@@ -22,7 +22,7 @@ useBreakL' :: [(ItemStructuralFunction, ComposeLinkType)] -> [(ItemStructuralFun
     -> LinkTest ItemLink
 useBreakL' x y = useBreakListsLinkTest (map (uncurry noa) x) (map (uncurry noa) y)
   where
-    noa x y = (x, ILink y orientAttachment)
+    noa a b = (a, ILink b orientAttachment)
     
 
 useBreakListsLinkTest :: [(ItemStructuralFunction, a)] -> [(ItemStructuralFunction, a)] -> LinkTest a
@@ -40,12 +40,10 @@ useBreakListsLinkTest llist rlist = LTest ltest rtest
 itemToBreakLists :: Item 
     -> ([(ItemStructuralFunction, ComposeLinkType)] , [(ItemStructuralFunction, ComposeLinkType)])
 itemToBreakLists itm = case itm ^. itType of
+    HELD TORCH -> (getAmmoLinks itm,[])
     HELD {} -> 
-            ( map
+            ( getAmmoLinks itm
-                (\(i, a) -> (AmmoMagSF a,AmmoInLink i a))
+            , [(WeaponTargetingSF,WeaponTargetingLink), (WeaponScopeSF,WeaponScopeLink)]
-                (IM.toList $ itm ^. itUse . heldAmmoTypes)
-            ,
-            [(WeaponTargetingSF,WeaponTargetingLink), (WeaponScopeSF,WeaponScopeLink)]
             )
     AMMOMAG {} -> fromMaybe ([],[]) $ do
         atype <- itm ^? itUse . amagType
@@ -59,8 +57,14 @@ itemToBreakLists itm = case itm ^. itType of
     TARGETING{} -> ([(AugmentedHUDSF,AugmentedHUDLink)],[])
     _ -> ([],[])
 
+getAmmoLinks :: Item -> [(ItemStructuralFunction, ComposeLinkType)]
+getAmmoLinks itm = map
+                (\(i, a) -> (AmmoMagSF a,AmmoInLink i a))
+                (IM.toList $ itm ^. itUse . heldAmmoTypes)
+
 itemToFunction :: Item -> ItemStructuralFunction
 itemToFunction itm = case itm ^. itType of
+    HELD TORCH -> WeaponScopeSF
     HELD {} -> WeaponPlatformSF
     AMMOMAG {} -> maybe UncomposableIsolateSF AmmoMagSF $ itm ^? itUse . amagType
     ATTACH REMOTESCREEN -> RemoteScreenSF
@@ -78,39 +82,7 @@ simplePCI :: Item -> PartiallyComposedItem ItemLink
 simplePCI itm = (itm, itemToFunction itm, uncurry useBreakL' $ itemToBreakLists itm)
 
 basePartiallyComposedItem' :: Item -> PartiallyComposedItem ItemLink
-basePartiallyComposedItem' itm = case itm ^. itType of
+basePartiallyComposedItem' itm = simplePCI itm
---    AMMOMAG _ -> ammoComposedItem' itm
---    TARGETING{} -> (itm, WeaponTargetingSF, useBreakListsLinkTest [noa AugmentedHUDSF AugmentedHUDLink] [])
---    ATTACH REMOTESCREEN -> nolinks RemoteScreenSF
---    ATTACH BULLETSYNTHESIZER -> (itm, AmmoModifierSF BulletAmmo, LTest (const Nothing) (const Nothing))
---    LEFT{} -> isolate
---    EQUIP{} -> isolate
---    CONSUMABLE{} -> isolate
---    CRAFT{} -> isolate
-    _ -> simplePCI itm
-  where
-
-    noa x y = (x, ILink y orientAttachment)
-    nolinks x = (itm, x, LTest (const Nothing) (const Nothing))
-    isolate = (itm, UncomposableIsolateSF, LTest (const Nothing) (const Nothing))
-
-ammoComposedItem' :: Item -> PartiallyComposedItem ItemLink
-ammoComposedItem' itm = fromMaybe (error "in ammoComposedItem, wrong item") $ do
-    atype <- itm ^? itUse . amagType
-    return
-        ( itm
-        , AmmoMagSF atype
-        , useBreakListsLinkTest
-            [ noa (AmmoModifierSF atype) AmmoModLink
-            , noa (AmmoTargetingSF atype) AmmoTargetingLink
-            , noa (AmmoPayloadSF atype) AmmoPayloadLink
-            , noa (AmmoEffectSF atype) AmmoEffectLink
-            , noa RemoteScreenSF RemoteScreenLink
-            ]
-            []
-        )
-  where
-    noa x y = (x, ILink y orientAttachment)
 
 type LDTComb a b = LabelDoubleTree b a -> LabelDoubleTree b a -> Maybe (LabelDoubleTree b a)
 

src/Dodge/Item/Held/Utility.hs

@@ -26,10 +26,10 @@ latchkey _ = defaultHeldItem
 torch :: Item
 torch =
     defaultHeldItem
-        & itEffect . ieInv .~ EffectWhileRoot CreateHeldLight
+        & itEffect . ieInv .~ EffectWhileAttached CreateHeldLight
         & itType .~ HELD TORCH
-        -- & itUse . heldAim . aimHandlePos .~ 5
         & itUse . heldAim . aimMuzzles . ix 0 . mzPos . _x .~ 10
+        & itUse . heldAmmoTypes .~ singleAmmo ElectricalAmmo
 
 {- |
 Sends out pulses that display walls.

src/Dodge/Item/HeldOffset.hs

@@ -2,9 +2,10 @@ module Dodge.Item.HeldOffset (
     turretItemOffset,
     twoFlatHRot,
     heldItemOffset,
+    heldItemRelativeOrient,
 ) where
 
-import qualified Linear.Quaternion as Q
+import qualified Quaternion as Q
 import Data.Maybe
 import Dodge.Creature.HandPos
 import Dodge.Data.Creature
@@ -22,24 +23,33 @@ transToHandle itm = fromMaybe id $ do
     V2 x y <- itm ^? itUse . heldAim . aimHandlePos
     return (-.-.- V3 x y 0)
 
+-- there is a lot of duplication going on here, and also need to check
+-- rotations
 heldItemRelativeOrient :: Item -> Creature -> (Point3, Q.Quaternion Float) -> (Point3, Q.Quaternion Float)
 heldItemRelativeOrient itm cr (p,q)
-    |  _posture (_crStance cr) == Aiming = (p,q)
+    |  _posture (_crStance cr) == Aiming =
-    |  isTwoHandFlat = (p,q)
+        (p +.+.+ aimingWeaponZeroPos cr itm `v2z` shoulderHeight, Q.qID * q)
---        (+.+.+ V3 (_crRad cr) 0 handD)
+    |  isTwoHandFlat = 
---            . rotate3 (twoFlatHRot cr)
+        ( (+.+.+ V3 (_crRad cr) 0 handD)
---            . transToHandle itm
+            . rotate3 (twoFlatHRot cr)
-    |  isOneHand = (p,q)
+            $ transToHandle itm p 
---        (+.+.+ V3 0 0 handD)
+        , (Q.axisAngle (V3 0 0 1) (twoFlatHRot cr)) * q
---            . (+.+.+ V3 (_crRad cr * 0.7 + handPos) (_crRad cr * negate 0.7) 0)
+        )
---            . (+.+.+ V3 (-2) 0 0)
+    |  isOneHand = 
---            . transToHandle itm
+            ( (+.+.+ V3 0 0 handD)
-    | otherwise = (p,q)
+            . (+.+.+ V3 (_crRad cr * 0.7 + handPos) (_crRad cr * negate 0.7) 0)
---        (+.+.+ V3 0 0 handD)
+            . (+.+.+ V3 (-2) 0 0)
---            . (+.+.+ V3 (_crRad cr) 0 0)
+            $ transToHandle itm p
---            . rotate3 (strideRot cr + 1.2)
+            , Q.qID * q
---            . (+.+.+ V3 (-8) 0 0)
+            )
---            . transToHandle itm
+    | otherwise = 
+        ( (+.+.+ V3 0 0 handD)
+        . (+.+.+ V3 (_crRad cr) 0 0)
+        . rotate3 (strideRot cr + 1.2)
+        . (+.+.+ V3 (-8) 0 0)
+        $ transToHandle itm p
+        , (Q.axisAngle (V3 0 0 1) (strideRot cr + 1.2)) * q
+        )
   where
     handD = 15
     handPos = case cr ^? crStance . carriage of
@@ -54,36 +64,7 @@ heldItemRelativeOrient itm cr (p,q)
     sLen = _strideLength $ _crStance cr
 
 heldItemOffset :: Item -> Creature -> Point3 -> Point3
-heldItemOffset itm cr
+heldItemOffset itm cr p = fst (heldItemRelativeOrient itm cr (p,Q.qID))
-    |  _posture (_crStance cr) == Aiming =
-        (+.+.+ aimingWeaponZeroPos cr itm `v2z` shoulderHeight)
-    |  isTwoHandFlat =
-        (+.+.+ V3 (_crRad cr) 0 handD)
-            . rotate3 (twoFlatHRot cr)
-            . transToHandle itm
-    |  isOneHand =
-        (+.+.+ V3 0 0 handD)
-            . (+.+.+ V3 (_crRad cr * 0.7 + handPos) (_crRad cr * negate 0.7) 0)
-            . (+.+.+ V3 (-2) 0 0)
-            . transToHandle itm
-    | otherwise =
-        (+.+.+ V3 0 0 handD)
-            . (+.+.+ V3 (_crRad cr) 0 0)
-            . rotate3 (strideRot cr + 1.2)
-            . (+.+.+ V3 (-8) 0 0)
-            . transToHandle itm
-  where
-    handD = 15
-    handPos = case cr ^? crStance . carriage of
-        Just (Walking x LeftForward) -> f x * 50
-        _ -> 0
-    isOneHand =
-        itm ^? itUseAimStance == Just OneHand
-            || isNothing (itm ^? itUseAimStance)
-    isTwoHandFlat = itm ^? itUseAimStance == Just TwoHandFlat
-    itUseAimStance = itUse . heldAim . aimStance
-    f i = 0.1 * fromIntegral (sLen - i) / fromIntegral sLen
-    sLen = _strideLength $ _crStance cr
 
 shoulderHeight :: Float
 shoulderHeight = 18

src/Dodge/Item/Orientation.hs

@@ -16,6 +16,7 @@ orientByLink :: Item -> ComposeLinkType -> (Point3, Q.Quaternion Float)
 orientByLink itm lt = case (_itType itm,lt) of
     (HELD FLAMETHROWER, AmmoInLink{}) -> (V3 4 (-6) 0, Q.axisAngle (V3 1 0 0) 0)
     (HELD _,AmmoInLink{}) -> (V3 7 (-2) 0, Q.axisAngle (V3 1 0 0) 0)
+    (HELD _,WeaponScopeLink) -> (V3 5 0 5, Q.axisAngle (V3 1 0 0) 0)
     _ -> (0,Q.axisAngle (V3 1 0 0) 0)
 
 orientAttachment :: Item -> ComposeLinkType -> Item -> Maybe (Point3, Q.Quaternion Float)

src/Dodge/LightSource/Torch.hs

@@ -1,5 +1,7 @@
 module Dodge.LightSource.Torch where
 
+import Color
+import Dodge.WorldEvent.Flash
 import Dodge.Data.World
 import Dodge.Item.Draw -- heldItemOffset needs to be moved somewhere more sensible
 import Dodge.LightSource -- this needs to be split!
@@ -7,12 +9,14 @@ import Geometry
 import LensHelp
 
 createTorchLightOffset :: Creature -> Item -> Point3 -> World -> World
-createTorchLightOffset cr it off =
+createTorchLightOffset cr it off = muzFlareAt yellow pos (_crDir cr) .
-    cWorld . lWorld . tempLightSources
+    (cWorld . lWorld . tempLightSources
         .:~ tlsTimeRadColPos
             1
             250
             0.7
-            (p +.+.+ rotate3 (_crDir cr) (heldItemOffset it cr (off +.+.+ V3 8 0 1.5)))
+            pos
+    )
   where
+    pos = (p +.+.+ rotate3 (_crDir cr) (heldItemOffset it cr (off +.+.+ V3 8 0 1.5)))
     p = addZ 0 $ _crPos cr

src/Quaternion.hs

@@ -10,6 +10,7 @@ WARNING: orphan instances concerning Aeson classes and Linear.Quaternion datatyp
 The warnings have been disabled.
 -}
 module Quaternion (
+    qID,
     rotateToZ,
     vToQuat,
     module Linear.Quaternion,
@@ -42,4 +43,7 @@ vToQuat a b
   where
     cprod = crossProd a b
 
+qID :: Q.Quaternion Float
+qID = Q.axisAngle (V3 1 0 0) 0
+
 --deriving instance (Flat a => Flat (Quaternion a))