Make torch use battery power

ghcidOutput

@@ -1,15 +1 @@
-/home/justin/Haskell/loop/src/Dodge/ItEffect.hs:67:17-19: warning: [-Wunused-matches]
+All good (602 modules, at 23:49:54)
-    Defined but not used: ‘itm’
-   |
-67 | createHeldLight itm cr = id
-   |                 ^^^
-/home/justin/Haskell/loop/src/Dodge/ItEffect.hs:67:21-22: warning: [-Wunused-matches]
-    Defined but not used: ‘cr’
-   |
-67 | createHeldLight itm cr = id
-   |                     ^^
-/home/justin/Haskell/loop/src/Dodge/Creature/State.hs:202:14-16: warning: [-Wunused-matches]
-    Defined but not used: ‘itm’
-    |
-202 | testtorch cr itm (p,q) =  --createTorchLightOffset cr itm pos' .
-    |              ^^^

src/Dodge/Creature.hs

@@ -280,6 +280,7 @@ testInventory =
 stackedInventory :: [Item]
 stackedInventory =
     [ torch
+    , torch
     , remoteScreen
     , megaShellMag
     , targetingScope TARGETLASER

src/Dodge/Creature/State.hs

@@ -4,7 +4,6 @@ module Dodge.Creature.State (
 ) where
 
 import Dodge.LightSource
-import Dodge.WorldEvent.Flash
 import qualified Data.Map.Strict as M
 import Data.Maybe
 import Data.Monoid
@@ -174,7 +173,7 @@ updateRootItem cr = fromMaybe id $ do
 
 updateRootItem' :: LabelDoubleTree ItemLink Item -> Creature -> World -> World
 updateRootItem' itmtree cr =
-    ldtPropagateFold
+    ldtPropagateFoldTree
         chainLinkOrientation
         chainLinkOrientation
         (updateItemWithOrientation cr)
@@ -193,21 +192,31 @@ chainLinkOrientation mo par (ILink lt f) child = (p + Q.rotate q p1, q * q1)
     (p, q) = mo
     (p1, q1) = f par lt child
 
-updateItemWithOrientation :: Creature -> (Point3, Q.Quaternion Float) -> Item -> World -> World
+updateItemWithOrientation :: Creature -> (Point3, Q.Quaternion Float) 
-updateItemWithOrientation cr m itm = case _itType itm of
+    -> LabelDoubleTree ItemLink Item
-    HELD TORCH -> testtorch cr itm m
+    -> World -> World
+updateItemWithOrientation cr m itmtree = case _itType itm of
+    HELD TORCH -> shineTorch cr itmtree m
     _ -> id
-
-testtorch :: Creature -> Item -> (Point3, Q.Quaternion Float) -> World -> World
-testtorch cr itm (p,q) =  --createTorchLightOffset cr itm pos' .
-    muzFlareAt yellow pos'' d
-    .( cWorld . lWorld . tempLightSources .:~
-        tlsTimeRadColPos 1 250 0.7 pos''
-    )
   where
-    --pos = (_crPos cr `v2z` 0 + rotate3 cdir p)
+    itm = itmtree ^. ldtValue
+
+
+
+shineTorch :: Creature -> LabelDoubleTree ItemLink Item -> (Point3, Q.Quaternion Float) -> World -> World
+shineTorch cr itmtree (p,q) = fromMaybe id $ do
+    (_,mag) <- find (isammolink . _iatType . fst) (itmtree ^. ldtLeft)
+    i <- mag ^? ldtValue . itUse . amagLoadStatus . iaLoaded
+    guard $ i >= x
+    invid <- mag ^? ldtValue . itLocation . ilInvID
+    return $
+        (cWorld . lWorld . tempLightSources .:~ tlsTimeRadColPos 1 250 0.7 pos'')
+        . (cWorld . lWorld . creatures . ix (_crID cr) . crInv . ix invid . itUse . amagLoadStatus . iaLoaded -~ x)
+  where
+    x = 10
+    isammolink AmmoInLink{} = True
+    isammolink _ = False
     pos = (_crPos cr `v2z` 0 + rotate3 cdir p)
-    --pos'' = pos
     pos'' = pos + rotate3 d (V3 8 0 1.5)
     cdir = _crDir cr
     a = argV (Q.qToV2 q)

src/Dodge/Data/Item/Effect.hs

@@ -22,21 +22,16 @@ data ItInvEffect
     | ChargeIfInInventory
     | SetCharge Int
     | EffectRootNotroot ItInvEffect ItInvEffect
-    | CreateHeldLight
     | CreateShieldWall
     | RemoveShieldWall
     | EffectWhileRoot ItInvEffect
     | EffectWhileAttached ItInvEffect
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
-data ItFloorEffect = NoFloorEffect
-    deriving (Eq, Ord, Show, Read) --Generic, Flat)
-
 data ItDropEffect = NoDropEffect
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
 makeLenses ''ItEffect
 deriveJSON defaultOptions ''ItInvEffect
-deriveJSON defaultOptions ''ItFloorEffect
 deriveJSON defaultOptions ''ItDropEffect
 deriveJSON defaultOptions ''ItEffect

src/Dodge/Default/Item.hs

@@ -1,13 +1,11 @@
 module Dodge.Default.Item (
     module Dodge.Default.Item,
     module Dodge.Default.Item.Use,
-    module Dodge.Default.Item.Effect,
 ) where
 
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
 import Dodge.Data.Item
-import Dodge.Default.Item.Effect
 import Dodge.Default.Item.Use
 import Geometry.Data
 
@@ -48,3 +46,10 @@ defaultBulletWeapon = defaultHeldItem
 defaultConsumable :: Item
 defaultConsumable = defaultHeldItem & itUse .~ UseConsume CDoNothing
 
+defaultItEffect :: ItEffect
+defaultItEffect =
+    ItEffect
+        { _ieInv = NoInvEffect
+        , _ieOnInsert = NoInvEffect
+        , _ieOnDrop = NoInvEffect
+        }

src/Dodge/Default/Item/Effect.hs

@@ -1,11 +0,0 @@
-module Dodge.Default.Item.Effect
-    where
-import Dodge.Data.Item.Effect
-
-defaultItEffect :: ItEffect
-defaultItEffect =
-    ItEffect
-        { _ieInv = NoInvEffect
-        , _ieOnInsert = NoInvEffect
-        , _ieOnDrop = NoInvEffect
-        }

src/Dodge/Default/Item/Use/AimParams.hs

@@ -1,4 +1,7 @@
-module Dodge.Default.Item.Use.AimParams where
+module Dodge.Default.Item.Use.AimParams (
+    defaultAimParams,
+    defaultItZoom,
+) where
 
 import Dodge.Data.Item.Use
 import Linear

src/Dodge/DoubleTree.hs

@@ -38,6 +38,22 @@ ldtPropagateFold lf rf up x (LDT v l 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 -> LabelDoubleTree b a -> d -> d)
+    -> c 
+    -> LabelDoubleTree 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 
     -> LabelDoubleTree b a -> LabelDoubleTree c a

src/Dodge/ItEffect.hs

@@ -1,4 +1,6 @@
-module Dodge.ItEffect where
+module Dodge.ItEffect 
+    ( doInvEffect
+    ) where
 
 import qualified IntMapHelp as IM
 import Control.Lens
@@ -12,15 +14,11 @@ doInvEffect iie = case iie of
     ChargeIfInInventory -> chargeIfInInventory
     SetCharge i -> setItemCharge i
     EffectRootNotroot f g -> rootNotrootEff f g
-    CreateHeldLight -> createHeldLight
     CreateShieldWall -> createShieldWall
     RemoveShieldWall -> removeShieldWall
     EffectWhileRoot f -> rootNotrootEff f NoInvEffect
     EffectWhileAttached f -> effectWhileAttached f
 
-doFloorEffect :: ItFloorEffect -> Int -> World -> World
-doFloorEffect NoFloorEffect = const id
-
 rootNotrootEff :: ItInvEffect -> ItInvEffect -> Item -> Creature -> World -> World
 rootNotrootEff f g it
     | it ^? itLocation . ilIsRoot == Just True = doInvEffect f it
@@ -62,7 +60,3 @@ chargeIfEquipped itm cr
     invid = _ilInvID $ _itLocation itm
     ptrWpCharge = cWorld . lWorld . creatures . ix (_crID cr) . crInv . ix invid . itUse . leftConsumption . wpCharge
     maxcharge = itm ^?! itUse . leftConsumption . wpMaxCharge
-
-createHeldLight :: Item -> Creature -> World -> World
-createHeldLight itm cr = id
---createHeldLight itm cr = createTorchLightOffset cr itm 0

src/Dodge/Item/Ammo.hs

@@ -80,8 +80,8 @@ battery =
                 , _amagType = ElectricalAmmo
                 , _amagLoadStatus =
                     ReloadStatus
-                        { _iaMax = 100
+                        { _iaMax = 10^ (9::Int)
-                        , _iaLoaded = 100
+                        , _iaLoaded = 10^ (9::Int)
                         }
                 }
 

src/Dodge/Item/Grammar.hs

@@ -25,7 +25,6 @@ useBreakL' x y = useBreakListsLinkTest (map (uncurry noa) x) (map (uncurry noa)
   where
     noa a b = (a, ILink b orientAttachment)
 
-
 useBreakListsLinkTest :: [(ItemStructuralFunction, a)] -> [(ItemStructuralFunction, a)] -> LinkTest a
 useBreakListsLinkTest llist rlist = LTest ltest rtest
   where

src/Dodge/Item/Held/Utility.hs

@@ -26,7 +26,6 @@ latchkey _ = defaultHeldItem
 torch :: Item
 torch =
     defaultHeldItem
-        & itEffect . ieInv .~ EffectWhileAttached CreateHeldLight
         & itType .~ HELD TORCH
         & itUse . heldAim . aimMuzzles . ix 0 . mzPos . _x .~ 10
         & itUse . heldAmmoTypes .~ singleAmmo ElectricalAmmo

src/Dodge/Item/Orientation.hs

@@ -1,29 +1,29 @@
-module Dodge.Item.Orientation 
+module Dodge.Item.Orientation (
-    ( orientAttachment
+    orientAttachment,
-    ) where
+) where
 
 import Dodge.Data.ComposedItem
-import Geometry.Data
 import Dodge.Data.Item
+import Geometry.Data
 import qualified Quaternion as Q
 
 orientChild :: Item -> (Point3, Q.Quaternion Float)
 orientChild itm = case _itType itm of
-    HELD TORCH -> (V3 0 20 0,Q.qID)
+    HELD TORCH -> (V3 0 5 0, Q.qID)
-    _ -> (0,Q.qID)
+    _ -> (0, Q.qID)
 
 orientByLink :: Item -> ComposeLinkType -> (Point3, Q.Quaternion Float)
-orientByLink itm lt = case (_itType itm,lt) of
+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 _, AmmoInLink{}) -> (V3 7 (-2) 0, Q.qID)
-    (HELD _,WeaponScopeLink) -> (V3 5 0 5, Q.qID)
+    (HELD _, WeaponScopeLink) -> (V3 5 0 5, Q.qID)
-    _ -> (0,Q.qID)
+    _ -> (0, Q.qID)
 
 orientAttachment :: Item -> ComposeLinkType -> Item -> (Point3, Q.Quaternion Float)
-orientAttachment par lnk ch = case (_itType par,lnk,_itType ch) of
+orientAttachment par lnk ch = case (_itType par, lnk, _itType ch) of
---    (HELD BURSTRIFLE,_,HELD TORCH) -> (V3 20 0 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.qID)
+--    (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
+    (t1, q1) = orientByLink par lnk
-    (t2,q2) = orientChild ch
+    (t2, q2) = orientChild ch