Add 2019 day 3 + start of a 'Geo' module

y2019/package.yaml

@@ -22,6 +22,7 @@ description:         Please see the README on GitHub at <https://github.com/mx42
 dependencies:
 - base >= 4.7 && < 5
 - split
+- containers
 
 library:
   source-dirs: src

y2019/src/Day2.hs

@@ -1,6 +1,5 @@
 module Day2
-  ( day2,
+  ( day2
-    processInput
   ) where
 
 import Data.List.Split

y2019/src/Day3.hs

@@ -0,0 +1,84 @@
+module Day3 (day3) where
+
+import           Data.List.Split
+import           Data.List
+
+import qualified Data.Map as Map
+
+import           Geo.Point
+import           Geo.Segment
+import           Geo.Vector
+
+type Coords = Map.Map Int [(Int, Int)]
+
+parseElem :: [Char] -> Vector
+parseElem ('U':count) = let n = read count in Vector n 0
+parseElem ('D':count) = let n = read count in Vector (-n) 0
+parseElem ('L':count) = let n = read count in Vector 0 (-n)
+parseElem ('R':count) = let n = read count in Vector 0 n
+parseElem _ = nilVector
+
+seg2coords :: (Coords, Coords) -> Segment -> (Coords, Coords)
+seg2coords (accH, accV) (Segment (Point x1 y1) (Point x2 y2))
+  | x1' == x2' = (accH, Map.insertWith (++) x1' [(y1', y2')] accV)
+  | y1' == y2' = ((Map.insertWith (++) y1' [(x1', x2')] accH), accV)
+  | otherwise = (accH, accV)
+  where x1' = round x1
+        x2' = round x2
+        y1' = round y1
+        y2' = round y2
+
+computeIntersections' :: Coords -> [Point] -> Int -> [(Int, Int)] -> [Point]
+computeIntersections' hcoords ps vx vys = points ++ ps
+  where hinRange = Map.filterWithKey (\hy hxs -> (any (inRange hy) vys) && (any (inRange vx) hxs)) hcoords
+        inRange p (p1, p2) = if p1 < p2 then p1 <= p && p <= p2 else p2 <= p && p <= p1
+        points = map (\hy -> Point (fromIntegral vx) (fromIntegral hy)) (Map.keys hinRange)
+
+computeIntersections :: (Coords, Coords) -> (Coords, Coords) -> [Point]
+computeIntersections (vertShape1, horizShape1) (vertShape2, horizShape2) = intersections1 ++ intersections2
+  where compute vs hs = Map.foldlWithKey (computeIntersections' hs) [] vs
+        intersections1 = compute vertShape1 horizShape2
+        intersections2 = compute horizShape1 vertShape2
+
+parseSegments :: String -> [Segment]
+parseSegments input = reverse (linkVectors (map parseElem (splitOn "," input)))
+
+getCoordsFromSegs :: [Segment] -> (Coords, Coords)
+getCoordsFromSegs segments = foldl seg2coords (Map.empty, Map.empty) segments
+
+getDistanceOnShape :: [Segment] -> Point -> Int
+getDistanceOnShape (seg@(Segment s d):xs) p
+  |p `onSegment` seg = round (manhattanDist s p)
+  |otherwise = round (manhattanDist s d) + (getDistanceOnShape xs p)
+getDistanceOnShape [] _ = 0
+
+getIntersectionDist :: [Segment] -> [Segment] -> Point -> Int
+getIntersectionDist s1 s2 p = getDistanceOnShape s1 p + getDistanceOnShape s2 p
+
+day3 :: IO ()
+day3 = do
+  putStrLn "AoC 2019 day 3"
+  putStr "Enter input >"
+
+  firstInput <- getLine
+  secondInput <- getLine
+  putStrLn ""
+
+  let firstShape = parseSegments firstInput
+  let firstCoords = getCoordsFromSegs firstShape
+  let secondShape = parseSegments secondInput
+  let secondCoords = getCoordsFromSegs secondShape
+
+  let intersections = computeIntersections firstCoords secondCoords
+
+  let part1 = manhattanDist origin (head (sortOn (manhattanDist origin) intersections))
+  putStr "Part1: "
+  print part1
+  putStrLn ""
+
+  let intersectionDists = map (getIntersectionDist firstShape secondShape) intersections
+  let part2 = minimum intersectionDists
+
+  putStr "Part2: "
+  print part2
+  putStrLn ""

y2019/src/DayPicker.hs

@@ -7,11 +7,14 @@ import System.Environment
 
 import Day1
 import Day2
+import Day3
 
+-- TODO Better way?
 load :: [String] -> IO ()
 load [] = putStrLn "Usage: script [day]"
 load ("1":_) = day1
 load ("2":_) = day2
+load ("3":_) = day3
 load _ = putStrLn "Unavailable date"
 
 dayPicker :: IO ()

y2019/src/Geo/Point.hs

@@ -0,0 +1,24 @@
+module Geo.Point
+  ( Point(..),
+    origin,
+    manhattanDist,
+    add,
+    sub
+  ) where
+
+data Point = Point { x :: Float, y :: Float } deriving (Show)
+
+instance Eq Point where
+  (==) (Point x1 y1) (Point x2 y2) = x1 == x2 && y1 == y2
+
+origin :: Point
+origin = Point 0 0
+
+manhattanDist :: Point -> Point -> Float
+manhattanDist a b = abs(x(b) - x(a)) + abs(y(b) - y(a))
+
+add :: Point -> Point -> Point
+add (Point xa ya) (Point xb yb) = Point (xa + xb) (ya + yb)
+
+sub :: Point -> Point -> Point
+sub (Point xa ya) (Point xb yb) = Point (xa - xb) (ya - yb)

y2019/src/Geo/Segment.hs

@@ -0,0 +1,52 @@
+module Geo.Segment
+  ( Segment(..),
+    directionalVect,
+    segmentIntersection,
+    linkVectors,
+    linkPoints,
+    onSegment
+  ) where
+
+import Geo.Point
+import Geo.Vector
+
+data Segment = Segment { src :: Point, dst :: Point } deriving (Show)
+
+directionalVect :: Segment -> Vector
+directionalVect (Segment s d) = directionalVectorFromPoint (d `sub` s)
+
+onSegment :: Point -> Segment -> Bool
+onSegment p@(Point px py) (Segment s@(Point sx sy) d@(Point dx dy))
+  | p == d = True
+  | p == s = True
+  | sx == dx && sx == px && (between py sy dy) = True
+  | sy == dy && sy == py && (between px sx dx) = True
+  | otherwise = False
+  where between p' s' d' = if s' < d' then p' >= s' && p' <= d' else p' >= d' && p' <= s'
+
+segmentIntersection :: Segment -> Segment -> Maybe Point
+segmentIntersection s1 s2 =
+  if t1 < 0 || t1 > 1 || t2 < 0 || t2 > 1
+  then Nothing
+  else Just (directionalVectorToPoint (Vector t1 t2) (src(s1)))
+  where dirS1 = directionalVect s1
+        dirS2 = directionalVect s2
+        determinant = determinantVector dirS1 dirS2
+        dirX = directionalVectorFromPoint (src(s2) `sub` src(s1))
+        t1 = (determinantVector dirX dirS2) / determinant
+        t2 = (determinantVector dirX dirS1) / determinant
+
+linkPoints :: [Point] -> [Segment]
+linkPoints pts = foldl addPointToSegments [] pts
+
+linkVectors :: [Vector] -> [Segment]
+linkVectors vectors = linkPoints (reverse points)
+  where points = foldl linkVectors' [] vectors
+
+linkVectors' :: [Point] -> Vector -> [Point]
+linkVectors' [] v = [addV2P origin v]
+linkVectors' xs@(p:_) v = (addV2P p v):xs
+
+addPointToSegments :: [Segment] -> Point -> [Segment]
+addPointToSegments [] pt = [Segment origin pt]
+addPointToSegments xs@(h:_) pt = (Segment (dst(h)) pt):xs

y2019/src/Geo/Vector.hs

@@ -0,0 +1,28 @@
+module Geo.Vector
+  ( Vector(..),
+    determinantVector,
+    directionalVectorFromPoint,
+    directionalVectorToPoint,
+    nilVector,
+    addV2P
+  ) where
+
+import Geo.Point
+
+data Vector = Vector { x :: Float, y :: Float } deriving (Show)
+
+addV2P :: Point -> Vector -> Point
+addV2P (Point xp yp) (Vector xv yv) = Point (xp + xv) (yp + yv)
+
+nilVector :: Vector
+nilVector = Vector 0 0
+
+directionalVectorFromPoint :: Point -> Vector
+directionalVectorFromPoint (Point px py) = Vector (px / len) (py / len)
+  where len = sqrt(px * px + py * py)
+
+determinantVector :: Vector -> Vector -> Float
+determinantVector (Vector x1 y1) (Vector x2 y2) = (x1 * y2) - (y1 * x2)
+
+directionalVectorToPoint :: Vector -> Point -> Point
+directionalVectorToPoint (Vector vx vy) (Point px py) = Point (vx * px) (vy * py)