Work on sensor machines, remove some datatypes associated with placements

src/Dodge/Item/Weapon/BatteryGuns.hs

@@ -5,11 +5,11 @@ module Dodge.Item.Weapon.BatteryGuns
     )
     where
 import Dodge.Data
+import Dodge.Particle.TeslaArc
 import Dodge.SoundLogic.LoadSound
-import Dodge.Creature.State.Data
 import Dodge.Data.DamageType
 import Dodge.WorldEvent
-import Dodge.Wall.Damage
+import Dodge.WorldEvent.Damage
 import Dodge.Default
 import Dodge.Item.Draw
 import Dodge.Item.Data
@@ -173,7 +173,7 @@ makeLaserAt phaseV pos dir = Particle
     { _ptDraw = const blank
     , _ptUpdate = moveLaser phaseV pos dir
     }
-moveLaser 
+moveLaser
     :: Float    -- ^ Phase velocity, controls deflection through windows
     -> Point2 
     -> Float 
@@ -221,11 +221,7 @@ moveLaser phaseV pos dir w pt
     h' ws (_,Right wl) = not $ any (\w' -> _wlID w' == _wlID wl) ws
     h' _ _ = True
     (thHit, ps) = f [] pos xp
-    hitEffect = case thHit of
+    hitEffect = damThingHitWith (Lasering 19) pos xp thHit
-        Just (p,Left cr) 
-            -> creatures . ix (_crID cr) . crState . crDamage %~ (Lasering 19 pos p xp :)
-        Just (p,Right wl) -> damageWall (Lasering 19 pos p xp) wl
-        _   -> id
     pic = setLayer 1 $ pictures
         [ setDepth 19   . color (brightX 0 0.5 yellow) $ lineOfThickness 20 (pos:ps)
         , setDepth 19.5 . color (brightX 10 1 yellow)  $ lineOfThickness 3  (pos:ps)

src/Dodge/LevelGen.hs

@@ -12,7 +12,6 @@ import Dodge.Data
 import Dodge.LevelGen.Block
 import Dodge.LevelGen.Pathing
 import Dodge.LevelGen.StaticWalls
-import Dodge.LevelGen.AutoDoor
 import Dodge.LevelGen.TriggerDoor
 import Dodge.LevelGen.Switch
 import Dodge.LevelGen.Data
@@ -59,10 +58,8 @@ placeSpotID ps w = case _psType ps of
       where 
         mapBoth fn (x,y) = (fn x, fn y) 
     PutSingleDoor col f a b speed 
-        -> putSingleDoor False col f (doShift a) (doShift b) speed w
+        -> placeSingleDoor False col f (doShift a) (doShift b) speed w
-    PutDoubleDoor col f a b speed 
+    --PutAutoDoor a b -> (,) 0 $ placeAutoDoor (doShift a) (doShift b) w
-        -> (,) 0 $ insertDoubleDoor False col f (doShift a) (doShift b) speed w
-    PutAutoDoor a b -> (,) 0 $ addAutoDoor (doShift a) (doShift b) w
     PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
     PutBlock{} -> error "messed up block placement somehow"
     PutBtDoor c bp f a b speed -> addButtonDoor c (doShift bp) (f + rot) 

src/Dodge/LevelGen/AutoDoor.hs

@@ -1,26 +0,0 @@
---{-# LANGUAGE BangPatterns #-}
-{- |
-Creation of doors that open when creatures approach them.
- -}
-module Dodge.LevelGen.AutoDoor
-    where
-import Dodge.Data
-import Dodge.Base
-import Dodge.Creature.Property
---import Dodge.LevelGen.MoveDoor
-import Dodge.LevelGen.TriggerDoor
---import Geometry
-import Picture
-import Geometry.Data
---import qualified DoubleStack as DS
-import qualified IntMapHelp as IM
-
-
-addAutoDoor 
-    :: Point2   -- ^ Left point
-    -> Point2   -- ^ Right point (though the two points should be symmetric)
-    -> World 
-    -> World
-addAutoDoor a b = insertDoubleDoor True (dim yellow) cond a b 3
-  where
-    cond = any (crNearSeg 40 a b) . IM.filter isAnimate . _creatures

src/Dodge/LevelGen/Data.hs

@@ -17,11 +17,10 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutProp Prop
     | PutFlIt Item
     | PutPressPlate PressPlate
-    | PutAutoDoor Point2 Point2
+   -- | PutAutoDoor Point2 Point2
     | PutBlock [Int] Color [Point2]
     | PutLineBlock Wall Float Float Point2 Point2
     | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
-    | PutDoubleDoor Color (World -> Bool) Point2 Point2 Float
     | PutSingleDoor Color (World -> Bool) Point2 Point2 Float
     | PutDoor Color (World -> Bool) [(Point2,Point2)]
     | PutBtDoor Color Point2 Float Point2 Point2 Float

src/Dodge/LevelGen/TriggerDoor.hs

@@ -1,9 +1,8 @@
 --{-# LANGUAGE BangPatterns #-}
 module Dodge.LevelGen.TriggerDoor
     ( putDoor
-    , putSingleDoor
+    , placeSingleDoor
     , addButtonDoor
-    , insertDoubleDoor
     ) where
 import Dodge.Data
 import Dodge.Base
@@ -34,7 +33,7 @@ addButtonDoor c btp btr a b speed w
     $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
     $ set pathGraph newGraph
     $ set pathGraphP newGraphPairs
-    $ snd (putSingleDoor False c cond a b speed w)
+    $ snd (placeSingleDoor False c cond a b speed w)
   where 
     bid = IM.newKey $ _buttons w
     cond w' = BtNoLabel == _btState (_buttons w' IM.! bid)
@@ -123,15 +122,9 @@ doorMechanism drid speed wlidOpCps dr w
         & walls . ix wlid %~ moveDoorToward speed p
         & (\w'' -> foldr (changeZonedWall (moveDoorToward speed p) wlid) w'' (zoneps zp))
 
-insertDoubleDoor ::  Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World
+placeSingleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World
-    -> World
-insertDoubleDoor isPathable col cond a b speed
-    = snd . putSingleDoor isPathable col cond a (0.5 *.* (a +.+ b)) speed
-    . snd . putSingleDoor isPathable col cond b (0.5 *.* (a +.+ b)) speed
-
-putSingleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World
     -> (Int, World)
-putSingleDoor isPathable col cond a b speed w = (drid, addWalls w 
+placeSingleDoor isPathable col cond a b speed w = (drid, addWalls w 
     & doors %~ addDoor)
   where
     drid = IM.newKey $ _doors w

src/Dodge/Machine/Sensor.hs

@@ -11,12 +11,15 @@ import ShapePicture
 import Shape
 
 import Control.Lens
+import Data.Either
 
-lightSensor :: Point2 -> Float -> Placement
+damageSensor 
-lightSensor p r = Placement (PS p r $ PutLS theLS)
+    :: (DamageType -> Either Int Int) -- Left gets sensed, Right does damage
+    -> Point2 -> Float -> Placement
+damageSensor damF p r = Placement (PS p r $ PutLS theLS)
     $ \lsid -> jsps p r $ PutMachine blue (reverse $ square wdth) defaultMachine
-        { _mcDraw = lightSensorSPic 
+        { _mcDraw = sensorSPic 
-        , _mcUpdate = lightSensorUpdate
+        , _mcUpdate = sensorUpdate damF
         , _mcLSs = [lsid]
         }
   where
@@ -25,26 +28,30 @@ lightSensor p r = Placement (PS p r $ PutLS theLS)
         , _lsIntensity = 0.1
         }
 
-lightSensorUpdate :: Machine -> World -> World
+lightSensor :: Point2 -> Float -> Placement
-lightSensorUpdate mc w = w & machines . ix mcid %~ upmc
+lightSensor = damageSensor senseLasering
+
+senseLasering :: DamageType -> Either Int Int
+senseLasering Lasering {_dmAmount = x} = Left x
+senseLasering _ = Right 0
+
+sensorUpdate :: (DamageType -> Either Int Int) -> Machine -> World -> World
+sensorUpdate damF mc w = w & machines . ix mcid %~ upmc
     & lightSources . ix lsid %~ upls
   where
     upmc = ( mcSensor %~ \x' -> min 750 (max 0 (x' - 5 + newSense)) )
+        . ( mcHP -~ sum dam )
         . (mcDamage .~ [])
     x = _mcSensor mc
     mcid = _mcID mc
     lsid = head (_mcLSs mc)
-    newSense = sum . map _dmAmount $ filter isLasering $ _mcDamage mc
+    (senseData,dam) = partitionEithers $ map damF $ _mcDamage mc
+    newSense = sum senseData
     ni = fromIntegral x / 500
     upls = lsIntensity .~ V3 ni ni ni
 
-isLasering Lasering {} = True
+sensorSPic :: Machine -> SPic
-isLasering _ = False
+sensorSPic _ = ( colorSH blue $ upperPrismPoly 25 (square wdth)
-isElectrical Electrical {} = True
-isElectrical _ = False
-
-lightSensorSPic :: Machine -> SPic
-lightSensorSPic mc = ( colorSH blue $ upperPrismPoly 25 (square wdth)
     , mempty )
 
 wdth :: Float

src/Dodge/Particle/Bullet/HitEffect.hs

@@ -4,6 +4,7 @@ Effects of bullets upon impact with walls or creatures.
 module Dodge.Particle.Bullet.HitEffect
     where
 import Dodge.Data
+import Dodge.Particle.Spark
 import Dodge.Data.DamageType
 import Dodge.Data.SoundOrigin
 import Dodge.Wall.Damage

src/Dodge/Particle/Spark.hs

@@ -0,0 +1,41 @@
+module Dodge.Particle.Spark
+    ( colSpark
+    , colSpark'
+    )
+    where
+import Dodge.Data
+import Dodge.Data.DamageType
+import Dodge.Particle.Bullet.Draw
+import Dodge.Particle.Bullet.Update
+import Dodge.WorldEvent.HitEffect
+import Dodge.Creature.State.Data
+import Color
+import Geometry
+
+import System.Random
+import Control.Lens
+
+colSpark :: Int -> Color -> Point2 -> Float -> World -> World
+colSpark = colSpark' 0.7
+colSpark' :: Float -> Int -> Color -> Point2 -> Float -> World -> World
+colSpark' randDir time col pos baseDir w = w 
+    & worldEvents %~ ( over particles (spark :) . )
+    & randGen .~ g
+  where 
+    (a,g)  = randomR (-randDir,randDir) $ _randGen w
+    dir = a + baseDir
+    spark = BulletPt
+        { _ptDraw = drawBul
+        , _ptUpdate = mvGenBullet
+        , _btVel' = rotateV dir (V2 5 0)
+        , _btColor' = col
+        , _btTrail' = [pos]
+        , _btPassThrough' = Nothing
+        , _btWidth' = 1
+        , _btTimer' = time
+        , _btHitEffect' = destroyOnImpact sparkEff noEff
+        }
+    sparkEff bt p cr = creatures . ix (_crID cr) . crState . crDamage %~ ( SparkDam 1 sp p ep : )
+      where 
+        sp = head (_btTrail' bt)
+        ep = sp +.+ _btVel' bt

src/Dodge/Particle/TeslaArc.hs

@@ -0,0 +1,132 @@
+module Dodge.Particle.TeslaArc
+    ( makeTeslaArcAt
+    ) where
+import Dodge.Data
+import Dodge.Data.DamageType
+import Dodge.Creature.State.Data
+import Dodge.WorldEvent.Damage
+import Dodge.Base
+import Dodge.Zone
+import Dodge.Base.Collide
+import Dodge.Picture
+import Dodge.Particle.Spark
+import Dodge.WorldEvent.ThingsHit
+import Dodge.RandomHelp
+import Picture
+import Geometry
+import qualified IntMapHelp as IM
+
+import Control.Lens
+import System.Random
+import Control.Monad.State
+import Data.Function (on)
+import Data.List
+import Data.Maybe
+makeTeslaArcAt :: Color -> Point2 -> Float -> Particle
+makeTeslaArcAt col pos dir = LinearParticle
+    { _ptPoints = [pos]
+    , _ptDraw = drawTeslaArc
+    , _ptUpdate = moveTeslaArc pos dir
+    , _ptTimer = 2
+    , _ptColor = brightX 100 1.5 col
+    }
+drawTeslaArc :: Particle -> Picture
+drawTeslaArc pt = setLayer 1 $ pictures 
+    [ setDepth 20.5 $ color (brightX 2 1 $ _ptColor pt) $ lineOfThickness  3 ps
+    , setDepth 20   $ color (V4 0 0 0 0.5)              $ lineOfThickness 10 ps
+    ]
+  where
+    ps = _ptPoints pt
+-- todo: fix electrical damage location
+moveTeslaArc 
+    :: Point2   -- ^ Emmission position
+    -> Float    -- ^ Emmission direction
+    -> World 
+    -> Particle
+    -> (World, Maybe Particle)
+moveTeslaArc p d w pt
+    | t == 2 = 
+        (foldr damCrs w hitCrs & randGen .~ g & colSpark 8 nc q2 (argV sv)
+             & damThingHitWith (Electrical 50) q1 ((2 *.* q2) -.- q1) thHit
+        , Just $ pt & ptTimer -~ 1 & ptPoints .~ ps'
+        )
+    | t < 1     = (w , Nothing)
+    | otherwise = (w , Just $ pt & ptTimer -~ 1)
+ where 
+    t = _ptTimer pt
+    ps = take 25 $ p : map f (crsLightChain p d 0 w)
+    f (E3x1 cr) = _crPos cr
+    f (E3x2 p1) = p1
+    f (E3x3 p1) = p1
+    ps' = lightningMids d pers ps
+    pers = evalState (sequence $ repeat $ randInCirc 5) $ _randGen w
+    nc = brightX 100 1.5 $ numColor colid
+    (colid,g) = randomR (0::Int,5) $ _randGen w
+    f1 (E3x1 cr) = Just $ _crID cr
+    f1 _         = Nothing
+    hitCrs       = mapMaybe f1 $ take 14 $ crsLightChain p d 0 w
+    damCrs cid = over (creatures . ix cid . crState . crDamage) (Electrical 5 cpos cpos cpos :)
+      where 
+        cpos = _crPos (_creatures w IM.! cid)
+    q1 = last $ init ps'
+    q2 = last ps'
+    hitWall = reflectPointWalls q1 ((2 *.* q2) -.- q1) $ wallsNearPoint q1 w
+    thHit = thingHit q1 ((2 *.* q2) -.- q1) w
+    sv = maybe (q2 -.- q1) snd hitWall
+{- Finds a point somewhere roughly inbetween two points.  -}
+lightningMid :: Float -> Point2 -> Point2 -> Point2
+lightningMid d p1 p2 = (0.25 *.* (p1 +.+ p2)) +.+ 0.5 *.* p3
+    where p3 = errorClosestPointOnLine 1 p1 (p1 +.+ unitVectorAtAngle d) p2
+{- Finds extra middle points between successive points in a list of points.  -}
+lightningMids :: Float -> [Point2] -> [Point2] -> [Point2]
+lightningMids d1 (p:pers) (p1:p3:ps)
+    = let p2 = p +.+ lightningMid d1 p1 p3
+          d2 = argV $ p3 -.- p2
+      in  p1 : p2 : lightningMids d2 pers (p3:ps)
+lightningMids _ _ ps = ps
+{- Finds a list of hit things from a given point.
+'E3x1' objects are creatures, 'E3x2' objects are points on walls, 'E3x3' objects are points in space.  -}
+crsLightChain :: Point2 -> Float -> Float -> World -> [Either3 Creature Point2 Point2]
+crsLightChain p d wlAttract w = case crOrWallSensitive p d wlAttract w of
+    E3x1 cr -> E3x1 cr : crsLightChain (_crPos cr) (argV (_crPos cr -.- p)) 
+                                       (min 1 (wlAttract + 0.3)) w
+    E3x2 p1 -> [E3x2 p1]
+    E3x3 p1 -> E3x3 p1 : crsLightChain p1 (dChange + argV (p1 -.- p)) (min 1 (wlAttract + 0.3)) (set randGen g w)
+  where 
+    (dChange, g) = randomR (-0.5,0.5) $ _randGen w
+{-
+Finds whether a creature or wall is in front of a given point and direction.
+Evaluates to a creature as an 'E3x1' or a wall as an 'E3x2'.
+Has a parameter to tweak how attracted the test is to walls.
+ -}
+crOrWallSensitive 
+    :: Point2   -- ^ Start point
+    -> Float    -- ^ Direction (radians)
+    -> Float    -- ^ Wall attraction parameter
+    -> World 
+    -> Either3 Creature Point2 Point2
+crOrWallSensitive p dir wlAttract w = fromMaybe (E3x3 $ p +.+ rotateV dir (V2 arcLen 0))
+    . listToMaybe 
+    . sortBy (compare `on` g)
+    $ catMaybes [cr,wlp]
+  where 
+    cr  = E3x1 <$> nearestCrInFront p dir 100 w
+    wlp = fmap E3x2 
+        . listToMaybe
+        . sortBy (compare `on` dist p)
+        $ mapMaybe 
+            ( fmap fst
+            . (\p1 -> reflectPointWalls p p1 $ wallsNearPoint p w)
+            . (+.+) p
+            . (\d -> rotateV d (V2 100 0))
+            . (+ dir)
+            . (* wlAttract)
+            )
+            [-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8]
+    g (E3x2 p1)  = 100 + dist p p1 -- tweak makes it more likely to hit crs first
+    --g (E3x2 p1)  = dist p p1 - 100 -- tweak makes it more likely to hit walls first
+    g (E3x1 cr1) = dist p $ _crPos cr1
+    g _ = 0
+    (arcLen,_) = randomR (25,50) $ _randGen w
+-- BUG: can hit crs through walls
+

src/Dodge/Placements.hs

@@ -0,0 +1,23 @@
+module Dodge.Placements
+    ( putDoubleDoorThen
+    , putAutoDoor
+    )
+    where
+import Dodge.Data
+import Dodge.Base
+import Color
+import Geometry
+import Dodge.LevelGen.Data
+import Dodge.Creature.Property
+
+import qualified Data.IntMap.Strict as IM
+putDoubleDoorThen :: Color -> (World -> Bool)  -> Point2 -> Point2 -> Float -> Maybe Placement -> Placement
+putDoubleDoorThen col cond a b speed mayp = ps0j (PutSingleDoor col cond a half speed)
+    $ Placement (PS (V2 0 0) 0 (PutSingleDoor col cond b half speed)) $ const mayp
+  where
+    half = 0.5 *.* (a +.+ b)
+
+putAutoDoor :: Point2 -> Point2 -> Placement
+putAutoDoor a b = putDoubleDoorThen (dim yellow) cond a b 3 Nothing
+  where
+    cond = any (crNearSeg 40 a b) . IM.filter isAnimate . _creatures

src/Dodge/Room/Airlock.hs

@@ -7,6 +7,7 @@ import Dodge.Room.Placement
 import Dodge.Room.Foreground
 import Dodge.Default.Room
 import Dodge.Data
+import Dodge.Placements
 import Dodge.LevelGen.Data
 import Dodge.LevelGen.Switch
 import Dodge.RandomHelp
@@ -18,7 +19,8 @@ import System.Random
 import Control.Monad.State
 {- | A passage with a switch that opens forward access while closing backwards access. -}
 airlock :: RandomGen g => State g Room
-airlock = takeOne [airlock0,airlock90,airlockCrystal]
+--airlock = takeOne [airlock0,airlock90,airlockCrystal]
+airlock = takeOne [airlock0]
 {- | Straight airlock -}
 airlock0 :: Room
 airlock0 = defaultRoom
@@ -27,8 +29,10 @@ airlock0 = defaultRoom
     , _rmPath  = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20  5) ]
     , _rmPS    = 
         [Placement (PS (V2 (-35) 50) (negate $ pi/2) $ PutButton $ makeSwitch col red id id)
-            $ \btid -> jspsJ (V2 0 20) 0 (PutDoubleDoor col (not . cond' btid) (V2 1 0) (V2 39 0) 2)
+            $ \btid -> Just $ putDoubleDoorThen col (not . cond' btid) (V2 (-1) 20) (V2 41 20) 2
-            $ sPS (V2 0 80) 0 $ PutDoubleDoor col (cond' btid) (V2 1 0) (V2 39 0) 2
+                $ Just $ putDoubleDoorThen col (cond' btid) (V2 (-1) 80) (V2 41 80) 2 Nothing
+          --  $ \btid -> jspsJ (V2 0 0) 0 (PutDoubleDoor col (not . cond' btid) (V2 1 20) (V2 39 20) 2)
+          --  $ sPS (V2 0 0) 0 $ PutDoubleDoor col (cond' btid) (V2 1 80) (V2 39 80) 2
         ,mountedLightI 70 (V2 (-2) 30) (V2 (-2) 70)
         ,sps0 $ PutForeground $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
         ]

src/Dodge/Room/Door.hs

@@ -5,11 +5,8 @@ module Dodge.Room.Door
     where
 import Geometry
 import Dodge.Room.Data
-import Dodge.LevelGen.Data
 import Dodge.Default.Room
-
+import Dodge.Placements
---import Control.Monad.State
---import System.Random
 
 door :: Room
 door = defaultRoom
@@ -17,7 +14,7 @@ door = defaultRoom
     , _rmLinks = lnks
     , _rmPath  = [(V2 20 35,V2 20 5)]
 -- door extends into side walls (for shadows as rendered 12/03)
-    , _rmPS    = [sPS (V2 0 20) 0 $ PutAutoDoor (V2 0 0) (V2 40 0)]
+    , _rmPS    = [putAutoDoor (V2 0 20) (V2 40 20)]
     , _rmBound = [] 
     }
     where lnks = [(V2 20 35,0)

src/Dodge/Wall/Damage.hs

@@ -7,9 +7,9 @@ module Dodge.Wall.Damage
     ) where
 import Dodge.Data
 import Dodge.Data.DamageType
-import Dodge.WorldEvent.SpawnParticle
 import Dodge.WorldEvent.Cloud
 import Dodge.Wall.Reflect
+import Dodge.Particle.Spark
 import Geometry
 import Geometry.Vector3D
 import Color

src/Dodge/WorldEvent/Damage.hs

@@ -0,0 +1,22 @@
+module Dodge.WorldEvent.Damage
+    ( damThingHitWith
+    ) where
+import Dodge.Data
+import Dodge.Data.DamageType
+import Dodge.Creature.State.Data
+import Geometry
+import Dodge.Wall.Damage
+
+import Control.Lens
+
+damThingHitWith 
+    :: (Point2 -> Point2 -> Point2 -> DamageType)
+    -> Point2
+    -> Point2
+    -> Maybe (Point2, Either Creature Wall)
+    -> World 
+    -> World
+damThingHitWith partDT sp ep mayEiCrWl = case mayEiCrWl of
+    Just (hitp,Left cr )  -> creatures . ix (_crID cr) . crState . crDamage %~ (partDT sp hitp ep :)
+    Just (hitp,Right wl) -> damageWall (partDT sp hitp ep) wl
+    Nothing -> id

src/Dodge/WorldEvent/SpawnParticle.hs

@@ -5,25 +5,17 @@ module Dodge.WorldEvent.SpawnParticle
     ( makeGasCloud
     , aFlameParticle
     , makeFlameletTimed
-    , makeTeslaArcAt
-    , colSpark
-    , colSpark'
     ) where
 import Dodge.Data
 import Dodge.Data.DamageType
 import Dodge.Data.SoundOrigin
 import Dodge.Creature.State.Data
+--import Dodge.WorldEvent.Damage
 import Dodge.Base
-import Dodge.Zone
-import Dodge.Base.Collide
-import Dodge.Picture
---import Dodge.Picture.Layer
 import Dodge.WorldEvent.HitEffect
 import Dodge.WorldEvent.ThingsHit
 import Dodge.WorldEvent.Cloud
 import Dodge.WorldEvent.Flash
-import Dodge.Particle.Bullet.Draw
-import Dodge.Particle.Bullet.Update
 import Dodge.SoundLogic
 import Dodge.SoundLogic.LoadSound
 import Dodge.RandomHelp
@@ -37,9 +29,6 @@ import qualified IntMapHelp as IM
 import Control.Lens
 import System.Random
 import Control.Monad.State
-import Data.Function (on)
-import Data.List
-import Data.Maybe
 import Data.Tuple
 aFlameParticle 
     :: Int      -- ^ Timer
@@ -252,136 +241,3 @@ cloudPoisonDamage c w = w & creatures %~ flip (foldr (IM.adjust doDam)) damagedC
     damagedCrs = IM.keys $ IM.filter f $ creaturesNearPoint (stripZ $ _clPos c) w
     f cr = dist3 (addZ 20 $ _crPos cr) (_clPos c) < _crRad cr + _clRad c + 10
     doDam cr = cr & crState . crDamage %~ (PoisonDam 1 :)
-makeTeslaArcAt :: Color -> Point2 -> Float -> Particle
-makeTeslaArcAt col pos dir = LinearParticle
-    { _ptPoints = [pos]
-    , _ptDraw = drawTeslaArc
-    , _ptUpdate = moveTeslaArc pos dir
-    , _ptTimer = 2
-    , _ptColor = brightX 100 1.5 col
-    }
-drawTeslaArc :: Particle -> Picture
-drawTeslaArc pt = setLayer 1 $ pictures 
-    [ setDepth 20.5 $ color (brightX 2 1 $ _ptColor pt) $ lineOfThickness  3 ps
-    , setDepth 20   $ color (V4 0 0 0 0.5)              $ lineOfThickness 10 ps
-    ]
-  where
-    ps = _ptPoints pt
--- todo: fix electrical damage location
-moveTeslaArc 
-    :: Point2   -- ^ Emmission position
-    -> Float    -- ^ Emmission direction
-    -> World 
-    -> Particle
-    -> (World, Maybe Particle)
-moveTeslaArc p d w pt
-    | t == 2 = 
-        (foldr damCrs w hitCrs & randGen .~ g
-            & colSpark 8 nc q2 (argV sv)
-        , Just $ pt 
-            & ptTimer -~ 1
-            & ptPoints .~ ps'
-        )
-    | t < 1 = (w , Nothing)
-    | otherwise = (w , Just $ pt & ptTimer -~ 1)
- where 
-    t = _ptTimer pt
-    ps = take 25 $ p : map f (crsLightChain p d 0 w)
-    f (E3x1 cr) = _crPos cr
-    f (E3x2 p1) = p1
-    f (E3x3 p1) = p1
-    ps' = lightningMids d pers ps
-    pers = evalState (sequence $ repeat $ randInCirc 5) $ _randGen w
-    nc = brightX 100 1.5 $ numColor colid
-    (colid,g) = randomR (0::Int,5) $ _randGen w
-    f1 (E3x1 cr) = Just $ _crID cr
-    f1 _         = Nothing
-    hitCrs       = mapMaybe f1 $ take 14 $ crsLightChain p d 0 w
-    damCrs cid = over (creatures . ix cid . crState . crDamage) (Electrical 5 cpos cpos cpos :)
-      where 
-        cpos = _crPos (_creatures w IM.! cid)
-    q1 = last $ init ps'
-    q2 = last ps'
-    hitWall = reflectPointWalls q1 ((2 *.* q2) -.- q1) $ wallsNearPoint q1 w
-    sv = maybe (q2 -.- q1) snd hitWall
-{- Finds a point somewhere roughly inbetween two points.  -}
-lightningMid :: Float -> Point2 -> Point2 -> Point2
-lightningMid d p1 p2 = (0.25 *.* (p1 +.+ p2)) +.+ 0.5 *.* p3
-    where p3 = errorClosestPointOnLine 1 p1 (p1 +.+ unitVectorAtAngle d) p2
-{- Finds extra middle points between successive points in a list of points.  -}
-lightningMids :: Float -> [Point2] -> [Point2] -> [Point2]
-lightningMids d1 (p:pers) (p1:p3:ps)
-    = let p2 = p +.+ lightningMid d1 p1 p3
-          d2 = argV $ p3 -.- p2
-      in  p1 : p2 : lightningMids d2 pers (p3:ps)
-lightningMids _ _ ps = ps
-{- Finds a list of hit things from a given point.
-'E3x1' objects are creatures, 'E3x2' objects are points on walls, 'E3x3' objects are points in space.  -}
-crsLightChain :: Point2 -> Float -> Float -> World -> [Either3 Creature Point2 Point2]
-crsLightChain p d wlAttract w = case crOrWallSensitive p d wlAttract w of
-    E3x1 cr -> E3x1 cr : crsLightChain (_crPos cr) (argV (_crPos cr -.- p)) 
-                                       (min 1 (wlAttract + 0.3)) w
-    E3x2 p1 -> [E3x2 p1]
-    E3x3 p1 -> E3x3 p1 : crsLightChain p1 (dChange + argV (p1 -.- p)) (min 1 (wlAttract + 0.3)) (set randGen g w)
-  where 
-    (dChange, g) = randomR (-0.5,0.5) $ _randGen w
-{-
-Finds whether a creature or wall is in front of a given point and direction.
-Evaluates to a creature as an 'E3x1' or a wall as an 'E3x2'.
-Has a parameter to tweak how attracted the test is to walls.
- -}
-crOrWallSensitive 
-    :: Point2   -- ^ Start point
-    -> Float    -- ^ Direction (radians)
-    -> Float    -- ^ Wall attraction parameter
-    -> World 
-    -> Either3 Creature Point2 Point2
-crOrWallSensitive p dir wlAttract w = fromMaybe (E3x3 $ p +.+ rotateV dir (V2 arcLen 0))
-    . listToMaybe 
-    . sortBy (compare `on` g)
-    $ catMaybes [cr,wlp]
-  where 
-    cr  = E3x1 <$> nearestCrInFront p dir 100 w
-    wlp = fmap E3x2 
-        . listToMaybe
-        . sortBy (compare `on` dist p)
-        $ mapMaybe 
-            ( fmap fst
-            . (\p1 -> reflectPointWalls p p1 $ wallsNearPoint p w)
-            . (+.+) p
-            . (\d -> rotateV d (V2 100 0))
-            . (+ dir)
-            . (* wlAttract)
-            )
-            [-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8]
-    g (E3x2 p1)  = 100 + dist p p1 -- tweak makes it more likely to hit crs first
-    --g (E3x2 p1)  = dist p p1 - 100 -- tweak makes it more likely to hit walls first
-    g (E3x1 cr1) = dist p $ _crPos cr1
-    g _ = 0
-    (arcLen,_) = randomR (25,50) $ _randGen w
--- BUG: can hit crs through walls
-
-colSpark :: Int -> Color -> Point2 -> Float -> World -> World
-colSpark = colSpark' 0.7
-colSpark' :: Float -> Int -> Color -> Point2 -> Float -> World -> World
-colSpark' randDir time col pos baseDir w = w 
-    & worldEvents %~ ( over particles (spark :) . )
-    & randGen .~ g
-  where 
-    (a,g)  = randomR (-randDir,randDir) $ _randGen w
-    dir = a + baseDir
-    spark = BulletPt
-        { _ptDraw = drawBul
-        , _ptUpdate = mvGenBullet
-        , _btVel' = rotateV dir (V2 5 0)
-        , _btColor' = col
-        , _btTrail' = [pos]
-        , _btPassThrough' = Nothing
-        , _btWidth' = 1
-        , _btTimer' = time
-        , _btHitEffect' = destroyOnImpact sparkEff noEff
-        }
-    sparkEff bt p cr = creatures . ix (_crID cr) . crState . crDamage %~ ( SparkDam 1 sp p ep : )
-      where 
-        sp = head (_btTrail' bt)
-        ep = sp +.+ _btVel' bt

src/Dodge/WorldEvent/ThingsHit.hs

@@ -3,6 +3,7 @@ Find which objects lie upon a line.
  -}
 module Dodge.WorldEvent.ThingsHit
     ( thingsHit
+    , thingHit
     , thingsHitLongLine
     , thingsHitExceptCr
     , thingsHitExceptCrLongLine
@@ -40,6 +41,8 @@ thingsHit sp ep w
         _        -> IM.empty
     wls = zip (map (fromJust . hitPoint) hitWls) (map Right hitWls)
     hitPoint w' = uncurry (intersectSegSeg sp ep) (_wlLine w')
+thingHit :: Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall)
+thingHit sp ep = listToMaybe . thingsHit sp ep
 {- List objects that appear on a line.
 Can filter out a creature.  -}
 thingsHitExceptCr