Skip to content
{{ message }}

Instantly share code, notes, and snippets.

# MBCook/LineIntersections.hs

Last active Aug 29, 2015
DailyProgrammer #163 in Haskell
 A -2.5 .5 3.5 .5 B -2.23 99.99 -2.10 -56.23 C -1.23 99.99 -1.10 -56.23 D 100.1 1000.34 2000.23 2100.23 E 1.5 -1 1.5 1.0 F 2.0 2.0 3.0 2.0 G 2.5 .5 2.5 2.0
 -- 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
to join this conversation on GitHub. Already have an account? Sign in to comment