{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Imj.Physics.Discrete.Collision
(
mirrorSpeedAndMoveToPrecollisionIfNeeded
, CollisionStatus(..)
, firstCollision
, Location(..)
) where
import Imj.Prelude
import Imj.Geo.Discrete
import Imj.Physics.Discrete.Types
data Location = InsideWorld
| OutsideWorld
deriving(Eq, Show)
data CollisionStatus = NoCollision
| PreCollision
mirrorSpeedAndMoveToPrecollisionIfNeeded :: (Coords Pos -> Location)
-> PosSpeed
-> (PosSpeed, CollisionStatus)
mirrorSpeedAndMoveToPrecollisionIfNeeded getLocation posspeed@(PosSpeed pos speed) =
maybe
(posspeed, NoCollision)
adjustPosSpeed
$ firstCollision getLocation trajectory
where
trajectory = bresenham $ mkSegment pos $ sumPosSpeed pos speed
adjustPosSpeed (mirror, newPos) = (PosSpeed newPos $ mirrorSpeed speed mirror, PreCollision)
firstCollision :: (Coords Pos -> Location)
-> [Coords Pos]
-> Maybe (Mirror, Coords Pos)
firstCollision getLocation (p1:theRest@(p2:_)) =
mirrorIfNeededAtomic getLocation (PosSpeed p1 (diffPosToSpeed p2 p1)) <|> firstCollision getLocation theRest
firstCollision _ _ = Nothing
mirrorSpeed :: Coords Vel -> Mirror -> Coords Vel
mirrorSpeed (Coords dr dc) m =
case m of
MirrorRow -> Coords (negate dr) dc
MirrorCol -> Coords dr (negate dc)
MirrorAll -> Coords (negate dr) (negate dc)
data Mirror = MirrorRow
| MirrorCol
| MirrorAll
mirrorIfNeededAtomic :: (Coords Pos -> Location) -> PosSpeed -> Maybe (Mirror, Coords Pos)
mirrorIfNeededAtomic getLocation (PosSpeed pos@(Coords r c) (Coords dr dc)) =
let future = Coords (r+dr) (c+dc)
isWall coord = getLocation coord == OutsideWorld
mirror = case getLocation future of
OutsideWorld
| dr == 0 -> Just MirrorCol
| dc == 0 -> Just MirrorRow
| otherwise ->
case (isWall (Coords (r+dr) c),
isWall (Coords r (c+dc))) of
(True, True) -> Just MirrorAll
(False, False) -> Just MirrorAll
(True, False) -> Just MirrorRow
(False, True) -> Just MirrorCol
InsideWorld
| dr == 0 -> Nothing
| dc == 0 -> Nothing
| otherwise ->
case (isWall (Coords (r+dr) c),
isWall (Coords r (c+dc))) of
(True, True) -> Just MirrorAll
(False, False) -> Nothing
(True, False) -> Just MirrorRow
(False, True) -> Just MirrorCol
in maybe Nothing (\m -> Just (m, pos)) mirror