Merge AoC 2019 & 2020 Haskell codebases

haskellAoC/src/Geo/Point.hs

@@ -0,0 +1,24 @@
+module Geo.Point
+  ( Point(..),
+    origin,
+    manhattanDist,
+    add,
+    sub
+  ) where
+
+data Point = Point { x :: Double, y :: Double } deriving (Show, Eq)
+
+-- instance Eq Point where
+--   (==) (Point x1 y1) (Point x2 y2) = x1 == x2 && y1 == y2
+
+origin :: Point
+origin = Point 0 0
+
+manhattanDist :: Point -> Point -> Double
+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)

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

haskellAoC/src/Geo/Vector.hs

@@ -0,0 +1,43 @@
+module Geo.Vector
+  ( Vector(..),
+    determinantVector,
+    directionalVectorFromPoint,
+    directionalVectorToPoint,
+    nilVector,
+    addV2P,
+    roundVecAtN,
+    roundN,
+    vec2angle
+  ) where
+
+import Geo.Point
+
+data Vector = Vector { x :: Double, y :: Double } deriving (Show, Eq)
+
+addV2P :: Point -> Vector -> Point
+addV2P (Point xp yp) (Vector xv yv) = Point (xp + xv) (yp + yv)
+
+nilVector :: Vector
+nilVector = Vector 0 0
+
+roundVecAtN :: Int -> Vector -> Vector
+roundVecAtN prec (Vector vx vy) = Vector (roundN prec vx) (roundN prec vy)
+
+-- https://stackoverflow.com/questions/12450501/round-number-to-specified-number-of-digits
+roundN :: Int -> Double -> Double
+roundN prec val = (fromInteger $ round $ val * (10 ^ prec)) / (10.0 ^^ prec)
+
+directionalVectorFromPoint :: Point -> Vector
+directionalVectorFromPoint (Point px py) = Vector (px / len) (py / len)
+  where len = sqrt(px * px + py * py)
+
+determinantVector :: Vector -> Vector -> Double
+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)
+
+vec2angle :: Vector -> Double
+vec2angle (Vector vx vy) = roundN 5 angle'
+ where angle = atan2 vx vy
+       angle' = pi - angle

haskellAoC/src/Lib.hs

@@ -0,0 +1,58 @@
+module Lib (pickYear) where
+
+import Y2019.Days
+import Y2020.Days
+
+import Data.List
+
+import System.Directory
+import System.Environment
+
+type DayFun = [String] -> (String, String)
+
+getDayFun :: String -> String -> DayFun
+getDayFun "2019" "01" = y19day01
+getDayFun "2019" "02" = y19day02
+getDayFun "2019" "03" = y19day03
+getDayFun "2019" "04" = y19day04
+getDayFun "2019" "05" = y19day05
+getDayFun "2019" "06" = y19day06
+getDayFun "2019" "07" = y19day07
+getDayFun "2019" "08" = y19day08
+getDayFun "2019" "09" = y19day09
+getDayFun "2019" "10" = y19day10
+getDayFun "2019" "11" = y19day11
+getDayFun "2019" "12" = y19day12
+getDayFun "2019" "13" = y19day13
+getDayFun "2020" "01" = y20day01
+getDayFun "2020" "02" = y20day02
+getDayFun "2020" "03" = y20day03
+
+callDailyFun :: String -> DayFun -> String -> IO ()
+callDailyFun year fn name = do
+  putStrLn $ "With input " ++ name
+  input <- readFile ("inputs/" ++ year ++ "/" ++ name)
+  let (part1, part2) = fn $ lines input
+  putStrLn $ "Part1: " ++ part1
+  putStrLn $ "Part2: " ++ part2
+
+getFiles :: String -> String -> IO [String]
+getFiles year day = listDirectory ("inputs/" ++ year ++ "/") >>=
+                    return . filter (isPrefixOf day)
+
+dayPicker :: String -> String -> IO ()
+dayPicker year day = do
+  let dailyFun = getDayFun year day
+  files       <- getFiles year day
+  _           <- mapM (callDailyFun year dailyFun) files
+  putStrLn     $ "Ending process"
+
+
+load :: [String] -> IO ()
+load (year:day:_) = dayPicker year day
+load _ = putStrLn "Usage: script [year] [day]"
+
+pickYear :: IO ()
+pickYear = do
+  args <- getArgs
+  load args

haskellAoC/src/Y2019/Day01.hs

@@ -0,0 +1,17 @@
+module Y2019.Day01 (day1) where
+
+massFuelReq :: Integer -> Integer
+massFuelReq mass = (floor (fromIntegral mass / 3)) - 2
+
+moduleFuelReq :: Integer -> Integer
+moduleFuelReq mass
+  | req > 0 =  req + moduleFuelReq req
+  | req <= 0 = 0
+  where req = massFuelReq mass
+
+day1 :: [String] -> (String, String)
+day1 input = (part1, part2)
+  where
+    modules = (map read input)
+    part1 = show $ sum $ map massFuelReq modules
+    part2 = show $ sum $ map moduleFuelReq modules

haskellAoC/src/Y2019/Day02.hs

@@ -0,0 +1,27 @@
+module Y2019.Day02 (day2) where
+
+import Y2019.Intcode
+
+replaceNth :: Int -> a -> [a] -> [a]
+replaceNth _ _ [] = []
+replaceNth n newVal (x:xs)
+  | n == 0 = newVal:xs
+  | otherwise = x:replaceNth (n-1) newVal xs
+
+computeVerbNoun :: Int -> Int -> [Int] -> Int
+computeVerbNoun noun verb input = (runProgramV1 newInput) !! 0
+  where newInput = replaceNth 1 noun . replaceNth 2 verb $ input
+
+bruteforce :: Int -> Int -> [Int] -> Int -> Int
+bruteforce noun verb input objective
+  | result == objective = noun * 100 + verb
+  | verb == 99 = bruteforce (noun + 1) 0 input objective
+  | noun < 100 = bruteforce noun (verb + 1) input objective
+  where result = computeVerbNoun noun verb input
+
+day2 :: [String] -> (String, String)
+day2 (input:_) = (part1, part2)
+  where intCodes = parseProgram input
+        part1 = show $ computeVerbNoun 12 2 intCodes
+        objective = 19690720
+        part2 = show $ bruteforce 0 0 intCodes objective

haskellAoC/src/Y2019/Day03.hs

@@ -0,0 +1,67 @@
+module Y2019.Day03 (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 :: [String] -> (String, String)
+day3 (firstInput:secondInput:_) = (part1, part2)
+  where firstShape = parseSegments firstInput
+        firstCoords = getCoordsFromSegs firstShape
+        secondShape = parseSegments secondInput
+        secondCoords = getCoordsFromSegs secondShape
+        intersections = computeIntersections firstCoords secondCoords
+        part1 = show $ manhattanDist origin (head (sortOn (manhattanDist origin) intersections))
+        intersectionDists = map (getIntersectionDist firstShape secondShape) intersections
+        part2 = show $ minimum intersectionDists

haskellAoC/src/Y2019/Day04.hs

@@ -0,0 +1,24 @@
+module Y2019.Day04 (day4) where
+
+import Data.List.Split
+import Data.List
+
+isValid :: (Int -> Bool) -> Int -> Bool
+isValid groupsCriteria n = length6 && isSorted && hasGroups
+  where digits = show n
+        length6 = (length digits) == 6
+        isSorted = digits == sort digits
+        hasGroups = any (\d -> groupsCriteria (length d)) (group digits)
+
+getNext :: (Int -> Bool) -> Int -> Int
+getNext groupsCriteria cur
+  | isValid groupsCriteria (cur + 1) = (cur + 1)
+  | otherwise = getNext groupsCriteria (cur + 1)
+
+day4 :: [String] -> (String, String)
+day4 (input:_) = (part1, part2)
+  where range = (map read (splitOn "-" input)) :: [Int]
+        iterP1 = takeWhile (< (range !! 1)) (iterate (getNext (> 1)) (range !! 0))
+        part1 = show ((length iterP1) - 1)
+        iterP2 = takeWhile (< (range !! 1)) (iterate (getNext (== 2)) (range !! 0))
+        part2 = show ((length iterP2) - 1)

haskellAoC/src/Y2019/Day05.hs

@@ -0,0 +1,11 @@
+module Y2019.Day05 (day5) where
+
+import Y2019.Intcode
+
+day5 :: [String] -> (String, String)
+day5 (input:_) = (part1, part2)
+  where intCodes = parseProgram input
+        outputP1 = runProgramV2 [1] intCodes
+        part1 = show $ outputP1 !! 0
+        outputP2 = runProgramV2 [5] intCodes
+        part2 = show $ outputP2 !! 0

haskellAoC/src/Y2019/Day06.hs

@@ -0,0 +1,41 @@
+module Y2019.Day06 (day6) where
+
+import           Data.Maybe
+import qualified Data.Map as Map
+import           Data.List.Split
+import qualified Data.Set as Set
+
+-- https://stackoverflow.com/questions/22403029/how-to-zip-lists-with-different-length
+zipWithPadding :: a -> b -> [a] -> [b] -> [(a,b)]
+zipWithPadding a b (x:xs) (y:ys) = (x,y) : zipWithPadding a b xs ys
+zipWithPadding a _ []     ys     = zip (repeat a) ys
+zipWithPadding _ b xs     []     = zip xs (repeat b)
+
+orbitLength :: Map.Map String String -> String -> Int
+orbitLength orbits object
+  | isJust orbitOn = 1 + (orbitLength orbits (head (maybeToList orbitOn)))
+  | isNothing orbitOn = 0
+  where orbitOn = object `Map.lookup` orbits
+
+getOrbits :: Map.Map String String -> String -> [String]
+getOrbits orbits object
+  | isJust orbitOn = object:(getOrbits orbits (head (maybeToList orbitOn)))
+  | isNothing orbitOn = object:[]
+  where orbitOn = object `Map.lookup` orbits
+
+countTuples :: [(String, String)] -> Int
+countTuples (("", _):xs) = 1 + countTuples xs
+countTuples ((_, ""):xs) = 1 + countTuples xs
+countTuples ((_, _):xs) = 2 + countTuples xs
+countTuples [] = 0
+
+day6 :: [String] -> (String, String)
+day6 input = (part1, part2)
+  where orbitsMap = Map.fromList (map (\r -> (r !! 1, r !! 0)) (map (splitOn ")") input))
+        orbitingObjects = Map.keysSet orbitsMap
+        nbOrbitsPerObject = map (orbitLength orbitsMap) (Set.toList orbitingObjects)
+        part1 = show $ sum nbOrbitsPerObject
+        myOrbits = reverse $ tail $ getOrbits orbitsMap "YOU"
+        santaOrbits = reverse $ tail $ getOrbits orbitsMap "SAN"
+        elems = dropWhile (\(a, b) -> a == b) (zipWithPadding [] [] myOrbits santaOrbits)
+        part2 = show $ countTuples elems

haskellAoC/src/Y2019/Day07.hs

@@ -0,0 +1,35 @@
+module Y2019.Day07 (day7) where
+
+import Data.List
+import Y2019.Intcode
+
+processProgram :: [Int] -> [Int] -> Int
+processProgram program inputs = head outputs
+  where outputs = runProgramV2 inputs program
+
+-- Memory -> phase (1st input) -> 2nd input -> outputs
+chainProcesses :: [Int] -> [Int] -> Int -> Int
+chainProcesses program (phase:nextPhases) signal
+  | (null nextPhases) = newSignal
+  | otherwise = chainProcesses program nextPhases newSignal
+  where newSignal = processProgram program [phase, signal]
+
+testCombinationsP1 :: [Int] -> [([Int], Int)]
+testCombinationsP1 program = map (\p -> (p, chainProcesses program p 0)) phasesPerm
+  where phasesPerm = permutations [0..4]
+
+testCombinationsP2 :: [Int] -> [([Int], Int)]
+testCombinationsP2 program = map (\p -> (p, runProgramV3 program p)) phasesPerm
+  where phasesPerm = permutations [5..9]
+
+day7 :: [String] -> (String, String)
+day7 (input:_) = (part1, part2)
+  where program = parseProgram input
+        combinationsP1 = testCombinationsP1 program
+        part1 = show $ maximumBy (\(_, a) (_, b) -> compare a b) combinationsP1
+        part2 = ""
+  -- WIP
+  -- let combinationsP2 = testCombinationsP2 program
+  -- let p2 = maximumBy (\(_, a) (_, b) -> compare a b) combinationsP2
+
+  -- putStrLn $ "Part 2 (WIP/Buggy): " ++ (show p2)

haskellAoC/src/Y2019/Day08.hs

@@ -0,0 +1,37 @@
+module Y2019.Day08 (day8) where
+
+import Data.List.Split
+import Data.List
+
+width :: Int
+width = 25
+
+height :: Int
+height = 6
+
+buildLayers :: String -> Int -> Int -> [[Char]]
+buildLayers "" _ _ = []
+buildLayers input w h = front:(buildLayers back w h)
+  where (front, back) = splitAt (w * h) input
+
+decodeLayers :: [String] -> String
+decodeLayers layers = foldl decodeLayers' (replicate (width * height) '2') layers
+  where decodeLayers' acc layer = map (\(a, l) -> if a == '2' then l else a) (zip acc layer)
+
+day8 :: [String] -> (String, String)
+day8 (input:_) = (part1, part2)
+  where layers = buildLayers input width height
+        countDigit d = length . (filter (== d))
+        min0layer = minimumBy (\ a b -> (countDigit '0' a) `compare` (countDigit '0' b)) layers
+        p1nbOf1 = countDigit '1' min0layer
+        p1nbOf2 = countDigit '2' min0layer
+
+        part1 = show $ p1nbOf1 * p1nbOf2
+
+        decoded = unlines (chunksOf width (decodeLayers layers))
+
+        repl '0' = ' '
+        repl '1' = '#'
+        repl c   = c
+
+        part2 = map repl decoded

haskellAoC/src/Y2019/Day09.hs

@@ -0,0 +1,9 @@
+module Y2019.Day09 (day9) where
+
+import Y2019.Intcode
+
+day9 :: [String] -> (String, String)
+day9 (input:_) = (part1, part2)
+  where memory = parseProgram input
+        part1 = show $ runProgramV2 [1] memory
+        part2 = show $ runProgramV2 [2] memory

haskellAoC/src/Y2019/Day10.hs

@@ -0,0 +1,55 @@
+module Y2019.Day10 (day10) where
+
+import Data.List
+import Geo.Vector
+import Geo.Point
+
+parseLine :: Int -> [Char] -> [Int]
+parseLine xp ('#':cs) = xp:(parseLine (xp + 1) cs)
+parseLine xp (_:cs) = parseLine (xp + 1) cs
+parseLine _ [] = []
+
+parseInput :: Int -> [String] -> [Point]
+parseInput yp (l:ls) = (map convertToPoint $ parseLine 0 l) ++ parseInput (yp + 1) ls
+  where convertToPoint xp = Point (fromIntegral xp) (fromIntegral yp)
+parseInput _ [] = []
+
+getDirVectors :: Point -> [Point] -> [Vector]
+getDirVectors src (dest:dests) = computedVect:(getDirVectors src dests)
+  where computedVect = roundVecAtN 5 $ directionalVectorFromPoint (dest `sub` src)
+getDirVectors _ [] = []
+
+getVectorAndDistPerPoint :: [Point] -> Point -> [(Point, Double, Double)]
+getVectorAndDistPerPoint (dest:dests) src = (dest, computedVect, distance):nextEntries
+  where computedVect = vec2angle $ directionalVectorFromPoint diffPt
+        distance = roundN 5 $ sqrt $ ((Geo.Point.x diffPt) ^ 2) + ((Geo.Point.y diffPt) ^ 2)
+        diffPt = dest `sub` src
+        nextEntries = getVectorAndDistPerPoint dests src
+getVectorAndDistPerPoint [] _ = []
+
+asteroidSorting :: (Point, Double, Double) -> (Point, Double, Double) -> Ordering
+asteroidSorting (_, angle1, dist1) (_, angle2, dist2)
+  | angle1 > angle2 = GT
+  | angle1 < angle2 = LT
+  | dist1 > dist2 = GT
+  | dist1 < dist2 = LT
+  | otherwise = EQ
+
+getLaserOrder :: [[Point]] -> [Point]
+getLaserOrder ((p:[]):xs) = p:(getLaserOrder xs)
+getLaserOrder ((p:ps):xs) = p:(getLaserOrder (xs ++ [ps]))
+getLaserOrder [] = []
+
+day10 :: [String] -> (String, String)
+day10 input = (part1, part2)
+  where asteroids = parseInput 0 input
+        p1 = maximumBy (\(_, a) (_, b) -> compare a b) $ map countFn asteroids
+        countFn pt = (pt, (length $ nub $ getDirVectors pt asteroids) - 1)
+        p2 = getLaserOrder $
+          map (\m -> map (\(p, _, _) -> p) m) $
+          groupBy (\(_, v1, _) (_, v2, _) -> v1 == v2) $
+          sortBy asteroidSorting $
+          getVectorAndDistPerPoint asteroids $
+          fst p1
+        part1 = show $ p1
+        part2 = show $ p2 !! 200

haskellAoC/src/Y2019/Day11.hs

@@ -0,0 +1,33 @@
+module Y2019.Day11 (day11) where
+
+import qualified Data.Map as M
+import Data.List
+import Y2019.Intcode
+
+getCoords :: ([Int] -> Int) -> [((Int, Int), Int)] -> (Int, Int)
+getCoords fn (((x, y),_):xs) = getCoords' x y xs
+  where getCoords' ax ay (((bx, by), _):xs') = getCoords' (fn [ax, bx]) (fn [ay, by]) xs'
+        getCoords' ax ay [] = (ax, ay)
+
+drawLine :: Int -> (Int, Int) -> Int -> M.Map (Int, Int) Int -> String
+drawLine curY (minX, maxX) curX paint
+  | curX == maxX = [color, '\n']
+  | otherwise = [color] ++ drawLine curY (minX, maxX) (curX + 1) paint
+  where color = if (M.findWithDefault 0 (curX, curY) paint) == 0 then '.' else '#'
+
+draw :: M.Map (Int, Int) Int -> String
+draw painting = draw' minCoords maxCoords (snd minCoords)
+  where minCoords = getCoords minimum $ M.toList painting
+        maxCoords = getCoords maximum $ M.toList painting
+        draw' (minX, _) (maxX, maxY) curY
+          | curY == maxY = drawLine curY (minX, maxX) minX painting
+          | otherwise = (drawLine curY (minX, maxX) minX painting) ++
+                        (draw' minCoords maxCoords (curY + 1))
+
+day11 :: [String] -> (String, String)
+day11 (input:_) = (part1, part2)
+  where memory = parseProgram input
+        painting = runProgramPaint memory 0
+        registration = runProgramPaint memory 1
+        part1 = show $ length $ painting
+        part2 = draw registration

haskellAoC/src/Y2019/Day12.hs

@@ -0,0 +1,57 @@
+module Y2019.Day12 (day12) where
+
+import Data.List
+import Data.List.Split
+
+data V = V { _x :: Int, _y :: Int, _z :: Int } deriving (Eq, Show)
+
+nullV :: V
+nullV = V 0 0 0
+
+data Moon = Moon { _pos :: V, _vel :: V } deriving (Eq, Show)
+
+parseLine :: String -> Moon
+parseLine input = Moon (V (getNb 0) (getNb 1) (getNb 2)) nullV
+  where input' = filter (\c -> not $ elem c "<>,") input
+        parts = splitOn " " input'
+        getNb x = read $ (!! 1) $ splitOn "=" $ (parts !! x)
+
+computeVelocity :: V -> [Moon] -> V
+computeVelocity pos@(V x y z) ((Moon (V ox oy oz) _):others) = V (curX + nextX) (curY + nextY) (curZ + nextZ)
+  where (V nextX nextY nextZ) = computeVelocity pos others
+        curX = veloChange x ox
+        curY = veloChange y oy
+        curZ = veloChange z oz
+        veloChange a b = if a > b
+                         then -1
+                         else if a < b
+                              then 1
+                              else 0
+computeVelocity _ [] = nullV
+
+applyVelocity :: [Moon] -> Moon -> Moon
+applyVelocity others cur@(Moon curPos@(V px py pz) (V vx vy vz)) = Moon newPos newVel
+  where (V nvx nvy nvz) = computeVelocity curPos others'
+        others' = filter (/= cur) others
+        newVel = V (vx + nvx) (vy + nvy) (vz + nvz)
+        newPos = V (px + vx + nvx)  (py + vy + nvy)  (pz + vz + nvz)
+
+computeStep :: [Moon] -> [Moon]
+computeStep moons = map (applyVelocity moons) moons
+
+moonEnergy :: Moon -> Int
+moonEnergy (Moon (V px py pz) (V vx vy vz)) = potentialEnergy * kineticEnergy
+  where potentialEnergy = (abs px) + (abs py) + (abs pz)
+        kineticEnergy = (abs vx) + (abs vy) + (abs vz)
+
+day12 :: [String] -> (String, String)
+day12 input = (part1, part2)
+  where planets = map parseLine $ filter (not . null) input
+        iteration = iterate computeStep planets
+
+        at1000 = iteration !! 1000
+        part1 = show $ sum $ map moonEnergy $ at1000
+
+        -- ok, inefficient, need something better
+        idx = elemIndex planets $ tail iteration
+        part2 = show $ fmap (+1) idx

haskellAoC/src/Y2019/Day13.hs

@@ -0,0 +1,19 @@
+module Y2019.Day13 (day13) where
+
+import Y2019.Intcode
+
+parseOutput :: [Int] -> [(Int, Int, Int)]
+parseOutput (x:(y:(t:xs))) = (x, y, t):(parseOutput xs)
+parseOutput _ = []
+
+day13 :: [String] -> (String, String)
+day13 (input:_) = (part1, part2)
+  where memory = parseProgram input
+        outputP1 = parseOutput $ runProgramV2 [] memory
+        part1 = show $ length $ filter (\(_,_,t) -> t == 2) outputP1
+        part2 = "WIP"
+
+  -- let hackedMemory = 2:xs
+  --      where (_:xs) = memory
+
+  -- let outputP2 = parseOutput $ runProgramV2 [] hackedMemory

haskellAoC/src/Y2019/Days.hs

@@ -0,0 +1,32 @@
+module Y2019.Days (y19day01, y19day02, y19day03, y19day04, y19day05, y19day06,
+                   y19day07, y19day08, y19day09, y19day10, y19day11, y19day12,
+                   y19day13
+                  ) where
+
+import Y2019.Day01
+import Y2019.Day02
+import Y2019.Day03
+import Y2019.Day04
+import Y2019.Day05
+import Y2019.Day06
+import Y2019.Day07
+import Y2019.Day08
+import Y2019.Day09
+import Y2019.Day10
+import Y2019.Day11
+import Y2019.Day12
+import Y2019.Day13
+
+y19day01 = day1
+y19day02 = day2
+y19day03 = day3
+y19day04 = day4
+y19day05 = day5
+y19day06 = day6
+y19day07 = day7
+y19day08 = day8
+y19day09 = day9
+y19day10 = day10
+y19day11 = day11
+y19day12 = day12
+y19day13 = day13

haskellAoC/src/Y2019/Intcode.hs

@@ -0,0 +1,222 @@
+module Y2019.Intcode (parseProgram, runProgramV1, runProgramV2, runProgramV3, runProgramPaint) where
+
+import Data.Map
+import Data.List.Split
+import Data.Char
+
+-- import Debug.Trace
+-- trace _ x = x
+
+trace' _ x = x
+
+data ParamMode = Position | Direct | Relative deriving (Show)
+
+data OpCode = OpAdd | OpMult | OpRead | OpWrite | OpJumpEq | OpJumpNeq | OpLT | OpEq | OpOffset | OpExit deriving (Eq, Show)
+
+data State = State { _index :: Int,
+                     _relIndex :: Int,
+                     _input :: [Int],
+                     _output :: [Int],
+                     _memory :: Map Int Int,
+                     _running :: Bool } deriving (Show)
+
+data Instr = Instr { _opcode :: OpCode,
+                     _p1 :: (ParamMode, Int),
+                     _p2 :: (ParamMode, Int),
+                     _p3 :: (ParamMode, Int)
+                   }
+
+-- computeOpCode: Take an INT and returns a tuple4:
+-- - Int = opcode
+-- - Subsequent ints = Mode of nth param (0 = pos, 1 = direct, 2 = relative)
+computeOpCode :: Int -> (OpCode, ParamMode, ParamMode, ParamMode)
+computeOpCode input = result -- trace ("Compute opcode " ++ show input ++ " -> " ++ show result) result
+  where opcode = convertOpCode $ input `mod` 100
+        digits = show input
+        len = length digits
+        mode1 = convertToPM $ if len > 2 then (ord $ digits !! (len - 3)) - 48 else 0
+        mode2 = convertToPM $ if len > 3 then (ord $ digits !! (len - 4)) - 48 else 0
+        mode3 = convertToPM $ if len > 4 then (ord $ digits !! (len - 5)) - 48 else 0
+        result = (opcode, mode1, mode2, mode3)
+        convertToPM 0 = Position
+        convertToPM 1 = Direct
+        convertToPM 2 = Relative
+        convertOpCode 1 = OpAdd
+        convertOpCode 2 = OpMult
+        convertOpCode 3 = OpRead
+        convertOpCode 4 = OpWrite
+        convertOpCode 5 = OpJumpEq
+        convertOpCode 6 = OpJumpNeq
+        convertOpCode 7 = OpLT
+        convertOpCode 8 = OpEq
+        convertOpCode 9 = OpOffset
+        convertOpCode 99 = OpExit
+
+getInstruction :: State -> Instr
+getInstruction s = Instr opcode param1 param2 param3
+  where (opcode, m1, m2, m3) = computeOpCode $ getMemoryAt 0
+        param1 = (m1, getMemoryAt 1)
+        param2 = (m2, getMemoryAt 2)
+        param3 = (m3, getMemoryAt 3)
+        getMemoryAt n = (_memory s) ! (n + _index s)
+
+getWriteAddress :: State -> (ParamMode, Int) -> Int
+getWriteAddress _ (Position, n) = n
+getWriteAddress _ (Direct, n) = n
+getWriteAddress s (Relative, n) = (n + _relIndex s)
+
+getValue :: State -> (ParamMode, Int) -> Int
+getValue s (Position, n) = findWithDefault 0 n (_memory s)
+getValue _ (Direct, n) = n
+getValue s (Relative, n) = findWithDefault 0 (n + _relIndex s) (_memory s)
+
+compute :: State -> Instr -> State
+-- OPCODE 1 - ADDITION
+compute s (Instr OpAdd p1 p2 p3) = dbg s { _index = newIndex, _memory = newMemory }
+  where newIndex = (_index s) + 4
+        newMemory = insert resultIndex result (_memory s)
+        resultIndex = getWriteAddress s p3
+        value1 = getValue s p1
+        value2 = getValue s p2
+        result = value1 + value2
+        dbg x = trace' ("ADD\t\t"++ show p1 ++ " [" ++ show value1 ++ "] + "++ show p2 ++" [" ++ show value2 ++ "] =\t[" ++ show result ++ "]\t-> @ [" ++ show resultIndex ++ "] " ++ show p3) x
+-- OPCODE 2 - MULTIPLICATION
+compute s (Instr OpMult p1 p2 p3) = dbg s { _index = newIndex, _memory = newMemory }
+  where newIndex = (_index s) + 4
+        newMemory = insert resultIndex result (_memory s)
+        resultIndex = getWriteAddress s p3
+        value1 = getValue s p1
+        value2 = getValue s p2
+        result = value1 * value2
+        dbg x = trace' ("MULT\t\t" ++ show p1 ++ " [" ++ show value1 ++ "] * "++ show p2++" [" ++ show value2 ++ "] =\t[" ++ show result ++ "]\t-> @ [" ++ show resultIndex ++ "] "++ show p3) x
+-- OPCODE 3 - READ
+compute s (Instr OpRead p1 _ _) = dbg s { _index = newIndex, _memory = newMemory, _input = newInput }
+  where newIndex = (_index s) + 2
+        newMemory = insert resultIndex value (_memory s)
+        resultIndex = getWriteAddress s p1
+        value = head $ _input s
+        newInput = tail $ _input s
+        dbg x = trace' ("READ\t\t[" ++ show value ++ "]\t-> @ [" ++ show resultIndex ++ "] " ++ show p1) x
+-- OPCODE 4 - OUTPUT
+compute s (Instr OpWrite p1 _ _) = dbg s { _index = newIndex, _output = newOutput }
+  where newIndex = (_index s) + 2
+        newOutput = (_output s) ++ [value]
+        value = getValue s p1
+        dbg x = trace' ("OUTPUT\t\t" ++ show p1 ++ " [" ++ show value ++ "]") x
+-- OPCODE 5 - JUMP-IF-TRUE
+compute s (Instr OpJumpEq p1 p2 _) = dbg s { _index = newIndex }
+  where value = getValue s p1
+        jumpTo = getValue s p2
+        newIndex = if value /= 0 then jumpTo else (_index s) + 3
+        dbg x = trace' ("JUMP-IF-TRUE\t" ++ show p1 ++ " [" ++ show value ++ "] JMP TO " ++ show p2 ++ " [" ++ show jumpTo ++ "]\t-> INDEX " ++ show newIndex) x
+-- OPCODE 6 - JUMP-IF-FALSE
+compute s (Instr OpJumpNeq p1 p2 _) = dbg s { _index = newIndex }
+  where value = getValue s p1
+        jumpTo = getValue s p2
+        newIndex = if value == 0 then jumpTo else (_index s) + 3
+        dbg x = trace' ("JUMP-IF-FALSE\t" ++ show p1 ++ " [" ++ show value ++ "] JMP TO " ++ show p2 ++ " [" ++ show jumpTo ++ "]\t-> INDEX " ++ show newIndex) x
+-- OPCODE 7 - LESS-THAN
+compute s (Instr OpLT p1 p2 p3) = dbg s { _index = newIndex, _memory = newMemory }
+  where newIndex = (_index s) + 4
+        value1 = getValue s p1
+        value2 = getValue s p2
+        resultIndex = getWriteAddress s p3
+        result = if value1 < value2 then 1 else 0
+        newMemory = insert resultIndex result (_memory s)
+        dbg x = trace' ("LESS-THAN\t" ++ show p1 ++ " [" ++ show value1 ++ "] vs " ++ show p2 ++ " [" ++ show value2 ++ "] =\t[" ++ show result ++ "]\t-> @ [" ++ show resultIndex ++ "] "++ show p3) x
+-- OPCODE 8 - EQUALS
+compute s (Instr OpEq p1 p2 p3) = dbg s { _index = newIndex, _memory = newMemory }
+  where newIndex = (_index s) + 4
+        value1 = getValue s p1
+        value2 = getValue s p2
+        result = if value1 == value2 then 1 else 0
+        resultIndex = getWriteAddress s p3
+        newMemory = insert resultIndex result (_memory s)
+        dbg x = trace' ("EQUALS\t\t" ++ show p1 ++ " [" ++ show value1 ++ "] vs " ++ show p2 ++ " [" ++ show value2 ++ "] =\t[" ++ show result ++ "]\t-> @ [" ++ show resultIndex ++ "] "++ show p3) x
+-- OPCODE 9 - REL-OFFSET
+compute s (Instr OpOffset p1 _ _) = dbg s { _index = newIndex, _relIndex = newRelIndex }
+  where value = getValue s p1
+        newIndex = (_index s) + 2
+        relIndex = _relIndex s
+        newRelIndex = value + relIndex
+        dbg x = trace' ("REL-OFFSET\t" ++ show p1 ++ " [" ++ show value ++ "] + CUR [" ++ show relIndex ++ "] =\t[" ++ show newRelIndex ++ "]") x
+-- OPCODE 99 - EXIT
+compute s (Instr OpExit _ _ _) = dbg s { _running = False }
+  where dbg x = trace' ("EXIT") x
+
+-- ELSE: NOT HANDLED
+-- compute s (Instr n _ _ _) = trace ("Unhandled opcode " ++ show n) s { _running = False }
+
+runProgram :: State -> State
+runProgram s
+  | _running(s) == True = let instr = getInstruction s in runProgram (compute s instr)
+  | otherwise = s
+
+parseProgram :: String -> [Int]
+parseProgram input = Prelude.map read (splitOn "," input)
+
+makeMemory :: [Int] -> Map Int Int
+makeMemory mem = fromList $ zip (iterate (+1) 0) mem
+
+-- Memory -> updated memory
+runProgramV1 :: [Int] -> [Int]
+runProgramV1 mem = Prelude.map snd . toList $ _memory endState
+  where initialState = State 0 0 [] [] (makeMemory mem) True
+        endState = runProgram initialState
+
+-- Input -> memory -> output
+runProgramV2 :: [Int] -> [Int] -> [Int]
+runProgramV2 input mem = _output endState
+  where initialState = State 0 0 input [] (makeMemory mem) True
+        endState = runProgram initialState
+
+-- Memory ->  Inputs (phases) -> Last output
+runProgramV3 :: [Int] -> [Int] -> Int
+runProgramV3 mem phases = chainProcesses instances [0]
+  where instances = Prelude.map (\p -> State 0 0 [p] [] (makeMemory mem) True) phases
+
+-- States -> Added input -> Last Output
+chainProcesses :: [State] -> [Int] -> Int
+chainProcesses (amp:nextAmps) input
+  | _running(amp) == False = out
+  | instrOp == OpWrite = chainProcesses (nextAmps ++ [curAmp]) [(head $ _output curAmp)]
+  | otherwise = chainProcesses (curAmp:nextAmps) []
+  where curAmp = compute amp {_input = (_input amp) ++ input } instr
+        instr = getInstruction amp
+        instrOp = _opcode(instr)
+        out = head (_output amp)
+
+-- directions: 0 = top, 1 = right, 2 = bot, 3 = left
+paintProgram :: State -> (Int, Int) -> Int -> Map (Int, Int) Int -> Map (Int, Int) Int
+paintProgram state curPos curDir painting
+  | _running(state) == False = painting
+  | instrOp == OpRead = paintProgram paintState newPos newDir newPainting
+  | otherwise = paintProgram normalState curPos curDir painting
+  where normalState = compute state instr
+        paintState = compute state {
+          _input = [findWithDefault 0 newPos painting], _output = []} instr
+        instr = getInstruction state
+        instrOp = _opcode instr
+        paintOutput = _output state
+        newPainting = if not (Prelude.null paintOutput)
+                      then insert curPos (paintOutput !! 0) painting
+                      else painting
+        turn = paintOutput !! 1
+        newDir = if not (Prelude.null paintOutput)
+                 then applyTurn turn curDir
+                 else curDir
+        applyTurn 0 cur = mod (cur - 1) 4
+        applyTurn 1 cur = mod (cur + 1) 4
+        newPos = if not (Prelude.null paintOutput)
+                 then move curPos newDir
+                 else curPos
+        move (x, y) 0 = (x, y - 1)
+        move (x, y) 1 = (x + 1, y)
+        move (x, y) 2 = (x, y + 1)
+        move (x, y) 3 = (x - 1, y)
+
+runProgramPaint :: [Int] -> Int -> Map (Int, Int) Int
+runProgramPaint mem initial = paintProgram initialState (0, 0) 0 (initialPaint initial)
+  where initialState = State 0 0 [initial] [] (makeMemory mem) True
+        initialPaint 0 = empty
+        initialPaint 1 = fromList [((0, 0), 1)]

haskellAoC/src/Y2020/Day01.hs

@@ -0,0 +1,33 @@
+module Y2020.Day01 (y20day01) where
+
+import Data.Maybe
+import Data.Sort
+
+findPair :: Int -> Int -> [Int] -> Maybe (Int, Int)
+findPair target x (h:t)
+  | target == x + h = Just (x, h)
+  | target < x + h = Nothing
+  | otherwise = findPair target x t
+findPair _ _ [] = Nothing
+
+findFirstMatchingPair :: Int -> [Int] -> Maybe (Int, Int)
+findFirstMatchingPair target (x:xs)
+  | isJust res = res
+  | otherwise = findFirstMatchingPair target (xs)
+  where res = findPair target x xs
+findFirstMatchingPair _ _ = Nothing
+
+findFirstMatchingTriplet :: Int -> [Int] -> (Int, Int, Int)
+findFirstMatchingTriplet target (x:xs)
+ | isJust res = let Just (a, b) = res in (x, a, b)
+ | otherwise = findFirstMatchingTriplet target xs
+ where res = findFirstMatchingPair (target - x) xs
+
+y20day01 :: [String] -> (String, String)
+y20day01 input = (part1, part2)
+  where
+    entries = (sort (map read input)) :: [Int]
+    Just (a, b) = findFirstMatchingPair 2020 entries
+    (x, y, z) = findFirstMatchingTriplet 2020 entries
+    part1 = show (a * b)
+    part2 = show (x * y * z)

haskellAoC/src/Y2020/Day02.hs

@@ -0,0 +1,25 @@
+module Y2020.Day02 (y20day02) where
+
+import Data.List.Split
+
+parseInput :: String -> (Int, Int, Char, String)
+parseInput input = (qty 0, qty 1, (parts !! 1) !! 0, parts !! 2)
+  where parts = splitOn " " $ filter (\c -> not $ elem c ":") input
+        qty n = read $ (!! n) $ splitOn "-" $ (parts !! 0)
+
+isValidPassP1 :: (Int, Int, Char, String) -> Bool
+isValidPassP1 (minP, maxP, c, pass) = count >= minP && count <= maxP
+  where count = length $ filter (== c) pass
+
+isValidPassP2 :: (Int, Int, Char, String) -> Bool
+isValidPassP2 (pos1, pos2, c, pass) = isPos pos1 `xor` isPos pos2
+  where isPos p = (pass !! (p - 1)) == c
+        xor a b = (a || b) && (a /= b)
+
+y20day02 :: [String] -> (String, String)
+y20day02 input = (part1, part2)
+  where
+    entries = map parseInput $ input
+    strCount f xs = show $ length $ filter f xs
+    part1 = strCount isValidPassP1 entries
+    part2 = strCount isValidPassP2 entries

haskellAoC/src/Y2020/Day03.hs

@@ -0,0 +1,22 @@
+module Y2020.Day03 (y20day03) where
+
+walkMap :: (Int, Int) -> (Int, Int) -> [(Int, Int)]
+walkMap (w, h) (wstep, hstep) = zip wCoords hCoords
+  where wCoords = map (`mod` w) $ take h $ iterate (+ wstep) 0
+        hCoords = take h $ iterate (+ hstep) 0
+
+getCharAtPos :: [String] -> (Int, Int) -> Char
+getCharAtPos myMap (w, h)
+  | h <= length myMap = (myMap !! h) !! w
+  | otherwise = '\0'
+
+getNumberOfTrees :: [String] -> [(Int, Int)] -> Int
+getNumberOfTrees myMap coords = length $ filter (== '#') $ map (getCharAtPos myMap) coords
+
+y20day03 :: [String] -> (String, String)
+y20day03 input = (part1, part2)
+  where width = length $ input !! 0
+        height = (length $ input)
+        getNb slope = getNumberOfTrees input $ walkMap (width, height) slope
+        part1 = show $ getNb (3, 1)
+        part2 = show $ product $ map getNb [(1, 1), (3, 1), (5, 1), (7, 1), (1, 2)]

haskellAoC/src/Y2020/Days.hs

@@ -0,0 +1,5 @@
+module Y2020.Days (y20day01, y20day02, y20day03) where
+
+import Y2020.Day01
+import Y2020.Day02
+import Y2020.Day03