Refactor targeting

src/Dodge/Creature/State.hs

@@ -3,6 +3,7 @@ module Dodge.Creature.State
     , doDamage
     ) where
 import Dodge.Data
+import Dodge.Targeting
 import Dodge.ItEffect
 import Dodge.Euse
 import Dodge.EnergyBall
@@ -229,7 +230,7 @@ doItemTargeting :: Int -> Creature -> World -> World
 doItemTargeting invid cr w = case cr ^? crInv . ix invid . itTargeting of
     Nothing -> w
     Just NoTargeting -> w
-    Just t  -> let (w',t') = _tgUpdate t (_crInv cr IM.! invid) cr w t
+    Just t  -> let (w',t') = updateTargeting (_tgUpdate t) (_crInv cr IM.! invid) cr w t
         in w' & creatures . ix (_crID cr) . crInv . ix invid . itTargeting .~ t'
 
 weaponReloadSounds :: Creature -> World -> World

src/Dodge/Data.hs

@@ -438,8 +438,8 @@ data Targeting
     = NoTargeting
     | Targeting
         { _tgPos    :: Maybe Point2
-        , _tgUpdate :: Item -> Creature -> World -> Targeting -> (World, Targeting)
+        , _tgUpdate :: TargetUpdate --Item -> Creature -> World -> Targeting -> (World, Targeting)
-        , _tgDraw   :: Item -> Creature -> Configuration -> World -> Picture
+        , _tgDraw   :: TargetDraw --Item -> Creature -> Configuration -> World -> Picture
         , _tgID     :: Maybe Int
         , _tgActive :: Bool
         }

src/Dodge/Data/Targeting.hs

@@ -2,6 +2,13 @@
 {-# LANGUAGE StrictData #-}
 module Dodge.Data.Targeting where
 
-data TargetUpdate = NoTargeting
+data TargetUpdate = NoTargetUpdate
+    | TargetLaserUpdate
+    | TargetRBPressUpdate
+    | TargetRBCreatureUpdate
+    | TargetCursorUpdate
 
-data TargetDraw = SquareTarget
+data TargetDraw = NoTargetDraw
+    | TargetDistanceDraw
+    | SimpleDrawTarget
+    | TargetRBCreatureDraw

src/Dodge/Item/Weapon/ExtraEffect.hs

@@ -11,7 +11,11 @@ module Dodge.Item.Weapon.ExtraEffect
     , targetRBCreature
     , targetCursor
     , targetLaser
-    , targetDistanceDraw
+    , targetLaserUpdate
+    , targetUpdateWith
+    , targetRBPressUpdate
+    , targetRBCreatureUp
+    , targetCursorUpdate
 --    , rbSetTarget
     ) where
 import Dodge.Data
@@ -25,15 +29,11 @@ import Dodge.Creature.Test
 import Dodge.WorldEvent.HelperParticle
 import Picture
 import Geometry.Vector
-import Geometry.Data
 import LensHelp
 import Sound.Data
-import ShortShow
 
 import qualified Data.Map.Strict as M
---import Data.Bifunctor
 import Data.Maybe
---import qualified Control.Foldl as L
 import qualified Streaming.Prelude as S
 import qualified SDL
 autoEffect :: (Item -> Creature -> World -> World) -> Int -> SoundID -> Item -> Creature -> World -> World
@@ -55,61 +55,27 @@ autoSonarEffect = autoEffect (const (aRadarPulse ObCreature)) 50 click1S
 defaultTargeting :: Targeting
 defaultTargeting = Targeting
     { _tgPos = Nothing
-    , _tgUpdate = \_ _ w t -> (w,t)
+    , _tgUpdate = NoTargetUpdate
-    , _tgDraw = \_ _ _ _ -> mempty
+    , _tgDraw = NoTargetDraw
     , _tgID = Nothing
     , _tgActive = False
     }
 targetLaser :: Targeting
 targetLaser = defaultTargeting
-    & tgUpdate  .~ targetLaserUpdate
+    & tgUpdate  .~ TargetLaserUpdate
 targetRBPress :: Targeting
 targetRBPress = defaultTargeting
-    & tgUpdate  .~ targetUpdateWith targetRBPressUpdate
+    & tgUpdate  .~ TargetRBPressUpdate
-    & tgDraw    .~ targetSimpleDraw
+    & tgDraw    .~ SimpleDrawTarget
 targetRBCreature :: Targeting
 targetRBCreature = defaultTargeting
-    & tgUpdate  .~ targetRBCreatureUp 
+    & tgUpdate  .~ TargetRBCreatureUpdate
-    & tgDraw    .~ targetRBCreatureDraw
+    & tgDraw    .~ TargetRBCreatureDraw
 
 targetCursor :: Targeting
 targetCursor = defaultTargeting
-    & tgUpdate  .~ targetUpdateWith targetCursorUpdate
+    & tgUpdate  .~ TargetCursorUpdate
-    & tgDraw    .~ targetSimpleDraw
+    & tgDraw    .~ SimpleDrawTarget
-
-targetDraw :: (Item -> Picture) -> Item -> Creature -> Configuration -> World -> Picture
-targetDraw f it _ cfig w = fromMaybe mempty $ do
-    p <- it ^? itTargeting . tgPos . _Just
-    return $ winScale cfig 
-        $ setLayer FixedCoordLayer 
-        $ color white 
-        $ uncurryV translate (worldPosToScreen w p)
-        $ f it
-targetSimpleDraw :: Item -> Creature -> Configuration -> World -> Picture
-targetSimpleDraw = targetDraw $ const activeTargetCursorPic
-
-targetDistanceDraw :: Item -> Creature -> Configuration -> World -> Picture
-targetDistanceDraw itm _ cfig w = fromMaybe mempty $ do
-    p <- itm ^? itTargeting . tgPos . _Just
-    let p1 = worldPosToScreen w p
-        mwp = mouseWorldPos w
-        p2 = worldPosToScreen w mwp
-        thecol = if dist p mwp > 100 then red else white
-    return $ winScale cfig 
-        $ setLayer FixedCoordLayer 
-        $ color thecol 
-        $ line [p1, p2]
-            <> transMidLine p1 p2 (scale 0.1 0.1 . text . shortShow $ dist p mwp)
-
-transMidLine :: Point2 -> Point2 -> Picture -> Picture
-transMidLine p1 p2 = translate 20 (f p1 p2) . uncurryV translate (0.5 *.* (p1 +.+ p2))
-  where
-    f (V2 x y) (V2 x' y') 
-        | y > y' && x > x' = max (-10) (x'-x)
-        | y > y' && x < x' = min 10 (x'-x)
-        | x > x'    = min 10 (x-x')
-        | otherwise = max (-10) (x-x')
-
 
 targetRBCreatureUp :: Item -> Creature -> World -> Targeting -> (World, Targeting)
 targetRBCreatureUp it cr w t
@@ -140,28 +106,6 @@ targetRBCreatureUp it cr w t
         cpos <- w ^? creatures . ix cid . crPos
         Just $ hasLOS cpos (_crPos cr) w
 
-targetRBCreatureDraw :: Item -> Creature -> Configuration -> World -> Picture
-targetRBCreatureDraw = targetDraw thepic
-  where
-    thepic it | _tgActive $ _itTargeting it = activeTargetCursorPic
-        | otherwise = targetCursorPic
-
-activeTargetCursorPic :: Picture
-activeTargetCursorPic = pictures
-    [rotate a $ line [V2 15 0,V2 10 0] <> targCorner | a <- [0,0.5*pi,pi,1.5*pi]]
-
-targetCursorPic :: Picture
-targetCursorPic = pictures
-    [rotate a targCorner | a <- [0,0.5*pi,pi,1.5*pi]]
-targCorner :: Picture
-targCorner = pictures
-    [line [V2   x  x, V2 x (x-y)]
-    ,line [V2   x  x, V2 (x-y) x]
-    ]
-  where
-    x = 10
-    y = 5
-
 targetUpdateWith :: (World -> Targeting -> Targeting)
     -> Item -> Creature -> World -> Targeting -> (World,Targeting)
 targetUpdateWith f it _ w t 

src/Dodge/Item/Weapon/Utility.hs

@@ -71,7 +71,7 @@ unsafeBlinkGun = blinkGun
 forceFieldGun :: Item
 forceFieldGun = defaultWeapon 
     { _itConsumption = defaultLoadable & laAmmoType .~ ForceFieldAmmo forceField
-    , _itTargeting = targetRBPress & tgDraw .~ targetDistanceDraw
+    , _itTargeting = targetRBPress & tgDraw .~ TargetDistanceDraw
     , _itParams = ParamMID Nothing
     }
     & itUse . rUse .~ HeldForceField --useForceFieldGun

src/Dodge/Render/ShapePicture.hs

@@ -1,6 +1,7 @@
 module Dodge.Render.ShapePicture
     ( worldSPic
     ) where
+import Dodge.Targeting.Draw
 import Dodge.RadarSweep.Draw
 import Dodge.Projectile.Draw
 import Dodge.Item.Draw.SPic
@@ -72,7 +73,7 @@ anyTargeting :: Configuration -> World -> SPic
 anyTargeting cfig w = (mempty,pictures $ IM.elems $ IM.mapMaybe f $ _crInv cr)
   where
     cr = you w
-    f it = fmap (\g -> g it cr cfig w) (it ^? itTargeting . tgDraw)
+    f it = fmap (\g -> drawTargeting g it cr cfig w) (it ^? itTargeting . tgDraw)
 
 drawCreature :: Creature -> SPic
 drawCreature cr = case _crType cr of

src/Dodge/Targeting.hs

@@ -0,0 +1,11 @@
+module Dodge.Targeting where
+import Dodge.Data
+import Dodge.Item.Weapon.ExtraEffect
+
+updateTargeting :: TargetUpdate -> Item -> Creature -> World -> Targeting -> (World, Targeting)
+updateTargeting tu = case tu of
+    NoTargetUpdate -> \_ _ w t -> (w,t)
+    TargetLaserUpdate -> targetLaserUpdate
+    TargetRBPressUpdate -> targetUpdateWith targetRBPressUpdate
+    TargetRBCreatureUpdate -> targetRBCreatureUp 
+    TargetCursorUpdate -> targetUpdateWith targetCursorUpdate

src/Dodge/Targeting/Draw.hs

@@ -0,0 +1,75 @@
+module Dodge.Targeting.Draw where
+import Dodge.Data
+import Dodge.Base
+import Picture
+import Geometry.Vector
+import Geometry.Data
+import LensHelp
+import ShortShow
+
+import Data.Maybe
+
+drawTargeting :: TargetDraw -> Item -> Creature -> Configuration -> World -> Picture
+drawTargeting td = case td of
+    NoTargetDraw -> \_ _ _ _ -> mempty
+    SimpleDrawTarget -> targetSimpleDraw
+    TargetRBCreatureDraw -> targetRBCreatureDraw
+    TargetDistanceDraw -> targetDistanceDraw
+
+targetSimpleDraw :: Item -> Creature -> Configuration -> World -> Picture
+targetSimpleDraw = targetDraw $ const activeTargetCursorPic
+
+targetDistanceDraw :: Item -> Creature -> Configuration -> World -> Picture
+targetDistanceDraw itm _ cfig w = fromMaybe mempty $ do
+    p <- itm ^? itTargeting . tgPos . _Just
+    let p1 = worldPosToScreen w p
+        mwp = mouseWorldPos w
+        p2 = worldPosToScreen w mwp
+        thecol = if dist p mwp > 100 then red else white
+    return $ winScale cfig 
+        $ setLayer FixedCoordLayer 
+        $ color thecol 
+        $ line [p1, p2]
+            <> transMidLine p1 p2 (scale 0.1 0.1 . text . shortShow $ dist p mwp)
+
+targetDraw :: (Item -> Picture) -> Item -> Creature -> Configuration -> World -> Picture
+targetDraw f it _ cfig w = fromMaybe mempty $ do
+    p <- it ^? itTargeting . tgPos . _Just
+    return $ winScale cfig 
+        $ setLayer FixedCoordLayer 
+        $ color white 
+        $ uncurryV translate (worldPosToScreen w p)
+        $ f it
+
+activeTargetCursorPic :: Picture
+activeTargetCursorPic = pictures
+    [rotate a $ line [V2 15 0,V2 10 0] <> targCorner | a <- [0,0.5*pi,pi,1.5*pi]]
+
+transMidLine :: Point2 -> Point2 -> Picture -> Picture
+transMidLine p1 p2 = translate 20 (f p1 p2) . uncurryV translate (0.5 *.* (p1 +.+ p2))
+  where
+    f (V2 x y) (V2 x' y') 
+        | y > y' && x > x' = max (-10) (x'-x)
+        | y > y' && x < x' = min 10 (x'-x)
+        | x > x'    = min 10 (x-x')
+        | otherwise = max (-10) (x-x')
+
+targetRBCreatureDraw :: Item -> Creature -> Configuration -> World -> Picture
+targetRBCreatureDraw = targetDraw thepic
+  where
+    thepic it | _tgActive $ _itTargeting it = activeTargetCursorPic
+        | otherwise = targetCursorPic
+
+targCorner :: Picture
+targCorner = pictures
+    [line [V2   x  x, V2 x (x-y)]
+    ,line [V2   x  x, V2 (x-y) x]
+    ]
+  where
+    x = 10
+    y = 5
+
+targetCursorPic :: Picture
+targetCursorPic = pictures
+    [rotate a targCorner | a <- [0,0.5*pi,pi,1.5*pi]]
+