Refactor tractor beam

src/Dodge/Creature.hs

@@ -162,6 +162,7 @@ startInventory :: IM.IntMap Item
 startInventory = IM.fromList (zip [0..20] 
     (
     [spreadGun
+    ,tractorGun
     ,longGun
     ,autoGun
     ,ltAutoGun

src/Dodge/Data.hs

@@ -480,6 +480,15 @@ data Prop
         , _pjID :: Int
         , _pjUpdate :: Prop -> World -> World
         }
+    | ProjectileTimed
+        { _pjPos :: Point2
+        , _pjStartPos :: Point2
+        , _pjVel :: Point2
+        , _prDraw :: Prop -> SPic
+        , _pjID :: Int
+        , _pjUpdate :: Prop -> World -> World
+        , _pjTime :: Int
+        }
     | Shell 
         { _pjPos :: Point2
         , _pjStartPos :: Point2

src/Dodge/Item/Weapon.hs

@@ -251,18 +251,20 @@ tractorGun = defaultAutoGun
     , _wpReloadState = 0
     , _itUseRate = 0
     , _itUseTime = 0
-    , _itUse = \_ -> aTractorBeam 0
+    , _itUse = aTractorBeam
     , _itUseModifiers =
         [ ammoUseCheckI
         ]
     , _wpSpread = 0.00001
     , _wpRange = 20
-    , _itFloorPict = (,) emptySH $ onLayer FlItLayer $ color blue $ pictures [polygon $ rectNESW 1.5 6 (-1.5) 0 ]
+    , _itFloorPict = tractorGunSPic
     , _itAimingSpeed = 0.4
     , _itAimingRange = 0.5
-    , _itEquipPict = pictureWeaponOnAim $ (,) emptySH $ color blue $ pictures [polygon $ rectNESW 1.5 6 (-1.5) 0 ]
+    , _itEquipPict = pictureWeaponOnAim tractorGunSPic
     }
-
+-- TODO own picture for tractor gun
+tractorGunSPic :: SPic
+tractorGunSPic = lasGunPic
 
 removeItAttachment :: Int -> Int -> World -> World
 removeItAttachment i _ w = w & creatures . ix i . crInv . ix itRef . itAttachment .~ NoItAttachment

src/Dodge/Item/Weapon/Grenade.hs

@@ -9,7 +9,6 @@ import Dodge.SoundLogic
 import Dodge.SoundLogic.LoadSound
 import Dodge.Item.Attachment.Data
 import Dodge.Item.Draw
---import Dodge.Default
 import Picture
 import Geometry
 import ShapePicture
@@ -100,5 +99,3 @@ throwArmReset x = ItInvEffect {_itInvEffect = f ,_itEffectCounter = x }
             & itHammer .~ HammerUp 
             & itEquipPict .~ pictureWeaponOnAim (grenadePic 50)
         | otherwise = it & itEffect . itEffectCounter -~ 1
-                                           
---(grenadeAccL, grenadeAccA) = (0.1, 0.1)

src/Dodge/Item/Weapon/UseEffect.hs

@@ -6,13 +6,13 @@ module Dodge.Item.Weapon.UseEffect
 import Dodge.Data
 import Dodge.Base
 import Dodge.Zone
-import Dodge.Base.Collide
 import Dodge.Picture.Layer
 --import Dodge.Item.Weapon.Decoration
 --import Dodge.Item.Weapon.TriggerType
 --import Dodge.WorldEvent.Flash
 --import Dodge.WorldEvent.ThingsHit
 import Picture
+import ShapePicture
 import Geometry
 
 import Data.Maybe
@@ -105,87 +105,84 @@ mvRadar x p w pt =
                 | otherwise = fromIntegral x / 10
     --colHelper y = color (withAlpha (y * globalAlpha) red)
 
-aTractorBeam 
+aTractorBeam :: Item -> Creature -> World -> World
-    :: Int      -- ^ Color id
+aTractorBeam _ cr w = over props (IM.insert i (tractorBeamAt i spos outpos dir)) w
-    -> Creature      -- ^ Creature id
-    -> World 
-    -> World
-aTractorBeam col cr w 
-    = set (creatures . ix cid . crInv . ix itRef . itUse)
-        (\_ -> aTractorBeam ((col + 1) `mod` 10))
-    $ over props (IM.insert i (tractorBeamAt col i pos dir)) w
   where 
     i = newProjectileKey w
-    cid = _crID cr
+    cpos = _crPos cr
-    pos = _crPos cr +.+ ((_crRad cr + 10) *.* unitVectorAtAngle dir)
+    spos = cpos +.+ (_crRad cr + 10) *.* unitVectorAtAngle dir
+    xpos = cpos +.+ 400 *.* unitVectorAtAngle dir
     dir = _crDir cr
-    itRef = _crInvSel cr
+    outpos = collidePointWalls cpos xpos
-tractorBeamAt :: Int -> Int -> Point2 -> Float -> Prop
+        $ wallsAlongLine cpos xpos w
-tractorBeamAt colID i pos dir = Projectile
+
+tractorBeamAt :: Int -> Point2 -> Point2 -> Float -> Prop
+tractorBeamAt i pos outpos dir = ProjectileTimed
     { _pjPos = pos
-    , _pjStartPos = p'
+    , _pjStartPos = outpos
     , _pjVel = d
-    , _prDraw = const (mempty,blank)
+    , _prDraw = tractorSPic
     , _pjID = i
-    , _pjUpdate = \_ -> updateTractor colID 10 i
+    , _pjUpdate = updateTractor
+    , _pjTime = 10
     }
   where 
     d  = unitVectorAtAngle dir
-    p' = pos +.+ 400 *.* d
 
 {- |
 The interaction of this with objects, walls etc needs more thought.  -}
-updateTractor :: Int -> Int -> Int -> World -> World
+updateTractor :: Prop -> World -> World
-updateTractor colID time i w
+updateTractor pj w
-    | time > 0 = set (props . ix i . pjUpdate) (\_ -> updateTractor colID (time-1) i) 
+    | _pjTime pj <= 0 = w & props %~ IM.delete i
-                    $ set (props . ix i . prDraw) (const (mempty,mempty))
+    | otherwise = w
-                    $ over creatures (IM.map tractCr) 
+        & props . ix i . pjTime -~ 1
-                    $ over floorItems (IM.map tractFlIt) 
+        & creatures     %~ IM.map (tractCr   pullVel pos outpos)
-                        w
+        & floorItems    %~ IM.map (tractFlIt pullVel pos outpos)
-    | otherwise = over props (IM.delete i) w
   where 
-    tractCr cr 
+    i = _pjID pj
-        | circOnSeg p1 p2 cP 10
+    pullVel = _pjVel pj
-                    = over crPos (\p -> 
+    pos = _pjPos pj
-                                   p -.- m *.* ((0.3/ x) *.* q +.+ (f y *.* p4))
+    outpos = _pjStartPos pj
-                                 ) cr
+
-        | otherwise = cr
+tractFlIt :: Point2 -> Point2 -> Point2 -> FloorItem -> FloorItem
-       where 
+tractFlIt q p1 outpos it 
-        x = abs y + 1
+    | circOnSeg p1 outpos (_flItPos it) 10 = it & flItPos %~ tractorPullPos q p1
-        y = errorClosestPointOnLineParam 1 p1 p3 cP
+    | otherwise = it
-        cP = _crPos cr
+
-        m | dist cP p1 < 350 = 1
+tractCr :: Point2 -> Point2 -> Point2 -> Creature -> Creature
-          | otherwise        = (400 - dist cP p1) / 50
+tractCr q p1 outpos cr
-    tractFlIt it | circOnSeg p1 p2 iP 10
+    | circOnSeg p1 outpos (_crPos cr) 10 = cr & crPos %~ tractorPullPos q p1
-                           = over flItPos  (\p -> p -.- m *.* 
+    | otherwise = cr
-                                                      ( (0.3/ x) *.* q +.+ (f y *.* p4))
+
-                                           ) it
+tractorPullPos :: Point2 -> Point2 -> Point2 -> Point2
-                 | otherwise = it
+tractorPullPos q p1 p = p -.- m *.* (0.3/ x' *.* q +.+ g y *.* p4)
-          where x = abs y + 1
+  where
-                y = errorClosestPointOnLineParam 2 p1 p3 iP
+    x' = abs y + 1
-                iP = _flItPos it
+    y = errorClosestPointOnLineParam 1 p1 p3 p
-                m | dist iP p1 < 350 = 1
+    m | dist p p1 < 350 = 1
-                  | otherwise        = (410 - dist iP p1) / 60
+      | otherwise        = (400 - dist p p1) / 50
-    pj = _props w IM.! i
+    g x | x > 5 = (10 - x) / 250
-    q = _pjVel pj
+        | x > 1 = 0.02
-    p1 = _pjPos pj
+        | x > -1 = x * 0.02
-    p' = _pjStartPos pj
+        | x > -5 = -0.02
-    p2 = maybe p' fst $ reflectPointWalls p1 p' $ wallsNearPoint p' w
+        | otherwise = (x - 10) / 250
-    p4 = vNormal p5
+    --p4 = vNormal p5
-    p5 = errorNormalizeV 12 $ p2 -.- p1
+    p4 = vNormal $ safeNormalizeV q
     p3 = p1 +.+ p4
-    g x | x > 5 = (10 - x) / 5
+
-        | x > 1 = 1
+tractorSPic :: Prop -> SPic
-        | x > -1 = x
+tractorSPic pj = (,) mempty $ setLayer 1 $ setDepth 20 $ color (withAlpha 0.5 col) $ polygon 
-        | x > -5 = -1
+    [ spos  -- not sure if this is anticlockwise...
-        | otherwise = (x - 10) / 5
+    , spos +.+ size *.* (d +.+ n)
-    f x = g x / 50
+    , xpos +.+ size *.* n
+    , xpos -.- size *.* n
+    , spos +.+ size *.* (d -.- n)
+    ]
+  where
+    size = fromIntegral (_pjTime pj)
+    spos = _pjPos pj
+    xpos = _pjStartPos pj
+    d = safeNormalizeV $ spos -.- xpos
+    n = vNormal d
     col = mixColors 0.5 0.5 white blue
-    px z = (fromIntegral time + 5) *.* z
+    
-    pz z = fromIntegral time * 10 *.* z
-    pic = setLayer 1 $ onLayer PtLayer $ color (withAlpha 0.05 col) 
-              $ polygon [ p1 +.+ px p4 
-                        , p1 -.- 10 *.* p5
-                        , p1 -.- px p4
-                        , (p' -.- pz p5) -.- px p4
-                        , (p' -.- pz p5) +.+ px p4]

src/Dodge/Room/Foreground.hs

@@ -1,8 +1,8 @@
 --{-# LANGUAGE TupleSections #-}
 module Dodge.Room.Foreground
     where
-import Dodge.Picture
+--import Dodge.Picture
-import Dodge.Base
+--import Dodge.Base
 import Picture
 import Geometry
 --import Geometry.Data
@@ -53,59 +53,63 @@ highPipe h x y = translateSHz h $ colorSH orange $ upperPrismPoly 5
   where
     n = 2.5 *.* normalizeV (vNormal (y -.- x))
 
-girderZ :: Float -> Point2 -> Point2 -> Picture
+girderZ 
-girderZ w x y = setDepth 50 $ color red $ pictures $
+    :: Float -- ^ height
-    [ thickLine [xt,yt] 3 
+    -> Float -- ^ distance between cross bars
-    , thickLine [xb,yb] 3
+    -> Float -- ^ width
+    -> Point2 -> Point2 -> Shape
+girderZ h d w x y = colorSH red $ mconcat $
+    [ highPipe h xt yt
+    , highPipe h xb yb
     ]
-    ++ map (flip thickLine 3 . tflat2) ls
+    <> zipWith (highPipe (h- 5)) ps qs
   where
     n = w *.* normalizeV (vNormal $ y -.- x)
     xb = x +.+ n
     yb = y +.+ n
     xt = x -.- n
     yt = y -.- n
-    ps = divideLineExact (w*2) xb yb
+    ps = divideLineExact d xb yb
-    dia = rotateV (pi/4) n
+    qs = tail $ divideLineExact d xt yt
-    ps' = map (\p -> intersectSegLine xt yt p (p +.+ dia)) ps
+
-    ls = catMaybes $ zipWith (fmap . (,)) ps ps'
+girderV 
-girderV :: Color -> Float -> Point2 -> Point2 -> Picture
+    :: Float -- ^ height
-girderV col w x y = setDepth 50 $ color col $ pictures $
+    -> Float -- ^ distance between cross bars
-    [ thickLine [xt,yt] 3 
+    -> Float -- ^ width
-    , thickLine [xb,yb] 3
+    -> Point2 -> Point2 -> Shape
+girderV h d w x y = colorSH red $ mconcat $
+    [ highPipe h xt yt
+    , highPipe h xb yb
     ]
-    ++ map (flip thickLine 3 . tflat2) as'
+    <> zipWith (highPipe (h- 5)) ps qs
-    ++ map (flip thickLine 3 . tflat2) bs'
   where
     n = w *.* normalizeV (vNormal $ y -.- x)
     xb = x +.+ n
     yb = y +.+ n
     xt = x -.- n
     yt = y -.- n
-    ps = divideLineExact (w*2) xb yb
+    ps = evenDouble $ divideLineExact d xb yb
-    (as,_) = evenOddSplit ps
+    qs = head qs' : evenDouble(tail qs')
-    f a = map (\p -> intersectSegLine xt yt p (p +.+ rotateV a n))
+      where
-    as' = catMaybes $ zipWith (fmap . (,)) as $ f (pi/4) as
+        qs' = divideLineExact d xt yt
-    bs' = catMaybes $ zipWith (fmap . (,)) as $ f (3*pi/4) as
+    evenDouble (a:_:xs) = a:a:evenDouble xs
-girder :: Color -> Float -> Point2 -> Point2 -> Picture
+    evenDouble xs = xs
-girder col w x y = pictures $
+
-    setDepth 50 (color col $ pictures $
+girder 
-        [ thickLine [xt,yt] 3 
+    :: Float -- ^ height
-        , thickLine [xb,yb] 3
+    -> Float -- ^ distance between cross bars
-        ]
+    -> Float -- ^ width
-        ++ map (flip thickLine 3 . tflat2) ls
+    -> Point2 -> Point2 -> Shape
-    )
+girder h d w x y = colorSH red $ mconcat $
-    : map (\p -> verticalPipe 1.5 col p 0 (-0.1)) [xb,xt,yb,yt]
+    [ highPipe h xt yt
+    , highPipe h xb yb
+    ]
+    <> zipWith (highPipe (h- 5)) ps qs
   where
     n = w *.* normalizeV (vNormal $ y -.- x)
     xb = x +.+ n
     yb = y +.+ n
     xt = x -.- n
     yt = y -.- n
-    ps = divideLineExact (w*2) xb yb
+    ps = divideLineExact d xb yb
-    ps' = map (\p -> intersectSegLine xt yt p (p +.+ n)) ps
+    qs = divideLineExact d xt yt
-    ls = catMaybes $ zipWith (fmap . (,)) ps ps'
-
-
---highGirder :: Point2 -> Point2 -> Picture
---highGirder x y = 

src/Dodge/Room/Start.hs

@@ -24,7 +24,7 @@ startRoom = do
     w <- state $ randomR (100,400)
     h <- state $ randomR (200,400)
     let fground = sPS (V2 0 0) 0 $ PutForeground $ 
-               highPipe 80 (V2  0    (h/3)) (V2  w    (h/2))
+               girderV 50 20 10 (V2  0    (h/5)) (V2  w    (h/5))
             <> highPipe 40 (V2  0    (h/2)) (V2  w    (h/3))
             <> highPipe 60 (V2 (w/3)    0 ) (V2 (w/3)  h   )
         theLamp = sPS (V2 (w/2) (h/2)) 0 $ putColorLamp (V3 0.75 0.75 0.75)