module Geometry.Processes.Billard (
    billard
) where



import Algebra.VectorSpace
import Control.Monad
import Data.List
import Data.Maybe

import Geometry.Core




-- $setup
-- >>> import Draw
-- >>> import qualified Graphics.Rendering.Cairo as C


-- | Shoot a billard ball, and record its trajectory as it is reflected off the
-- edges of a provided geometry.
--
-- <<docs/haddock/Geometry/Processes/Billard/billard.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Geometry/Processes/Billard/billard.svg" 330 360 $ \_ -> do
--     let lambda = transform (translate (Vec2 10 350) <> mirrorYCoords) . Polygon $
--             [ Vec2 0.387   340.156
--             , Vec2 113.773 170.078
--             , Vec2 0.387   0
--             , Vec2 85.426  0
--             , Vec2 312.195 340.156
--             , Vec2 227.156 340.156
--             , Vec2 156.293 233.859
--             , Vec2 85.426  340.156
--             , Vec2 0.387   340.156 ]
--         startPoint = Vec2 100 100
--         startAngle = deg (-25)
--         numReflections = 128
--         startVec = angledLine startPoint startAngle 100
--         billardPoints = startPoint : take numReflections (billard (polygonEdges lambda) startVec)
--     cairoScope $ do
--         setColor (mma 0)
--         C.setDash [2,4] 0
--         sketch lambda
--         C.stroke
--     cairoScope $ do
--         setColor (mma 0)
--         for_ billardPoints $ \point -> sketch (Circle point 3) >> C.stroke
--     cairoScope $ do
--         setColor (mma 1)
--         let billardArrows = zipWith Line billardPoints (tail billardPoints)
--         for_ billardArrows $ \arr -> sketch arr >> C.stroke
-- :}
-- Generated file: size 80KB, crc32: 0xd6e508bf
billard
    :: [Line] -- ^ Geometry; typically involves the edges of a bounding polygon.
    -> Line   -- ^ Initial velocity vector of the ball. Only start and direction,
              --   not length, are relevant for the algorithm.
    -> [Vec2] -- ^ List of collision points. Finite iff the ball escapes the
              --   geometry.
billard :: [Line] -> Line -> [Vec2]
billard [Line]
edges = (Line -> Bool) -> Line -> [Vec2]
go (Bool -> Line -> Bool
forall a b. a -> b -> a
const Bool
True)
  where
    -- The predicate is used to exclude the line just mirrored off of, otherwise
    -- we get rays stuck in a single line due to numerical shenanigans. Note
    -- that this is a valid use case for equality of Double (contained in
    -- Line/Vec2). :-)
    go :: (Line -> Bool) -> Line -> [Vec2]
    go :: (Line -> Bool) -> Line -> [Vec2]
go Line -> Bool
considerEdge ballVec :: Line
ballVec@(Line Vec2
ballStart Vec2
_)
      = let reflectionRays :: [(Line, Line)]
            reflectionRays :: [(Line, Line)]
reflectionRays = do
                Line
edge <- [Line]
edges
                (Line Vec2
_ Vec2
reflectionEnd, Vec2
incidentPoint, LLIntersection
ty) <- Maybe (Line, Vec2, LLIntersection)
-> [(Line, Vec2, LLIntersection)]
forall a. Maybe a -> [a]
maybeToList (Line -> Line -> Maybe (Line, Vec2, LLIntersection)
reflection Line
ballVec Line
edge)
                Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ case LLIntersection
ty of
                    IntersectionReal Vec2
_           -> Bool
True
                    IntersectionVirtualInsideR Vec2
_ -> Bool
True
                    LLIntersection
_otherwise                   -> Bool
False
                Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Vec2
incidentPoint Vec2 -> Line -> Bool
`liesAheadOf` Line
ballVec)
                Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Line -> Bool
considerEdge Line
edge)
                (Line, Line) -> [(Line, Line)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Line
edge, Vec2 -> Vec2 -> Line
Line Vec2
incidentPoint Vec2
reflectionEnd)

        in case [(Line, Line)]
reflectionRays of
            [] -> let Line Vec2
_ Vec2
end = Line
ballVec in [Vec2
end]
            [(Line, Line)]
_  ->
                let (Line
edgeReflectedOn, reflectionRay :: Line
reflectionRay@(Line Vec2
reflectionStart Vec2
_))
                      = ((Line, Line) -> (Line, Line) -> Ordering)
-> [(Line, Line)] -> (Line, Line)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy
                          (\(Line
_, Line Vec2
p Vec2
_) (Line
_, Line Vec2
q Vec2
_) -> Vec2 -> Vec2 -> Vec2 -> Ordering
distanceFrom Vec2
ballStart Vec2
p Vec2
q)
                          [(Line, Line)]
reflectionRays
                in Vec2
reflectionStart Vec2 -> [Vec2] -> [Vec2]
forall a. a -> [a] -> [a]
: (Line -> Bool) -> Line -> [Vec2]
go (Line -> Line -> Bool
forall a. Eq a => a -> a -> Bool
/= Line
edgeReflectedOn) Line
reflectionRay

    liesAheadOf :: Vec2 -> Line -> Bool
    liesAheadOf :: Vec2 -> Line -> Bool
liesAheadOf Vec2
point (Line Vec2
rayStart Vec2
rayEnd)
      = Vec2 -> Vec2 -> Double
dotProduct (Vec2
point Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
rayStart) (Vec2
rayEnd Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
rayStart) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0

    distanceFrom :: Vec2 -> Vec2 -> Vec2 -> Ordering
    distanceFrom :: Vec2 -> Vec2 -> Vec2 -> Ordering
distanceFrom Vec2
start Vec2
p Vec2
q
      = let pDistance :: Double
pDistance = Line -> Double
lineLength (Vec2 -> Vec2 -> Line
Line Vec2
start Vec2
p)
            qDistance :: Double
qDistance = Line -> Double
lineLength (Vec2 -> Vec2 -> Line
Line Vec2
start Vec2
q)
        in Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Double
pDistance Double
qDistance