DailyProgrammer #163 in Haskell
-- A program to take line segments in and find intersections fast | |
-- Challenge from: http://thirdpartyninjas.com/blog/2008/10/07/line-segment-intersection/ | |
-- Intersection algorithm from: http://stackoverflow.com/a/565282/786339 | |
import Data.Maybe -- To make Maybe handling easier | |
import Data.List -- So we can sort | |
import System.IO -- For file loading | |
------------------ Some types we'll use ------------------ | |
data Point = Point Float Float -- Our simple coords | |
deriving Eq | |
type Magnitude = Point | |
data Line = Line Point Point -- A line segment | |
deriving Eq | |
data NamedLine = NamedLine { -- A line with a name | |
getName :: String, | |
getTheLine :: Line -- 'the' to avoid name collision with Prelude | |
} | |
data NamedIntersection = NamedIntersection { -- Intersections we find | |
getNameA :: String, | |
getNameB :: String, | |
getIntersection :: Point | |
} deriving Eq | |
------------------ Instances so we can show things easily, sort, and check equality ------------------ | |
instance Show Line where | |
show (Line p1 p2) = show p1 ++ "," ++ show p2 | |
instance Show Point where | |
show (Point x y) = "(" ++ show x ++ ", " ++ show y ++ ")" | |
instance Show NamedLine where | |
show (NamedLine name line) = name ++ " " ++ show line | |
instance Show NamedIntersection where | |
show (NamedIntersection a b p) = a ++ " " ++ b ++ " " ++ show p | |
instance Eq NamedLine where | |
(==) a b = (getName a) == (getName b) | |
instance Ord NamedLine where | |
compare a b = (getName a) `compare` (getName b) | |
instance Ord NamedIntersection where | |
compare a b | |
| firstResult == EQ = (getNameB a) `compare` (getNameB b) | |
| otherwise = firstResult | |
where | |
firstResult = (getNameA a) `compare` (getNameA b) | |
------------------ Functions to work on our types ------------------ | |
normalizeLine :: Line -> Line -- Make lines go left to right, because I like it that way | |
normalizeLine l@(Line p1@(Point a b) p2@(Point c d)) = | |
if a <= c then l else Line p2 p1 | |
pointDiff :: Point -> Point -> Magnitude -- Figure out the difference between points | |
pointDiff (Point a b) (Point c d) = Point (a - c) (b - d) | |
crossProduct :: Point -> Point -> Float -- Basic cross product | |
crossProduct (Point a b) (Point c d) = a * d - b * c | |
calculatePoint :: Point -> Magnitude -> Float -> Point -- Given a start point, magnitude, and scale find our new point | |
calculatePoint (Point x y) (Point dx dy) s = Point (x + s * dx) (y + s * dy) | |
calculateIntersection :: NamedLine -> NamedLine -> Maybe Point | |
calculateIntersection nl1 nl2 = calculateLineIntersection (getTheLine nl1) (getTheLine nl2) | |
calculateLineIntersection :: Line -> Line -> Maybe Point -- Given two lines, return intersection point or nothing | |
calculateLineIntersection | |
l1@(Line p@(Point x1 y1) p2@(Point x2 y2)) | |
l2@(Line q@(Point x3 y3) q2@(Point x4 y4)) | |
| isZero rCrossS && isZero qMinusPCrossR = calculateCollinearOverlap l1 l2 -- Collinear, may overlap | |
| isZero rCrossS = Nothing -- Parallel | |
| inRange t && inRange u = Just $ calculatePoint p r t -- Intersect at point | |
| otherwise = Nothing -- No intersection | |
where | |
r = p2 `pointDiff` p | |
s = q2 `pointDiff` q | |
rCrossS = r `crossProduct` s | |
qMinusPCrossR = (q `pointDiff` p) `crossProduct` r | |
qMinusPCrossS = (q `pointDiff` p) `crossProduct` s | |
t = qMinusPCrossS / rCrossS | |
u = qMinusPCrossR / rCrossS | |
calculateCollinearOverlap :: Line -> Line -> Maybe Point -- Given two *collinear* lines, determine if they overlap | |
calculateCollinearOverlap | |
l1@(Line p@(Point x1 y1) (Point x2 y2)) | |
l2@(Line q@(Point x3 y3) (Point x4 y4)) | |
| x3 >= x1 && x3 <= x2 = Just q -- Start point of second line will work for us | |
| x1 >= x3 && x1 <= x4 = Just p -- Start point of first line will work for us | |
| otherwise = Nothing -- Lines don't overlap | |
isZero :: Float -> Bool -- Handle float issues by using a small margin of error | |
isZero x = x < 0.001 && x > (-0.001) | |
inRange :: Float -> Bool -- Checks if it's in range [0, 1] | |
inRange x = x >= 0 && x <= 1 | |
stringToNamedLine :: String -> NamedLine | |
stringToNamedLine s = NamedLine n $ normalizeLine $ Line (Point (read a) (read b)) (Point (read c) (read d)) | |
where | |
bits = words $ fixNoZeros s | |
n:a:b:c:d:xs = bits | |
fixNoZeros :: String -> String -- Haskell's read doesn't like the lack of leading 0s, fix it | |
fixNoZeros (' ':'.':xs) = ' ':'0':'.':(fixNoZeros xs) | |
fixNoZeros (x:xs) = x:(fixNoZeros xs) | |
fixNoZeros x = x | |
------------------ Given a list of named lines do useful things ------------------ | |
findIntersections :: NamedLine -> [NamedLine] -> [NamedIntersection] -- Find all intersections between a line and others | |
findIntersections _ [] = [] | |
findIntersections x (y:ys) | |
| isJust intersection = namedIntersection:(findIntersections x ys) | |
| otherwise = findIntersections x ys | |
where | |
intersection = x `calculateIntersection` y | |
namedIntersection = NamedIntersection (getName x) (getName y) (fromJust intersection) | |
classifyLines :: [NamedLine] -> ([NamedIntersection], [NamedLine]) -- Bootstrap into realClassifyLines | |
classifyLines lines = realClassifyLines lines [] [] [] | |
-- The list of strings is the names of lines we've seen hits in so if they come up later we don't accidentally mark them clean | |
realClassifyLines :: [NamedLine] -> [NamedIntersection] -> [NamedLine] -> [String] -> ([NamedIntersection], [NamedLine]) | |
realClassifyLines [] intersections cleanLines _ = (intersections, cleanLines) | |
realClassifyLines (line:lines) intersections cleanLines linesWithHits | |
| hits == [] && name `elem` linesWithHits = realClassifyLines lines intersections cleanLines linesWithHits | |
| hits == [] = realClassifyLines lines intersections (line:cleanLines) linesWithHits | |
| otherwise = realClassifyLines lines (hits ++ intersections) cleanLines (linesWeHit ++ linesWithHits) | |
where | |
name = getName line -- Line we're working on | |
hits = line `findIntersections` lines -- Hits between that line and the rest | |
linesWeHit = map getNameB hits -- Names of lines we hit | |
showIntersections :: [NamedIntersection] -> [String] | |
showIntersections intersections = map show (sort intersections) | |
showCleanLines :: [NamedLine] -> [String] | |
showCleanLines cleanLines = map getName (sort cleanLines) | |
------------------ Our main function, to do the work ------------------ | |
main = do | |
fileText <- readFile "input.txt" | |
let namedLines = sort $ map stringToNamedLine $ lines fileText | |
let (intersections, cleanLines) = classifyLines namedLines | |
putStrLn "Intersecting Lines:" | |
putStrLn $ unlines $ showIntersections intersections | |
putStrLn "No intersections:" | |
putStrLn $ unlines $ showCleanLines cleanLines |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment