Daily Programmer Challenge #163 [Hard] by /u/Regimardyl

import Data.Function(on)
import Data.List(nub, (\\))
import Data.Maybe(mapMaybe)
import System.Environment(getArgs)
import System.IO(readFile, putStrLn)

-- A simple line
data Line =
    NLine { gradient :: Rational, yIntercept :: Rational } -- y = gradient * x + yIntercept
    | VLine { xIntercept :: Rational } -- Vertical line: x = xIntercept
    deriving (Eq, Show)

type Point = (Rational, Rational)

-- Allows to easily read and process the given input
type NamedLine = (String, Point, Point)

-- (Line name, Line name, Comments about the intersection)
type Intersection = (String, String, String)

-- Make a line going through two points
fromPoints :: Point -> Point -> Line
fromPoints (x1,y1) (x2,y2)
    | x2 == x1  = VLine x1
    | otherwise = NLine gradient yIntercept
    where
        gradient    = (y2-y1) / (x2-x1)
        yIntercept  = y1 - x1 * gradient

-- Same for NamedLine
fromNamedLine :: NamedLine -> Line
fromNamedLine (_,p1,p2) = fromPoints p1 p2

-- Checks whether a number is between two others
inRange :: Ord a => a -> a -> a -> Bool
inRange n r1 r2 = (n>=from) && (n<=to)
    where
        (from, to) = if r1<r2 then (r1,r2) else (r2,r1)

-- Nice String representation for a Point
prettyPoint :: Point -> String
prettyPoint (x,y) = "(" ++ show (fromRational x :: Double) ++ "|" ++ show (fromRational y :: Double) ++ ")"

-- Nice String representation for an Intersection
prettyIntersect :: Intersection -> String
prettyIntersect (a,b,t) = a ++ " " ++ b ++ " " ++ t

-- x-coordinate of the point where two lines intersect, or whether they're identical
intersectLines :: Line -> Line -> Either Bool Point
intersectLines (NLine g1 y1) (NLine g2 y2) = if g1==g2
    then Left $ y1 == y2 -- Identical (True) or Paralell (False)
    else Right (xIntercept, g1*xIntercept + y1) -- Intersection point
    where
        xIntercept = (y2-y1) / (g1-g2)
intersectLines (VLine x1) (NLine g2 y2) = Right (x1, x1*g2 + y2) -- Will always intersect at x1
intersectLines l1@(NLine _ _) l2@(VLine _) = intersectLines l2 l1 -- Other way round
intersectLines (VLine x1) (VLine x2) = Left $ x1 == x2 -- Identical (True) or Paralell (False)

-- Checks whether two named Lines intercept
namedIntersect :: NamedLine -> NamedLine -> Maybe Intersection
namedIntersect nl1@(n1,p11,p12) nl2@(n2,p21,p22) =
    case intersectLines l1 l2 of
        Left False -> Nothing -- Lines don't intersect
        Left True -> if commonXRange
            then Just (n1, n2, "overlap") -- Lines overlap
            else Nothing -- Identical lines, but different ranges
        Right p -> if inXRange $ fst p
            then Just (n1, n2, "in " ++ prettyPoint p) -- Lines intersect
            else Nothing -- Lines intersect, but not in range of both lines
    where
        (l1,l2) = ((,) `on` fromNamedLine) nl1 nl2
        (x11,x12,x21,x22) = (fst p11, fst p12, fst p21, fst p22) -- Not very pretty, but in one line
        inXRange n = inRange n x11 x12 && inRange n x21 x22
        commonXRange = inRange x21 x11 x12 || inRange x22 x11 x12 -- One of the two points of the second line has to be in x range of the first line

-- Combine each element with each, excluding combining an element with itself
combineList :: [a] -> [(a,a)]
combineList [] = []
combineList (x:xs) = map (\e -> (x,e)) xs ++ combineList xs

-- Combine each named line with each
intersections :: [NamedLine] -> [Intersection]
intersections = mapMaybe pairIntersect . combineList
    where
        pairIntersect (l1,l2) = namedIntersect l1 l2

main = do
    (inputfile:_) <- getArgs
    input <- readFile inputfile
    let givenLines = map (parseLine . words) $ lines input
        intersectingLines = intersections givenLines
        nonIntersectingLines = map (\(n,_,_) -> n) givenLines \\ -- given line names
            nub (concatMap (\(a,b,_) -> [a,b]) intersectingLines) -- names of all intersecting lines
    putStrLn "Intersecting Lines:"
    mapM_ (putStrLn . prettyIntersect) intersectingLines
    putStrLn "No intersections:"
    mapM_ putStrLn nonIntersectingLines
    where
        parseLine [n,p11,p12,p21,p22] =
            (n, (readRational p11, readRational p12), (readRational p21, readRational p22))
        readRational :: String -> Rational
        readRational s@('.':_) = readRational $ '0':s
        readRational s = toRational (read s :: Double)