DailyProgrammer #163 in Haskell

input.txt

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

LineIntersections.hs

-- 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