Add intersecting beams

src/Dodge/Update.hs

@@ -59,6 +59,7 @@ functionalUpdate cfig w = checkEndGame
     . dbArg _worldEvents
     . updateIMl _modifications _mdUpdate
     . updateParticles 
+    . updateBeams
     . updateIMl _props _pjUpdate  
     . updateLightSources
     . updateClouds
@@ -141,6 +142,74 @@ updateParticles :: World -> World
 updateParticles w = updateInstantParticles $ set particles (catMaybes ps) w'
   where 
     (w',ps) = mapAccumR (\a b -> _ptUpdate b a b) w $ _particles w
+updateBeams :: World -> World
+updateBeams w = w
+    & newBeams .~ WorldBeams [] [] [] []
+    & beams    .~ thebeams
+    & combineBeams thebeams
+  where
+    thebeams = _newBeams w
+
+combineBeams :: WorldBeams -> World -> World
+combineBeams wbeams w = w'' 
+    & beams . positronBeams .~ pbeams
+    & beams . electronBeams .~ ebeams
+  where
+    (w',pbeams) = mapAccumR (combineBeamBeams (_electronBeams wbeams)) w $ _positronBeams wbeams
+    (w'',ebeams) = mapAccumR (combineBeamBeams (_positronBeams wbeams)) w' $ _electronBeams wbeams
+
+combineBeamBeams :: [Beam] -> World -> Beam -> (World,Beam)
+combineBeamBeams bms w bm = case intersectBeamBeams bm bms of
+    (ps,Nothing) -> (w, bm & bmFirstPoints .~ ps)
+    (ps,Just a)  -> (_beamCombine (_bmType bm) a w, bm & bmFirstPoints .~ ps)
+
+-- intersect a beam with a list of beams.
+-- returns the (reversed) travel of the beam up to maybe an intersection point
+intersectBeamBeams :: Beam -> [Beam] 
+    -> ([Point2], Maybe (Point2,(Point2,Point2,Beam),(Point2,Point2,Beam)))
+intersectBeamBeams bm bms = f [] $ _bmPoints bm
+  where
+    f ps (x:y:ys) = case intersectSegBeams x y bms of
+        Just (z,a) -> ((z:x:ps), Just (z,(x,y,bm),a))
+        Nothing -> f (x:ps) (y:ys)
+    f ps (x:[]) = (x:ps, Nothing)
+    f _ _ = error "made an empty beam"
+
+intersectSegBeams :: Point2 -> Point2 -> [Beam] -> Maybe (Point2,(Point2,Point2,Beam))
+intersectSegBeams sp ep (bm:bms) = case intersectSegBeam sp ep bm of
+    Nothing -> intersectSegBeams sp ep bms
+    Just a@(z,_) -> maybe (Just a) Just $ intersectSegBeams sp z bms
+intersectSegBeams _ _ _ = Nothing
+
+intersectSegBeam :: Point2 -> Point2 -> Beam -> Maybe (Point2,(Point2,Point2,Beam))
+intersectSegBeam sp ep bm = case intersectSegSegs' sp ep (_bmPoints bm) of
+    Nothing -> Nothing
+    Just (z,x,y) -> Just (z,(x,y,bm))
+
+intersectSegSegs' :: Point2 -> Point2 -> [Point2] -> Maybe (Point2,Point2,Point2)
+intersectSegSegs' sp ep (x:y:ys) = case intersectSegSeg sp ep x y of
+    Just z  -> maybe (Just (z,x,y)) Just $ intersectSegSegs' sp z (y:ys)
+    Nothing -> intersectSegSegs' sp ep (y:ys)
+intersectSegSegs' _ _ _ = Nothing
+
+--intersectSegSegs :: Point2 -> Point2 -> [Point2] -> Maybe Point2
+--intersectSegSegs sp ep (x:y:ys) = case intersectSegSeg sp ep x y of
+--    Just z  -> maybe (Just z) Just $ intersectSegSegs sp z (y:ys)
+--    Nothing -> intersectSegSegs sp ep (y:ys)
+--intersectSegSegs _ _ _ = Nothing
+--
+--intersectSegSegss :: Point2 -> Point2 -> [[Point2]] -> Maybe Point2
+--intersectSegSegss sp ep (as:ass) = case intersectSegSegs sp ep as of
+--    Just z  -> maybe (Just z) Just $ intersectSegSegss sp z ass
+--    Nothing -> intersectSegSegss sp ep ass
+--intersectSegSegss _ _ _ = Nothing
+--
+--intersectSegsSegss :: [Point2] -> [[Point2]] -> Maybe Point2
+--intersectSegsSegss (x:y:ys) ass = maybe 
+--    (intersectSegsSegss (y:ys) ass)
+--    Just
+--    (intersectSegSegss x y ass)
+--intersectSegsSegss _ _ = Nothing
 
 updateInstantParticles :: World -> World
 updateInstantParticles w = case _instantParticles w of