/LineIntersections.hs
Last active Aug 29, 2015
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