Move targeting functions

src/Dodge/Data/Item/Combine.hs

@@ -106,6 +106,7 @@ data EquipItemType
     | INVISIBILITYEQUIPMENT EquipSite
     | BRAINHAT
     | HAT
+    | TARGETINGHAT TargetType
     | HEADLAMP
     | POWERLEGS
     | SPEEDLEGS

src/Dodge/Item.hs

@@ -38,6 +38,7 @@ itemFromEquipType et = case et of
     INVISIBILITYEQUIPMENT _ -> error "need to define invisibility for more than wrist"
     BRAINHAT -> brainHat
     HAT -> hat
+    TARGETINGHAT tt -> targetingHat tt
     HEADLAMP -> headLamp
     POWERLEGS -> powerLegs
     SPEEDLEGS -> speedLegs

src/Dodge/Item/Draw/SPic.hs

@@ -36,6 +36,7 @@ equipItemSPic et _ = case et of
     INVISIBILITYEQUIPMENT _ -> noPic (colorSH chartreuse $ upperPrismPoly 3 $ rectWH 2 2)
     BRAINHAT -> noPic (colorSH yellow $ upperPrismPoly 3 $ rectWH 4 4)
     HAT -> noPic (colorSH yellow $ upperPrismPoly 3 $ rectWH 4 4)
+    TARGETINGHAT _ -> noPic (colorSH yellow $ upperPrismPoly 3 $ rectWH 4 4)
     HEADLAMP -> noPic headLampShape
     POWERLEGS -> legsSPic yellow
     SPEEDLEGS -> legsSPic green

src/Dodge/Item/Equipment.hs

@@ -4,6 +4,7 @@ module Dodge.Item.Equipment (
     powerLegs,
     wristInvisibility,
     wristArmour,
+    targetingHat,
     hat,
     brainHat,
     frontArmour,
@@ -16,6 +17,7 @@ module Dodge.Item.Equipment (
     flameShield,
 ) where
 
+import Dodge.Item.Targeting
 import Geometry.Data
 import Dodge.Data.CamouflageStatus
 import Dodge.Data.Item
@@ -86,6 +88,13 @@ hat =
         & itUse . equipEffect . eeSite .~ GoesOnHead
         & itType . iyBase .~ EQUIP HAT
 
+targetingHat :: TargetType -> Item
+targetingHat tt = 
+    defaultEquipment
+        & itUse . equipEffect . eeSite .~ GoesOnHead
+        & itType . iyBase .~ EQUIP (TARGETINGHAT tt)
+        & itUse . equipTargeting .~ (defaultTargeting & tgType .~ tt)
+
 headLamp :: Item
 headLamp =
     defaultEquipment

src/Dodge/Item/Info.hs

@@ -103,6 +103,7 @@ equipInfo eit = case eit of
     INVISIBILITYEQUIPMENT _ -> "A DEVICE THAT BENDS LIGHT AROUND ITS USER."
     BRAINHAT -> "AN IQ ENHANCER. USELESS."
     HAT -> "A HAT"
+    TARGETINGHAT tt -> "Headwear that "++ targetingInfo tt
     HEADLAMP -> "A TORCH STRAPPED TO A HAT."
     POWERLEGS -> "STRENGTH ENHANCING LEGS."
     SPEEDLEGS -> "SPEED ENHANCING LEGS."
@@ -114,6 +115,14 @@ equipInfo eit = case eit of
 
     AUTODETECTOR d -> "A DEVICE THAT DETECTS "++detectorInfo d ++" IN AN EXPANDING RADIUS. PULSES AUTOMATICALLY. "
 
+targetingInfo :: TargetType -> String
+targetingInfo tt = case tt of
+    TargetLaser -> "creates a laser, the end of which becomes the target."
+    TargetRBPress -> "creates a fixed target."
+    TargetRBLine -> "creates a line target."
+    TargetRBCreature -> "targets a creature."
+    TargetCursor -> "creates a moving target."
+
 consumableInfo :: ConsumableItemType -> String
 consumableInfo cit = case cit of
     MEDKIT _ -> "A SELF-USE HEALING KIT."

src/Dodge/Item/Weapon/ExtraEffect.hs

@@ -8,30 +8,15 @@ module Dodge.Item.Weapon.ExtraEffect (
     autoSonarEffect,
     autoEffect,
     autoRadarEffect,
-    targetLaserUpdate,
-    targetUpdateWith,
-    targetRBPressUpdate,
-    targetRBCreatureUp,
-    targetCursorUpdate,
     --    , rbSetTarget
 ) where
 
 --import Dodge.Item.Attachment.Data
 
-import qualified Data.Map.Strict as M
-import Data.Maybe
-import Dodge.Base
-import Dodge.Creature.Test
 import Dodge.Data.World
-import Dodge.Item.Weapon.LaserPath
 import Dodge.RadarSweep
 import Dodge.SoundLogic
-import Dodge.Zoning.Creature
-import FoldableHelp
-import Geometry.Vector
 import LensHelp
-import Picture
-import qualified SDL
 import Sound.Data
 
 autoEffect :: (Item -> Creature -> World -> World) -> Int -> SoundID -> Item -> Creature -> World -> World
@@ -62,97 +47,3 @@ autoRadarEffect = autoEffect (const (aRadarPulse ObWall)) 100 click1S
 autoSonarEffect :: Item -> Creature -> World -> World
 autoSonarEffect = autoEffect (const (aRadarPulse ObCreature)) 50 click1S
 
-
-
-targetRBCreatureUp :: Item -> Creature -> World -> Targeting -> (World, Targeting)
-targetRBCreatureUp it cr w t
-    | not $ _itIsHeld it =
-        ( w
-        , t
-            & tgID .~ Nothing
-            & tgPos .~ Nothing
-            & tgActive .~ False
-        )
-    | SDL.ButtonRight `M.member` _mouseButtons (_input w) && isJust (t ^? tgID . _Just)
-        && canSeeTarget =
-        (w, t & updatePos & tgActive .~ True)
-    | otherwise = (w, t & tgID .~ fmap _crID newtarg & updatePos & tgActive .~ False)
-  where
-    newtarg =
-        safeMinimumOn (dist mwp . _crPos)
-            . filter (canseepos . _crPos)
-            $ crsNearCirc mwp 40 w
-    canseepos p = hasLOS (_crPos cr) p w
-    mwp = mouseWorldPos (w ^. input) (w ^. cWorld . camPos)
-    updatePos t' = t' & tgPos .~ posFromMaybeID (_tgID t')
-    posFromMaybeID Nothing = Nothing
-    posFromMaybeID (Just i) = w ^? cWorld . lWorld . creatures . ix i . crPos
-    canSeeTarget = fromMaybe False $ do
-        cid <- t ^? tgID . _Just
-        cpos <- w ^? cWorld . lWorld . creatures . ix cid . crPos
-        Just $ hasLOS cpos (_crPos cr) w
-
-targetUpdateWith ::
-    (World -> Targeting -> Targeting) ->
-    Item ->
-    Creature ->
-    World ->
-    Targeting ->
-    (World, Targeting)
-targetUpdateWith f it _ w t
-    | _itIsHeld it = (w, f w t)
-    | otherwise = (w, t)
-
-targetCursorUpdate :: World -> Targeting -> Targeting
-targetCursorUpdate w t
-    | SDL.ButtonRight `M.member` _mouseButtons (_input w) =
-        t
-            & tgPos . _Just .~ mouseWorldPos (w ^. input) (w ^. cWorld . camPos)
-            & tgActive .~ True
-    | otherwise =
-        t & tgPos %~ const Nothing
-            & tgActive .~ False
-
-targetRBPressUpdate :: World -> Targeting -> Targeting
-targetRBPressUpdate w t
-    | SDL.ButtonRight `M.member` _mouseButtons (_input w) =
-        t
-            & tgPos %~ maybe (Just $ mouseWorldPos (w ^. input) (w ^. cWorld . camPos)) Just
-            & tgActive .~ True
-    | otherwise =
-        t & tgPos %~ const Nothing
-            & tgActive .~ False
-
-targetLaserUpdate :: Item -> Creature -> World -> Targeting -> (World, Targeting)
-targetLaserUpdate _ cr w t
-    | crIsAiming cr =
-        ( addLaserPic w
-        , t
-            & tgPos .~ fmap fst mp
-            & tgActive .~ True
-        )
-    | otherwise =
-        ( w
-        , t & tgPos %~ const Nothing
-            & tgActive .~ False
-        )
-  where
-    (mp, _) = reflectLaserAlong 0.2 sp ep w
-    sp = _crPos cr +.+ 15 *.* unitVectorAtAngle (_crDir cr)
-    ep = sp +.+ 5000 *.* normalizeV (mouseWorldPos (w ^. input) (w ^. cWorld . camPos) -.- sp)
-    addLaserPic =
-        cWorld . lWorld . lasers
-            .:~ LaserStart
-                { _lpPhaseV = 1
-                , _lpDir = _crDir cr
-                , _lpPos = sp
-                , _lpColor = col
-                , _lpType = TargetingLaser
-                }
-    --wpammo = _itConsumption it
-    --    reloadFrac
-    --        | _laLoaded wpammo == 0 = 1
-    --        | otherwise = case _laTransfer wpammo of
-    --            Transfer _ rs -> fromIntegral rs / fromIntegral (_laReloadTime wpammo)
-    --            NoTransfer -> 1
-    col = blue -- mixColors reloadFrac (1-reloadFrac) blue red

src/Dodge/Targeting.hs

@@ -1,7 +1,18 @@
 module Dodge.Targeting where
 
+import Color
+import Dodge.Item.Weapon.LaserPath
+import Dodge.Creature.Test
+import Dodge.Base.Coordinate
+import Dodge.Base.Collide
+import Dodge.Zoning.Creature
+import Geometry.Vector
+import FoldableHelp
 import Dodge.Data.World
-import Dodge.Item.Weapon.ExtraEffect
+import qualified SDL
+import qualified Data.Map.Strict as M
+import LensHelp
+import Data.Maybe
 
 updateTargeting :: TargetType -> Item -> Creature -> World -> Targeting -> (World, Targeting)
 updateTargeting tu = case tu of
@@ -10,3 +21,96 @@ updateTargeting tu = case tu of
     TargetRBLine -> targetUpdateWith targetRBPressUpdate
     TargetRBCreature -> targetRBCreatureUp
     TargetCursor -> targetUpdateWith targetCursorUpdate
+
+targetRBCreatureUp :: Item -> Creature -> World -> Targeting -> (World, Targeting)
+targetRBCreatureUp it cr w t
+    | not $ _itIsHeld it =
+        ( w
+        , t
+            & tgID .~ Nothing
+            & tgPos .~ Nothing
+            & tgActive .~ False
+        )
+    | SDL.ButtonRight `M.member` _mouseButtons (_input w) && isJust (t ^? tgID . _Just)
+        && canSeeTarget =
+        (w, t & updatePos & tgActive .~ True)
+    | otherwise = (w, t & tgID .~ fmap _crID newtarg & updatePos & tgActive .~ False)
+  where
+    newtarg =
+        safeMinimumOn (dist mwp . _crPos)
+            . filter (canseepos . _crPos)
+            $ crsNearCirc mwp 40 w
+    canseepos p = hasLOS (_crPos cr) p w
+    mwp = mouseWorldPos (w ^. input) (w ^. cWorld . camPos)
+    updatePos t' = t' & tgPos .~ posFromMaybeID (_tgID t')
+    posFromMaybeID Nothing = Nothing
+    posFromMaybeID (Just i) = w ^? cWorld . lWorld . creatures . ix i . crPos
+    canSeeTarget = fromMaybe False $ do
+        cid <- t ^? tgID . _Just
+        cpos <- w ^? cWorld . lWorld . creatures . ix cid . crPos
+        Just $ hasLOS cpos (_crPos cr) w
+
+targetUpdateWith ::
+    (World -> Targeting -> Targeting) ->
+    Item ->
+    Creature ->
+    World ->
+    Targeting ->
+    (World, Targeting)
+targetUpdateWith f it _ w t
+    | _itIsHeld it = (w, f w t)
+    | otherwise = (w, t)
+
+targetCursorUpdate :: World -> Targeting -> Targeting
+targetCursorUpdate w t
+    | SDL.ButtonRight `M.member` _mouseButtons (_input w) =
+        t
+            & tgPos . _Just .~ mouseWorldPos (w ^. input) (w ^. cWorld . camPos)
+            & tgActive .~ True
+    | otherwise =
+        t & tgPos %~ const Nothing
+            & tgActive .~ False
+
+targetRBPressUpdate :: World -> Targeting -> Targeting
+targetRBPressUpdate w t
+    | SDL.ButtonRight `M.member` _mouseButtons (_input w) =
+        t
+            & tgPos %~ maybe (Just $ mouseWorldPos (w ^. input) (w ^. cWorld . camPos)) Just
+            & tgActive .~ True
+    | otherwise =
+        t & tgPos %~ const Nothing
+            & tgActive .~ False
+
+targetLaserUpdate :: Item -> Creature -> World -> Targeting -> (World, Targeting)
+targetLaserUpdate _ cr w t
+    | crIsAiming cr =
+        ( addLaserPic w
+        , t
+            & tgPos .~ fmap fst mp
+            & tgActive .~ True
+        )
+    | otherwise =
+        ( w
+        , t & tgPos %~ const Nothing
+            & tgActive .~ False
+        )
+  where
+    (mp, _) = reflectLaserAlong 0.2 sp ep w
+    sp = _crPos cr +.+ 15 *.* unitVectorAtAngle (_crDir cr)
+    ep = sp +.+ 5000 *.* normalizeV (mouseWorldPos (w ^. input) (w ^. cWorld . camPos) -.- sp)
+    addLaserPic =
+        cWorld . lWorld . lasers
+            .:~ LaserStart
+                { _lpPhaseV = 1
+                , _lpDir = _crDir cr
+                , _lpPos = sp
+                , _lpColor = col
+                , _lpType = TargetingLaser
+                }
+    --wpammo = _itConsumption it
+    --    reloadFrac
+    --        | _laLoaded wpammo == 0 = 1
+    --        | otherwise = case _laTransfer wpammo of
+    --            Transfer _ rs -> fromIntegral rs / fromIntegral (_laReloadTime wpammo)
+    --            NoTransfer -> 1
+    col = blue -- mixColors reloadFrac (1-reloadFrac) blue red