Create a gist now

Instantly share code, notes, and snippets.

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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment