import Data.List
import qualified Data.Map as Map

f xs =
  let x1s = sort $ map fst xs
      x2s = sort $ map snd xs
      diff x y = abs (x - y)
   in sum $ zipWith diff x1s x2s

counter = Map.fromListWith (+) . map (,1)

sim xs =
  let c = counter (map snd xs)
   in sum [x * Map.findWithDefault 0 x c | x <- map fst xs]

main = do
  l <- readFile "data1.txt"
  let xs = [(read x, read y) | [x, y] <- map words (lines l)]
  print (f xs)
  print (sim xs)

allSame [] = True
allSame (x : xs) = all (== x) xs

monotonic xs = allSame (zipWith (\x y -> signum (x - y)) xs (tail xs))

diffValid (x : y : xs)
  | abs (x - y) >= 1 && abs (x - y) <= 3 = diffValid (y : xs)
  | otherwise = False
diffValid _ = True

isSafe xs = monotonic xs && diffValid xs

without xs i = [x | (x, j) <- zip xs [1 ..], j /= i]

isSafeDamp xs = isSafe xs || any (isSafe . without xs) [1 .. length xs]

main = do
  content <- readFile "data2.txt"
  let parsed = map (\l -> map read (words l)) (lines content) :: [[Int]]
  let nSafe = length (filter isSafe parsed)
  let nSafeDamp = length (filter isSafeDamp parsed)
  print ("number of safe elements: " ++ (show nSafe))
  print ("number of safe elements (damping): " ++ (show nSafeDamp))

import Data.List
import Debug.Trace

findMuls :: String -> [Int]
findMuls "" = []
findMuls s@(_ : s')
  | "mul(" `isPrefixOf` s = case parseArgs (drop 3 s) of
      Just ((n1, n2), rest) -> (n1 * n2) : findMuls rest
      Nothing -> findMuls s'
  | otherwise = findMuls s'

findMuls2 :: String -> Bool -> [Int]
findMuls2 [] _ = []
findMuls2 s@(_ : s') enabled
  | "do()" `isPrefixOf` s = findMuls2 (drop 4 s) True
  | "don't()" `isPrefixOf` s = findMuls2 (drop 7 s) False
  | "mul(" `isPrefixOf` s = case (enabled, parseArgs (drop 3 s)) of
      (True, Just ((n1, n2), rest)) -> (n1 * n2) : findMuls2 rest enabled
      _ -> findMuls2 s' enabled
  | otherwise = findMuls2 s' enabled

parseArgs :: String -> Maybe ((Int, Int), String)
parseArgs s = case break (== ')') s of
  (front, ')' : rest) -> case reads (front ++ ")") of
    [(val, "")] -> Just (val, rest)
    _ -> Nothing
  _ -> Nothing

main :: IO ()
main = do
  content <- readFile "data3.txt"
  let total = sum (findMuls content)
  let total2 = sum (findMuls2 content True)
  print $ "total: " ++ show total
  print $ "total with flag: " ++ show total2

import Data.Array
import Data.List

countXmas [] = 0
countXmas s@(_ : s')
  | "XMAS" `isPrefixOf` s = 1 + countXmas (drop 4 s)
  | otherwise = countXmas s'

diagonals grid = [diagonal arr i | i <- [0 .. m + n - 2]]
  where
    m = length grid
    n = length $ head grid
    arr = listArray ((0, 0), (m - 1, n - 1)) (concat grid)
    diagonal arr k = [arr ! (i, k - i) | i <- [max 0 (k - n + 1) .. min k (m - 1)]]

antiDiagonals = diagonals . map reverse

countPatterns grid = sum (map countXmas grid) + sum (map (countXmas . reverse) grid)

countAllDirections grid =
  let gridT = transpose grid
      gridDiag = diagonals grid
      gridADiag = antiDiagonals grid
      horCount = countPatterns grid
      verCount = countPatterns gridT
      diagCount = countPatterns gridDiag
      antiDiagCount = countPatterns gridADiag
   in horCount + verCount + diagCount + antiDiagCount

isMasXShape (i, j) grid =
  grid !! i !! j == 'M'
    && grid !! (i) !! (j + 2) == 'S'
    && grid !! (i + 1) !! (j + 1) == 'A'
    && grid !! (i + 2) !! (j) == 'M'
    && grid !! (i + 2) !! (j + 2) == 'S'

countMasXShape grid = length [() | i <- [0 .. m - 3], j <- [0 .. n - 3], isMasXShape (i, j) grid]
  where
    m = length grid
    n = length $ head grid

countMasXAllDirections grid =
  let normalCount = countMasXShape grid
      horizontalFlipCount = countMasXShape (map reverse grid)
      verticalFlipCount = countMasXShape (transpose grid)
      bothFlipCount = countMasXShape (map reverse $ transpose grid)
   in normalCount + horizontalFlipCount + verticalFlipCount + bothFlipCount

main = do
  content <- readFile "data4.txt"
  let grid = lines content
  -- ഭാഗം 1
  print $ countAllDirections grid
  -- ഭാഗം 2
  print $ countMasXAllDirections grid

import qualified Data.Graph as G
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Set as Set
import System.IO

main = do
  contents <- readFile "data5.txt"
  let (ruleLines, updateLines) = break null (lines contents)
      rules = map parseRule ruleLines
      updates = map parseUpdate (drop 1 updateLines)
      (correctUpdates, incorrectUpdates) = partition (isSorted rules) updates
      sortedUpdates = map (sortAccordingTo rules) incorrectUpdates
      middleSum = sum $ map middle correctUpdates
      middleSum2 = sum $ map middle sortedUpdates
  -- ഭാഗം 1
  print middleSum
  -- ഭാഗം 2
  print middleSum2

parseRule s = let [x, y] = splitOn '|' s in (read x, read y)

parseUpdate s = map read $ splitOn ',' s

splitOn delim s = case break (== delim) s of
  (a, _ : b) -> a : splitOn delim b
  (a, "") -> [a]

isSorted rules update =
  let indices = Map.fromList $ zip update [0 ..]
   in all
        (\(x, y) -> Map.lookup x indices < Map.lookup y indices)
        [(x, y) | (x, y) <- rules, x `elem` update, y `elem` update]

sortAccordingTo rules update =
  let edges = [(n, n, [y | (x, y) <- rules, x == n, y `elem` update]) | n <- update]
      (graph, nodeFromVertex, _) = G.graphFromEdges edges
      sortedVertices = G.topSort graph
      sortedNodes = map (\v -> let (n, _, _) = nodeFromVertex v in n) sortedVertices
   in sortedNodes

middle xs = xs !! (length xs `div` 2)

import Control.Monad.ST
import Data.Array
import Data.Array.ST
import qualified Data.Set as Set
import Debug.Trace

data Elem = Visited | Blocked | Free deriving (Show, Eq)

type Grid = [[Elem]]

data Direction = U | D | L | R deriving (Show, Eq, Ord)

type Pos = (Int, Int)

type State = (Pos, Direction)

turnRight :: Direction -> Direction
turnRight d
  | d == U = R
  | d == R = D
  | d == D = L
  | d == L = U

move (i, j) d
  | d == U = (i - 1, j)
  | d == R = (i, j + 1)
  | d == D = (i + 1, j)
  | d == L = (i, j - 1)

toGrid :: [String] -> Grid
toGrid [] = []
toGrid (l : ls) = (foldr repl [] l) : (toGrid ls)
  where
    repl c acc
      | c == '#' = Blocked : acc
      | otherwise = Free : acc

findGuard grid = head [(i, j) | i <- [0 .. length grid - 1], j <- [0 .. length (head grid) - 1], grid !! i !! j == '^']

countVisited grid = length (filter (== Visited) (elems grid))

simulate grid pos d m n states
  | (pos, d) `Set.member` states = (countVisited grid, True)
  | i' < 0 || i' >= m || j' < 0 || j' >= n = (countVisited grid', False)
  | grid ! (i', j') == Blocked = simulate grid' pos (turnRight d) m n states'
  | otherwise = simulate grid' (move pos d) d m n states'
  where
    states' = Set.insert (pos, d) states
    (i', j') = move pos d
    grid' = (grid // [(pos, Visited)])

countCycles grid pos d m n = length $ filter snd $ map (\(g, idx) -> simulateWithLog g pos d m n Set.empty idx total) (zip grids [1 ..])
  where
    grids = [grid // [((i, j), Blocked)] | i <- [0 .. m - 1], j <- [0 .. n - 1], grid ! (i, j) /= Blocked]
    total = length grids
    simulateWithLog grid pos d m n states idx total = trace (logProgress idx total) $ simulate grid pos d m n states
    logProgress idx total = show idx ++ "/" ++ show total

main = do
  content <- readFile "data6.txt"
  let charGrid = lines content
  let grid = toGrid charGrid
  let pos = findGuard charGrid
  let (m, n) = (length grid, length $ head grid)
  let inds = [(i, j) | i <- [0 .. m - 1], j <- [0 .. n - 1]]
  let gridArr = array ((0, 0), (m - 1, n - 1)) (zip inds $ concat grid)
  print $ fst $ simulate gridArr pos U m n Set.empty
  print $ countCycles gridArr pos U m n

countVisitedST :: STArray s (Int, Int) Elem -> ST s Int
countVisitedST mGrid = do
  elems <- getElems mGrid
  return $ length (filter (== Visited) elems)

simulate :: Array (Int, Int) Elem -> (Int, Int) -> Direction -> Int -> Int -> Set.Set State -> (Int, Bool)
simulate grid pos d m n states = runST $ do
  mGrid <- thaw grid :: ST s (STArray s (Int, Int) Elem)
  simulateST mGrid pos d m n states

simulateST :: STArray s (Int, Int) Elem -> (Int, Int) -> Direction -> Int -> Int -> Set.Set State -> ST s (Int, Bool)
simulateST mGrid pos@(i, j) d m n states
  | (pos, d) `Set.member` states = do
      writeArray mGrid pos Visited
      visitedCount <- countVisitedST mGrid
      return (visitedCount, True)
  | i' < 0 || i' >= m || j' < 0 || j' >= n = do
      writeArray mGrid pos Visited
      visitedCount <- countVisitedST mGrid
      return (visitedCount, False)
  | otherwise = do
      currentElem <- readArray mGrid (i', j')
      if currentElem == Blocked
        then simulateST mGrid pos (turnRight d) m n states'
        else do
          writeArray mGrid pos Visited
          simulateST mGrid (move pos d) d m n states'
  where
    states' = Set.insert (pos, d) states
    (i', j') = move pos d

concatMapFuncs :: [(a -> a -> a)] -> [a] -> [a]
concatMapFuncs fs [x] = [x]
concatMapFuncs fs (x : xs) = concatMap applyAll (concatMapFuncs fs xs)
  where
    applyAll y = map (\f -> f x y) fs

evalResults ops target xs = target `elem` (concatMapFuncs ops xs)

-- ആർഗ്യുമെന്റുകൾ റിവേഴ്സ് ചെയ്യുക, കാരണം ഡാറ്റ റിവേഴ്സ് ആണ്
intConcat x y = read (show y ++ show x)

splitLine c s = let (pre, _ : _ : post) = break (== c) s in (pre, post)

main = do
  content <- readFile "data7.txt"
  let contentLines = lines content
  let splitLines = map (splitLine ':') contentLines
  -- റിവേഴ്സ് ചെയ്യുക, അങ്ങനെ പ്രിസിഡൻസ് ഇടത്തുനിന്ന് വലത്തോട്ട് ആയിരിക്കും
  let parsedLines = [(read target, reverse $ map read $ words nums) | (target, nums) <- splitLines]
  let calibratedLines = filter (uncurry (evalResults [(+), (*)])) parsedLines
  let calibratedLinesConcat = filter (uncurry (evalResults [(+), (*), intConcat])) parsedLines
  let result = sum $ map fst calibratedLines
  let result2 = sum $ map fst calibratedLinesConcat
  -- ഭാഗം 1
  print $ result
  -- ഭാഗം 2
  print $ result2

import Data.Array
import Data.List
import qualified Data.Map as Map

type Loc = (Int, Int)

instance Num Loc where
  (x1, y1) + (x2, y2) = (x1 + x2, y1 + y2)
  (x1, y1) - (x2, y2) = (x1 - x2, y1 - y2)
  (x1, y1) * (x2, y2) = (x1 * x2, y1 * y2)
  fromInteger n = (fromInteger n, fromInteger n)

freqLocations grid = foldr (\(pos, c) acc -> Map.insertWith (++) c [pos] acc) Map.empty nonEmptyGrid
  where
    nonEmptyGrid = filter (\(_, c) -> c /= '.') $ assocs grid

pairs [] = []
pairs (x : xs) = [(x, y) | y <- xs] ++ pairs xs

scale n p = p * fromInteger n

inBounds grid (i, j) =
  let ((minI, minJ), (maxI, maxJ)) = bounds grid
   in i >= minI && i <= maxI && j >= minJ && j <= maxJ

-- ഭാഗം 1
placeAntinodes inBounds (p1, p2) = filter inBounds [p1 - dist, p2 + dist]
  where
    dist = p2 - p1

-- ഭാഗം 2
placeAntinodes2 inBounds (p1, p2) = (genNodes spaceBefore) ++ (genNodes spaceAfter)
  where
    genNodes spacingRule = takeWhile inBounds $ map spacingRule [0 ..]
    dist = p2 - p1
    spaceBefore n = p1 - (scale n dist)
    spaceAfter n = p2 + (scale n dist)

antinodes grid locMap placeAntinodes = concatMap process (Map.elems locMap)
  where
    process locs = concatMap placeAntinodes (pairs locs)

main = do
  content <- readFile "data8.txt"
  let gridList = lines content
  let (m, n) = (length gridList, length $ head gridList)
  let grid = listArray ((0, 0), (m - 1, n - 1)) (concat gridList)
  let locMap = freqLocations grid
  let placer1 = placeAntinodes (inBounds grid)
  let placer2 = placeAntinodes2 (inBounds grid)
  let allAntinodes1 = antinodes grid locMap placer1
  let allAntinodes2 = antinodes grid locMap placer2
  -- ഭാഗം 1
  print $ length $ nub allAntinodes1
  -- ഭാഗം 2
  print $ length $ nub allAntinodes2

import Data.Char
import Data.List (group)
import Debug.Trace

readDisk :: [Int] -> [Int]
readDisk xs = let (_, _, disk) = foldl process (True, 0, []) xs in disk
  where
    process (isFile, curId, disk) x =
      if isFile
        then
          (False, curId + 1, disk ++ (replicate x curId))
        else (True, curId, disk ++ (replicate x (-1)))

compress disk = (take filesize $ compress' disk revDisk) ++ (replicate (length disk - filesize) (-1))
  where
    compress' [] _ = []
    compress' _ [] = []
    compress' (f : fs) (b : bs)
      | f == -1 = b : compress' fs bs
      | otherwise = f : compress' fs (b : bs)
    revDisk = filter (>= 0) $ reverse disk
    filesize = length revDisk

compressBlocks :: [Int] -> [Int]
compressBlocks disk = concat $ compress' groups
  where
    compress' [] = []
    compress' gs =
      let (lastG, initG) = (last gs, init gs)
       in if head lastG == -1
            then (compress' initG) ++ [lastG]
            else case place lastG initG of
              Just gs' -> compress' $ group $ concat $ gs' ++ [replicate (length lastG) (-1)]
              Nothing -> compress' initG ++ [lastG]
    place _ [] = Nothing
    place x (f : fs)
      | (head f == -1) && length x <= length f = Just ((fill f x) : fs)
      | otherwise = do
          rest <- place x fs
          return (f : rest)
    groups = group disk
    back = filter ((>= 0) . head) groups
    fill f b = b ++ (drop (length b) f)

checkSum compressedDisk = sum [i * x | (i, x) <- zip [0 ..] compressedDisk, x /= -1]

showDisk disk = map (\x -> if x == -1 then '.' else intToDigit x) disk

main = do
  content <- readFile "data9.txt"
  let nums = map digitToInt content :: [Int]
  let disk = readDisk nums
  let compressed = compress disk
  let compressedBlocks = compressBlocks disk
  let cs = checkSum compressed
  let cs2 = checkSum compressedBlocks
  print $ cs
  print $ cs2

import Data.Array
import Data.Char
import Data.List
import qualified Data.Set as Set

inBounds grid (i, j) =
  let ((minI, minJ), (maxI, maxJ)) = bounds grid
   in i >= minI && i <= maxI && j >= minJ && j <= maxJ

trailheads grid = [(i, j) | ((i, j), x) <- assocs grid, x == 0]

count9 grid positions = length $ filter (\pos -> grid ! pos == 9) positions

dfs grid (i, j) = dfs' [] [(i, j)]
  where
    dfs' seen [] = seen
    dfs' seen (cur : stack) = dfs' (cur : seen) (neighbors cur ++ stack)
    neighbors (i, j) =
      [ (i', j')
      | (i', j') <- diffs (i, j),
        inBounds grid (i', j'),
        grid ! (i', j') - grid ! (i, j) == 1
      ]
    diffs (i, j) = [(i + 1, j), (i - 1, j), (i, j + 1), (i, j - 1)]

-- ഇവിടെ ഞങ്ങൾ എത്താവുന്ന 9കളുടെ എണ്ണത്തെക്കുറിച്ചാണ് ശ്രദ്ധിക്കുന്നത്, സൂചികയിൽ അദ്വിതീയമാണ്
trailheadScore grid (i, j) = count9 grid $ nub $ dfs grid (i, j)

-- ഇവിടെ ഞങ്ങൾ ഏതെങ്കിലും 9-ലേക്ക് എത്താനുള്ള വഴികളുടെ എണ്ണത്തെക്കുറിച്ചാണ് ശ്രദ്ധിക്കുന്നത്, സൂചികയിൽ അദ്വിതീയമല്ല
trailheadRating grid (i, j) = count9 grid $ dfs grid (i, j)

main = do
  content <- readFile "data10.txt"
  let contentLines = lines content
  let (m, n) = (length contentLines, length $ head contentLines)
  let grid = listArray ((0, 0), (m - 1, n - 1)) (map digitToInt $ concat contentLines)
  let ths = trailheads grid
  let score1 = sum $ map (trailheadScore grid) ths
  let score2 = sum $ map (trailheadRating grid) ths
  putStrLn $ "ഭാഗം 1: " ++ (show score1)
  putStrLn $ "ഭാഗം 2: " ++ (show score2)

import qualified Data.Map as Map

type Cache = Map.Map (Int, Int) Int

blinkLen :: Int -> Int -> Cache -> (Int, Cache)
blinkLen 0 _ cache = (1, cache)
blinkLen n 0 cache = blinkLen (n - 1) 1 cache
blinkLen n x cache =
  case Map.lookup (n, x) cache of
    Just result -> (result, cache)
    Nothing ->
      let (result, newCache) =
            if evenLength x
              then evenBlink x cache
              else blinkLen (n - 1) (x * 2024) cache
          updatedCache = Map.insert (n, x) result newCache
       in (result, updatedCache)
  where
    evenBlink x cache =
      let (x1, x2) = split x
          (res1, cache1) = blinkLen (n - 1) x1 cache
          (res2, cache2) = blinkLen (n - 1) x2 cache1
       in (res1 + res2, cache2)
    evenLength x = length (show x) `mod` 2 == 0
    split x = (read $ take halfLen xStr, read $ drop halfLen xStr)
      where
        xStr = show x
        halfLen = length xStr `div` 2

main = do
  content <- readFile "data11.txt"
  let nums = map read $ words content :: [Int]
  let (result, cache) = foldl (\(acc, cache) x -> let (res, newCache) = blinkLen 25 x cache in (acc + res, newCache)) (0, Map.empty) nums
  putStrLn $ "Part 1: " ++ show result
  let (result2, _) = foldl (\(acc, cache) x -> let (res, newCache) = blinkLen 75 x cache in (acc + res, newCache)) (0, cache) nums
  putStrLn $ "Part 2: " ++ show result2

import Data.Array
import Data.List (group, sortOn)
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set

type Loc = (Int, Int)

type Grid = Array Loc Char

directions :: [Loc]
directions = [(-1, 0), (1, 0), (0, -1), (0, 1)]

inBounds :: Grid -> Loc -> Bool
inBounds grid (i, j) =
  let ((minI, minJ), (maxI, maxJ)) = bounds grid
   in i >= minI && i <= maxI && j >= minJ && j <= maxJ

dfs grid start value visited = dfs' [start] visited []
  where
    dfs' [] visited acc = (acc, visited)
    dfs' (current : stack) visited acc
      | current `Set.member` visited = dfs' stack visited acc
      | otherwise = dfs' (neighbors ++ stack) (Set.insert current visited) (current : acc)
      where
        neighbors =
          [ (i + di, j + dj)
          | (di, dj) <- directions,
            let (i, j) = current,
            let neighbor = (i + di, j + dj),
            inBounds grid neighbor,
            grid ! neighbor == value
          ]

findRegions :: Grid -> [[Loc]]
findRegions grid = findRegions' (indices grid) Set.empty []
  where
    findRegions' [] _ acc = acc
    findRegions' (loc : locs) visited acc
      | loc `Set.member` visited = findRegions' locs visited acc
      | otherwise =
          let value = grid ! loc
              (region, newVisited) = dfs grid loc value visited
           in findRegions' locs newVisited (region : acc)

perimeter grid (i, j) = length $ perimeterIndices grid (i, j)

perimeterIndices grid (i, j) = filter isDifferentOrOutOfBounds neighbors
  where
    neighbors = [(i + di, j + dj) | (di, dj) <- directions]
    isDifferentOrOutOfBounds (ni, nj) =
      not (inBounds grid (ni, nj)) || grid ! (ni, nj) /= grid ! (i, j)

nSides grid region =
  sum (map (vertSideRows (-1)) [0 .. n])
    + sum (map (vertSideRows 1) [0 .. n])
    + sum (map (horSideRows (-1)) [0 .. m])
    + sum (map (horSideRows 1) [0 .. m])
  where
    countSides sides = length $ filter (\xs -> head xs) $ group sides
    vertSideRows dj j = contGroups $ map fst $ filter (\(i, j) -> invalid (i, j + dj)) (colArray ! j)
    horSideRows di i = contGroups $ map snd $ filter (\(i, j) -> invalid (i + di, j)) (rowArray ! i)
    ((0, 0), (m, n)) = bounds grid
    invalid (ni, nj) =
      not (inBounds grid (ni, nj)) || not (inRegion (ni, nj))
    inRegion pos = pos `Set.member` regionSet
    regionSet = Set.fromList region
    colArray = listArray (0, n) [sortOn fst $ filter ((== j) . snd) region | j <- [0 .. n]]
    rowArray = listArray (0, m) [sortOn snd $ filter ((== i) . fst) region | i <- [0 .. m]]
    contGroups [] = 0
    contGroups [x] = 1
    contGroups (x1 : x2 : xs)
      | x2 - x1 == 1 = contGroups (x2 : xs)
      | otherwise = 1 + contGroups (x2 : xs)

main :: IO ()
main = do
  content <- readFile "data12.txt"
  let gridList = lines content
  let (m, n) = (length gridList, length $ head gridList)
  let grid = listArray ((0, 0), (m - 1, n - 1)) (concat gridList)
  let regions = findRegions grid
  let areas = map length regions
  let perimeters = map (\r -> sum $ map (perimeter grid) r) regions
  putStrLn $ "ഭാഗം 1: " ++ show (sum $ zipWith (*) areas perimeters)
  let sides = map (nSides grid) regions
  putStrLn $ "ഭാഗം 2: " ++ show (sum $ zipWith (*) areas sides)

import Data.Maybe
import Debug.Trace
import Text.Parsec
import Text.Parsec.String (Parser)

{-
A =
ax bx
ay by
b = [px, py]
Ax=b => x = A^-1 b
-}
solve ((ax, ay), (bx, by), (px, py)) =
  let a = fromIntegral ax
      b = fromIntegral bx
      c = fromIntegral ay
      d = fromIntegral by
      p = fromIntegral px
      q = fromIntegral py
      det = a * d - b * c
   in if det == 0
        then Nothing
        else
          let (invA11, invA12, invA21, invA22) = (d / det, -b / det, -c / det, a / det)
              x = invA11 * p + invA12 * q
              y = invA21 * p + invA22 * q
              roundedX = round x
              roundedY = round y
           in if (fromIntegral roundedX * a + fromIntegral roundedY * b == p) && (fromIntegral roundedX * c + fromIntegral roundedY * d == q)
                then Just (3 * roundedX + roundedY)
                else Nothing

minTokenCost xs = sum $ map (maybe 0 id . solve) xs

parseTestCase :: Parser ((Int, Int), (Int, Int), (Int, Int))
parseTestCase = do
  _ <- string "Button A: X+"
  ax <- many1 digit
  _ <- string ", Y+"
  ay <- many1 digit
  _ <- newline
  _ <- string "Button B: X+"
  bx <- many1 digit
  _ <- string ", Y+"
  by <- many1 digit
  _ <- newline
  _ <- string "Prize: X="
  px <- many1 digit
  _ <- string ", Y="
  py <- many1 digit
  _ <- newline
  return ((read ax, read ay), (read bx, read by), (read px, read py))

parseTestCases :: Parser [((Int, Int), (Int, Int), (Int, Int))]
parseTestCases = many (parseTestCase <* optional newline)

readTestCases :: String -> Either ParseError [((Int, Int), (Int, Int), (Int, Int))]
readTestCases = parse parseTestCases ""

main = do
  input <- readFile "data13.txt"
  let delta = 10000000000000
  case readTestCases input of
    Left err -> print err
    Right testCases -> do
      putStrLn $ "Part 1: " ++ show (minTokenCost testCases)
      let testCasesPart2 = map (\((ax, ay), (bx, by), (px, py)) -> ((ax, ay), (bx, by), (px + delta, py + delta))) testCases
      putStrLn $ "Part 2: " ++ show (minTokenCost testCasesPart2)

import Control.Monad.ST
import Data.Array
import Data.Array.ST
import Data.List
import Debug.Trace
import Text.Parsec
import Text.Parsec.String (Parser)

number :: Parser Int
number = do
  sign <- optionMaybe (char '-')
  digits <- many1 digit
  let num = read digits
  return $ case sign of
    Just _ -> -num
    Nothing -> num

parseLine :: Parser ((Int, Int), (Int, Int))
parseLine = do
  _ <- string "p="
  px <- number
  _ <- char ','
  py <- number
  _ <- spaces
  _ <- string "v="
  vx <- number
  _ <- char ','
  vy <- number
  return ((py, px), (vy, vx))

parseData :: Parser [((Int, Int), (Int, Int))]
parseData = parseLine `sepBy` newline

zeros m n = listArray ((0, 0), (m - 1, n - 1)) [0 | i <- [0 .. m - 1], j <- [0 .. n - 1]]

buildGrid :: [((Int, Int), (Int, Int))] -> Int -> Int -> Array (Int, Int) Int
buildGrid nums m n = runSTArray $ do
  arr <- newArray ((0, 0), (m - 1, n - 1)) 0
  mapM_ (assign arr) nums
  return arr
  where
    assign arr ((x, y), _) = do
      current <- readArray arr (x, y)
      writeArray arr (x, y) (current + 1)

printGrid :: Array (Int, Int) Int -> IO ()
printGrid grid = do
  let ((minX, minY), (maxX, maxY)) = bounds grid
  mapM_ (printRow minY maxY) [minX .. maxX]
  where
    printRow minY maxY x = do
      let row = [if grid ! (x, y) == 0 then '.' else head (show (grid ! (x, y))) | y <- [minY .. maxY]]
      putStrLn row

timestep _ _ [] = []
timestep m n (((pi, pj), (vi, vj)) : rest) = (wrap (pi + vi) (pj + vj) m n, (vi, vj)) : (timestep m n rest)
  where
    wrap i j m n = ((i + m) `mod` m, (j + n) `mod` n)

quadrantSums grid m n =
  let mid dim = ((dim - 1) `div` 2)
      (midI, midJ) = (mid m, mid n)
   in [ sum $ [grid ! (i, j) | i <- [0 .. midI - 1], j <- [0 .. midJ - 1]],
        sum $ [grid ! (i, j) | i <- [0 .. midI - 1], j <- [midJ + 1 .. n - 1]],
        sum $ [grid ! (i, j) | i <- [midI + 1 .. m - 1], j <- [0 .. midJ - 1]],
        sum $ [grid ! (i, j) | i <- [midI + 1 .. m - 1], j <- [midJ + 1 .. n - 1]]
      ]

hasCenter :: Int -> Int -> Int -> [((Int, Int), (Int, Int))] -> Bool
hasCenter m n thresh nums = thresh <= (length $ filter inCenter nums)
  where
    inCenter ((i, j), _) = i >= m `div` 4 && i <= 3 * (m `div` 4) && j >= n `div` 4 && j <= 3 * (n `div` 4)

main = do
  content <- readFile "data14.txt"
  let (m, n) = (103, 101)
  let niter = 100
  case parse parseData "" content of
    Left err -> print err >> return ()
    Right nums -> do
      putStrLn ""
      let states = iterate (timestep m n) nums
      let finalState = states !! niter
      let finalGrid = buildGrid finalState m n
      let qsums = quadrantSums finalGrid m n
      putStrLn $ "ഭാഗം 1: " ++ (show $ product qsums)
      let thresh = length nums `div` 2
      let (firstIndex, num) = head $ filter (\(i, num) -> hasCenter m n thresh num) $ zip [0 ..] states
      printGrid $ buildGrid num m n
      putStrLn $ "ഭാഗം 2: " ++ (show i)

import Control.Monad.ST
import Data.Array
import Data.Array.ST
import Debug.Trace

type Loc = (Int, Int)

type Grid = Array Loc Char

type Dir = Char

inBounds :: Grid -> Loc -> Bool
inBounds grid (i, j) =
  let ((iMin, jMin), (iMax, jMax)) = bounds grid
   in i >= iMin && i <= iMax && j >= jMin && j <= jMax

inBoundsMut :: (Ix i) => STArray s (i, i) e -> (i, i) -> ST s Bool
inBoundsMut grid (i, j) = do
  ((iMin, jMin), (iMax, jMax)) <- getBounds grid
  return $ i >= iMin && i <= iMax && j >= jMin && j <= jMax

nextPos dir (i, j) = case dir of
  '^' -> (i - 1, j)
  'v' -> (i + 1, j)
  '<' -> (i, j - 1)
  '>' -> (i, j + 1)

move :: Grid -> Loc -> Loc -> Maybe Grid
move grid (i1, j1) (i2, j2)
  | inBounds grid (i1, j1) && inBounds grid (i2, j2) =
      let (didMove, grid') = runST $ do
            gridMut <- thaw grid
            didMove <- moveST gridMut (i1, j1) (i2, j2)
            grid' <- freeze gridMut
            return (didMove, grid')
       in if didMove then Just grid' else Nothing
  | otherwise = Nothing

moveST :: STArray s Loc Char -> Loc -> Loc -> ST s Bool
moveST gridMut (i1, j1) (i2, j2) = do
  elem1 <- readArray gridMut (i1, j1)
  elem2 <- readArray gridMut (i2, j2)
  case (elem1, elem2) of
    ('.', _) -> return True
    (_, '#') -> return False
    ('@', '.') -> do
      writeArray gridMut (i2, j2) '@'
      writeArray gridMut (i1, j1) '.'
      return True
    ('O', '.') -> do
      writeArray gridMut (i2, j2) 'O'
      writeArray gridMut (i1, j1) '.'
      return True
    (x, 'O') -> do
      let (i3, j3) = (i2 + (i2 - i1), j2 + (j2 - j1))
      inb <- inBoundsMut gridMut (i3, j3)
      if inb
        then do
          valid <- moveST gridMut (i2, j2) (i3, j3)
          if not valid
            then return False
            else do
              writeArray gridMut (i2, j2) x
              writeArray gridMut (i1, j1) '.'
              return True
        else return False

moveRobot grid (i, j) dir =
  let (i', j') = nextPos dir (i, j)
   in if not (inBounds grid (i', j'))
        then (grid, (i, j))
        else case move grid (i, j) (i', j') of
          Just g -> (g, (i', j'))
          Nothing -> (grid, (i, j))

printGrid :: Grid -> IO ()
printGrid grid = do
  let ((iMin, jMin), (iMax, jMax)) = bounds grid
  mapM_
    ( \i -> do
        mapM_ (\j -> putStr [grid ! (i, j)]) [jMin .. jMax]
        putStrLn ""
    )
    [iMin .. iMax]

traceGrid :: Grid -> a -> a
traceGrid grid expr = trace (unlines gridLines) expr
  where
    ((iMin, jMin), (iMax, jMax)) = bounds grid
    gridLines = [[grid ! (i, j) | j <- [jMin .. jMax]] | i <- [iMin .. iMax]]

score grid = sum $ map (\((i, j), _) -> 100 * i + j) $ filter (\(_, x) -> x == 'O') $ assocs grid

wideGrid grid m n = listArray ((0, 0), (m - 1, 2 * n - 1)) grid'
  where
    grid' = concatMap repl (assocs grid)
    repl (_, x)
      | x == '#' = "##"
      | x == 'O' = "[]"
      | x == '.' = ".."
      | x == '@' = "@."

findPos grid = head [pos | (pos, x) <- assocs grid, x == '@']

gpsCoordSum grid = sum [100 * i + j | ((i, j), x) <- assocs grid, x == '[']

moveW :: Array Loc Char -> Dir -> Array Loc Char
moveW grid dir = case (grid ! (i, j), grid ! (i', j')) of
  ('@', '#') -> grid
  ('@', '.') -> grid // [((i, j), '.'), ((i', j'), '@')]
  ('@', '[') ->
    let grid' = moveBox grid (i', j') dir
     in if grid' ! (i', j') == '.'
          then
            grid' // [((i, j), '.'), ((i', j'), '@')]
          else grid
  ('@', ']') ->
    let grid' = moveBox grid (i', j' - 1) dir
     in if grid' ! (i', j') == '.'
          then
            grid' // [((i, j), '.'), ((i', j'), '@')]
          else grid
  x -> error (show x)
  where
    (i, j) = findPos grid
    (i', j') = nextPos dir (i, j)
    -- move box at (i,j) in direction dir
    moveBox :: Array Loc Char -> Loc -> Dir -> Array Loc Char
    moveBox grid (i, j) dir
      -- if we move up, it can either between
      -- []
      -- []   (moves up)
      -- [][]
      --  []  (moves up)
      -- in the first case, we move the upper box and move the cur box if there is space
      -- in the second case we move both boxes and then the current box if there is space
      | boxSpaceEmpty grid (i, j) dir =
          if grid ! (i, j) /= '['
            then
              error "must be left brack"
            else case dir of
              '^' ->
                grid
                  // [ ((i, j), '.'),
                       ((i, j + 1), '.'),
                       ((i - 1, j), '['),
                       ((i - 1, j + 1), ']')
                     ]
              'v' ->
                grid
                  // [ ((i, j), '.'),
                       ((i, j + 1), '.'),
                       ((i + 1, j), '['),
                       ((i + 1, j + 1), ']')
                     ]
              '<' ->
                grid
                  // [ ((i, j), ']'),
                       ((i, j + 1), '.'),
                       ((i, j - 1), '[')
                     ]
              '>' ->
                grid
                  // [ ((i, j), '.'),
                       ((i, j + 1), '['),
                       ((i, j + 2), ']')
                     ]
      | boxSpaceBlocked grid (i, j) dir = grid
      | otherwise =
          let boxes = getNeighBoxes grid (i, j) dir
              grid' = foldr (\pos g -> moveBox g pos dir) grid boxes :: Array Loc Char
           in if boxSpaceEmpty grid' (i, j) dir
                then
                  moveBox grid' (i, j) dir
                else grid'

    getNeighBoxes grid (i, j) dir
      | grid ! (i, j) /= '[' = error "must be left brack"
      | otherwise = case dir of
          '^' ->
            if grid ! (i - 1, j) == '['
              then [(i - 1, j)]
              else
                if grid ! (i - 1, j) == ']' && grid ! (i - 1, j + 1) == '['
                  then [(i - 1, j - 1), (i - 1, j + 1)]
                  else
                    if grid ! (i - 1, j) == ']'
                      then [(i - 1, j - 1)]
                      else
                        if grid ! (i - 1, j + 1) == '['
                          then [(i - 1, j + 1)]
                          else []
          'v' ->
            if grid ! (i + 1, j) == '['
              then [(i + 1, j)]
              else
                if grid ! (i + 1, j) == ']' && grid ! (i + 1, j + 1) == '['
                  then [(i + 1, j - 1), (i + 1, j + 1)]
                  else
                    if grid ! (i + 1, j) == ']'
                      then [(i + 1, j - 1)]
                      else
                        if grid ! (i + 1, j + 1) == '['
                          then [(i + 1, j + 1)]
                          else []
          '>' -> if grid ! (i, j + 2) == '[' then [(i, j + 2)] else []
          '<' -> if grid ! (i, j - 1) == ']' then [(i, j - 2)] else []

    boxDisplacingSpaces grid (i, j) dir
      | grid ! (i, j) /= '[' = error "must be left brack"
      | otherwise = case dir of
          '^' -> [(i - 1, j), (i - 1, j + 1)]
          'v' -> [(i + 1, j), (i + 1, j + 1)]
          '>' -> [(i, j + 2)]
          '<' -> [(i, j - 1)]

    boxSpaceEmpty grid (i, j) dir =
      all
        (\p -> inBounds grid p && grid ! p == '.')
        (boxDisplacingSpaces grid (i, j) dir)

    boxSpaceBlocked grid (i, j) dir =
      any
        (\p -> not (inBounds grid p) || grid ! p == '#')
        (boxDisplacingSpaces grid (i, j) dir)

main :: IO ()
main = do
  rawContent <- readFile "data15.txt"
  let (gridSpec, _ : movesSpec) = break null (lines rawContent)
  let moves = concat movesSpec
  let (m, n) = (length gridSpec, length $ head gridSpec)
  let grid = listArray ((0, 0), (m - 1, n - 1)) (concat gridSpec)
  let (i, j) = fst $ head $ filter (\(_, x) -> x == '@') $ assocs grid
  let (finalGrid, finalPos) = foldl' (\(grid, pos) d -> moveRobot grid pos d) (grid, (i, j)) moves
  print $ score finalGrid
  let wgrid = wideGrid grid m n
  let final = foldl' moveW wgrid moves
  print $ gpsCoordSum final

{-# LANGUAGE TupleSections #-}

import Data.Array
import Data.Heap (MinPrioHeap)
import qualified Data.Heap as H
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set
import System.IO

type Dir = Int

type Loc = (Int, Int)

type Grid = Array Loc Char

type State = (Loc, Dir)

type Cost = Int

directionsForward = [(0, 1), (1, 0), (0, -1), (-1, 0)]

directionsBackward = map (\(x, y) -> (-x, -y)) directionsForward

parseGrid :: [String] -> (Grid, Loc, Loc)
parseGrid linesInput =
  let m = length linesInput
      n = length (head linesInput)
      gridList = concat linesInput
      grid = listArray ((0, 0), (m - 1, n - 1)) gridList
      findPos x = head [(i, j) | i <- [0 .. m - 1], j <- [0 .. n - 1], grid ! (i, j) == x]
      start = findPos 'S'
      end = findPos 'E'
   in (grid, start, end)

isValid :: Grid -> Loc -> Bool
isValid grid loc = inBounds grid loc && grid ! loc /= '#'

inBounds :: Grid -> Loc -> Bool
inBounds grid (i, j) =
  let ((iMin, jMin), (iMax, jMax)) = bounds grid
   in i >= iMin && i <= iMax && j >= jMin && j <= jMax

dijkstra :: Grid -> [State] -> [Loc] -> Map.Map State Cost
dijkstra grid starts directions = go initialQueue Map.empty
  where
    initialQueue = H.fromList [(0, s) | s <- starts]

    go :: MinPrioHeap Cost State -> Map.Map State Cost -> Map.Map State Cost
    go pq seenMap =
      case H.view pq of
        Nothing -> seenMap
        Just ((currentCost, currentState), pq') ->
          if Map.member currentState seenMap
            then go pq' seenMap
            else
              let seenMap' = Map.insert currentState currentCost seenMap
                  (loc@(x, y), dir) = currentState
                  (dx, dy) = directions !! dir
                  newLoc = (x + dx, y + dy)
                  newStates =
                    if isValid grid newLoc
                      then [(currentCost + 1, (newLoc, dir))]
                      else []
                  turnDirs = [(dir + 1) `mod` 4, (dir + 3) `mod` 4]
                  newStates' = newStates ++ [(currentCost + 1000, (loc, newDir)) | newDir <- turnDirs]
                  updatedPQ = foldr H.insert pq' newStates'
               in go updatedPQ seenMap'

countBestPathTiles grid start end minCost costFromStart costToEnd =
  let startsFromStart = [(start, 0)]
      startsFromEnd = [(end, d) | d <- [0 .. 3]]
      gridBounds = range (bounds grid)
      bestTiles =
        Set.fromList
          [ loc
          | loc <- gridBounds,
            grid ! loc /= '#',
            any
              ( \d ->
                  let cost_s = Map.findWithDefault maxBound (loc, d) costFromStart
                      cost_e = Map.findWithDefault maxBound (loc, d) costToEnd
                   in cost_s + cost_e == minCost
              )
              [0 .. 3]
          ]
   in Set.size bestTiles

main :: IO ()
main = do
  content <- readFile "data16.txt"
  let gridLines = lines content
  let (grid, start, end) = parseGrid gridLines
  let startsFromStart = [(start, 0)]
  let costFromStart = dijkstra grid startsFromStart directionsForward
  let startsFromEnd = [(end, d) | d <- [0 .. 3]]
  let costToEnd = dijkstra grid startsFromEnd directionsBackward
  let minCost = minimum [Map.findWithDefault maxBound (end, d) costFromStart | d <- [0 .. 3]]
  putStrLn $ "കുറഞ്ഞ സ്കോർ: " ++ show minCost
  let tileCount = countBestPathTiles grid start end minCost costFromStart costToEnd
  putStrLn $ "മികച്ച പാതകളുടെ ടൈലുകളുടെ എണ്ണം: " ++ show tileCount

import Data.Array
import Data.Bits
import Data.List (foldl', intercalate)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import System.IO
import Text.Parsec
import Text.Parsec.String (Parser)

type Regs = Array Int Int

type Op = Int

type Inst = (Int, Int)

type Prog = [Inst]

type Func = Regs -> [Int] -> Op -> Int -> (Regs, [Int], Int)

[a, b, c] = [0 .. 2]

comboOperand :: Regs -> Int -> Int
comboOperand regs op
  | op <= 3 = op
  | op == 4 = regs ! a
  | op == 5 = regs ! b
  | op == 6 = regs ! c
  | otherwise = error "Invalid operand"

adv, bxl, bst, jnz, bxc, outOp, bdv, cdv :: Func
adv regs out op ip = (regs // [(a, res)], out, ip + 1)
  where
    res = regs ! a `div` (2 ^ comboOperand regs op)
bxl regs out op ip = (regs // [(b, res)], out, ip + 1)
  where
    res = regs ! b `xor` op
bst regs out op ip = (regs // [(b, comboOperand regs op `mod` 8)], out, ip + 1)
jnz regs out op ip = (regs, out, ip')
  where
    ip' = if regs ! a /= 0 then op else ip + 1
bxc regs out op ip = (regs // [(b, regs ! b `xor` regs ! c)], out, ip + 1)
outOp regs out op ip = (regs, o : out, ip + 1)
  where
    o = comboOperand regs op `mod` 8
bdv regs out op ip = (regs // [(b, res)], out, ip + 1)
  where
    res = regs ! a `div` (2 ^ comboOperand regs op)
cdv regs out op ip = (regs // [(c, res)], out, ip + 1)
  where
    res = regs ! a `div` (2 ^ comboOperand regs op)

opFuncs :: [Func]
opFuncs = [adv, bxl, bst, jnz, bxc, outOp, bdv, cdv]

-- പ്രാരംഭ രജിസ്റ്റർ മൂല്യങ്ങൾക്കായുള്ള പാർസർ
parseRegs :: Parser Regs
parseRegs = do
  string "Register A: "
  aVal <- read <$> many1 digit
  newline
  string "Register B: "
  bVal <- read <$> many1 digit
  newline
  string "Register C: "
  cVal <- read <$> many1 digit
  many newline
  return $ listArray (0, 2) [aVal, bVal, cVal]

-- പ്രോഗ്രാമിനായുള്ള പാർസർ
parseProg :: Parser Prog
parseProg = do
  string "Program: "
  sepBy parseInst (char ',')

-- ഒരൊറ്റ ഇൻസ്ട്രക്ഷനായുള്ള പാർസർ
parseInst :: Parser Inst
parseInst = do
  opcode <- read <$> many1 digit
  char ','
  operand <- read <$> many1 digit
  return (opcode, operand)

-- മുഴുവൻ ഇൻപുട്ടിനായുള്ള സംയോജിത പാർസർ
parseInput :: Parser (Regs, Prog)
parseInput = do
  regs <- parseRegs
  prog <- parseProg
  return (regs, prog)

runProg :: Prog -> Regs -> [Int]
runProg prog regs = reverse out
  where
    progLen = length prog
    notDone (_, _, ip) = ip < progLen
    exec (regs', out, ip) =
      let (opCode, operand) = prog !! ip
          func = opFuncs !! opCode
       in func regs' out operand ip
    (_, out, _) = head $ dropWhile notDone $ iterate exec (regs, [], 0)

cycleFunc :: Int -> Int
cycleFunc a =
  let b1 = a .&. 7
      b2 = b1 `xor` 5
      c = a `shiftR` b2
      b3 = b2 `xor` 6
      a' = a `shiftR` 3
      b4 = b3 `xor` c
   in b4 .&. 7

dfs :: [Int] -> [Int]
dfs prog = concatMap (\a -> findPath a 10 a (tail prog)) initialSet
  where
    possibleAs :: Map Int [Int]
    possibleAs = Map.fromListWith (++) [(cycleFunc a, [a]) | a <- [0 .. 1023]]

    initialSet :: [Int]
    initialSet = case prog of
      [] -> []
      (x : _) -> Map.findWithDefault [] x possibleAs

    findPath :: Int -> Int -> Int -> [Int] -> [Int]
    findPath path pathI cur [] =
      if (cur `shiftR` 3) == 0 then [path] else []
    findPath path pathI cur (t : ts) =
      let cur' = cur `shiftR` 3
          candidates = Map.findWithDefault [] t possibleAs
          matches = filter (\a0 -> (a0 .&. 0x7F) == cur') candidates
       in concatMap
            ( \a ->
                let newA = (a `shiftR` 7) .&. 0x7
                    newPath = path .|. (newA `shiftL` pathI)
                 in findPath newPath (pathI + 3) a ts
            )
            matches

main :: IO ()
main = do
  content <- readFile "data17.txt"
  case parse parseInput "" content of
    Left err -> print err
    Right (regs, prog) -> do
      putStr "Part 1: "
      putStrLn $ intercalate "," $ map show $ runProg prog regs
      let flatProg = concat [[x, y] | (x, y) <- prog]
      putStrLn $ "Part 2: " ++ show (minimum (dfs flatProg))

import Control.Monad
import Control.Monad.ST
import Data.Array
import Data.Array.ST
import Data.Foldable (toList)
import qualified Data.Map as Map
import Data.Maybe (isJust)
import Data.Sequence (Seq (..), (|>))
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Debug.Trace
import System.IO
import System.IO.Unsafe (unsafePerformIO)

readPair s =
  let (pre, _ : post) = break (== ',') s
   in (read post, read pre) -- x,y എന്നത് i,j ആയി മാറ്റുക

printGrid grid = do
  let ((iMin, jMin), (iMax, jMax)) = bounds grid
  mapM_
    ( \i -> do
        mapM_ (\j -> putStr [grid ! (i, j)]) [jMin .. jMax]
        putStrLn ""
    )
    [iMin .. iMax]

bfs grid start target = bfs' (Seq.singleton (start, 0)) Set.empty
  where
    bfs' Seq.Empty _ = Nothing
    bfs' ((current@(i, j), len) :<| rest) visited
      | current == target = Just len
      | current `Set.member` visited = bfs' rest visited
      | otherwise =
          bfs' (rest <> Seq.fromList neighbors) (Set.insert current visited)
      where
        neighbors = [((i + di, j + dj), len + 1) | (di, dj) <- directions, inBounds (i + di, j + dj), grid ! (i + di, j + dj) /= '#']
        inBounds (i, j) =
          let ((minI, minJ), (maxI, maxJ)) = bounds grid
           in i >= minI && i <= maxI && j >= minJ && j <= maxJ

directions = [(-1, 0), (1, 0), (0, -1), (0, 1)]

showPair (i, j) = show j ++ "," ++ show i

main = do
  content <- readFile "data18.txt"
  let pairs = map readPair (lines content)
  let (m, n) = (71, 71)
  let nPairs = 1024
  let gridInit = listArray ((0, 0), (m - 1, n - 1)) ['.' | i <- [0 .. m - 1], j <- [0 .. n - 1]]
  let grid = gridInit // [(p, '#') | p <- (take nPairs pairs)]
  case bfs grid (0, 0) (m - 1, n - 1) of
    Just len -> putStrLn $ "ഭാഗം 1: " ++ (show len)
    Nothing -> error "പുറത്തേക്കുള്ള വഴി കണ്ടെത്താൻ കഴിഞ്ഞില്ല"

  let total = length pairs
  let restPairs = drop nPairs pairs
  let grids = scanl addObstacle (head restPairs, grid) (zip [1025 ..] (tail restPairs))
        where
          addObstacle (_, g) (n, p) = unsafePerformIO $ do
            putStr $ "\r" ++ show n ++ "/" ++ show total ++ " ജോഡികൾ ചേർത്തു"
            hFlush stdout
            return (p, g // [(p, '#')])
  let result = (showPair . fst . head) $ dropWhile (\(_, g) -> isJust $ bfs g (0, 0) (m - 1, n - 1)) grids
  putStrLn ""
  print $ result

import Control.Monad (void)
import qualified Control.Monad.State as S
import Data.List (isPrefixOf)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Text.Parsec
import Text.Parsec.String (Parser)

type Pattern = String

type Towel = String

type Cache = Map.Map String Bool

parsePatternOrTowel :: Parser String
parsePatternOrTowel = many1 (noneOf ", \n")

parsePatterns :: Parser [Pattern]
parsePatterns = parsePatternOrTowel `sepBy` (char ',' <* spaces)

parseTowels :: Parser [Towel]
parseTowels = many1 (parsePatternOrTowel <* spaces)

parseInput :: Parser ([Pattern], [Towel])
parseInput = do
  patterns <- parsePatterns
  void newline
  void newline
  towels <- parseTowels
  return (patterns, towels)

main :: IO ()
main = do
  content <- readFile "data19.txt"
  case parse parseInput "" content of
    Left err -> print err
    Right (patterns, towels) -> do
      putStrLn $ "Part 1: " ++ (show $ length $ filter (\t -> countPossible patterns t > 0) towels)
      putStrLn $ "Part 2: " ++ (show $ sum $ map (countPossible patterns) towels)

countPossible patterns towel = S.evalState (go patterns towel) Map.empty
  where
    go _ "" = return 1
    go patterns towel = do
      cache <- S.get
      case Map.lookup towel cache of
        Just result -> return result
        Nothing -> do
          let cands = filter (`isPrefixOf` towel) patterns
          let checkCandidate p = go patterns (drop (length p) towel)
          result <- sum <$> mapM checkCandidate cands
          S.modify (Map.insert towel result)
          return result

import Control.Monad
import Data.Array
import qualified Data.Map as Map
import Data.Sequence (Seq (..), (|>))
import qualified Data.Sequence as Seq
import qualified Data.Set as Set

inBounds grid (i, j) =
  let ((minI, minJ), (maxI, maxJ)) = bounds grid
   in i >= minI && i <= maxI && j >= minJ && j <= maxJ

distanceFrom grid start = go (Seq.singleton (start, 0)) Set.empty Map.empty
  where
    go Seq.Empty _ dists = listArray (bounds grid) (map (\i -> Map.findWithDefault maxBound i dists) (indices grid))
    go ((pos@(i, j), d) :<| rest) seen dists
      | pos `Set.member` seen = go rest seen dists
      | otherwise = go (rest <> Seq.fromList (neighbors grid pos)) (Set.insert pos seen) (Map.insert pos d dists)
      where
        neighbors grid (i, j) =
          [((i + di, j + dj), d + 1) | (di, dj) <- directions, inBounds grid (i + di, j + dj), grid ! (i + di, j + dj) /= '#']

distWithSkip grid distFromStart distToEnd (skipStart, skipEnd, skipLen) =
  distFromStart ! skipStart + skipLen + distToEnd ! skipEnd

directions = [(-1, 0), (1, 0), (0, -1), (0, 1)]

findPaths grid maxDist start = bfs' [] (Seq.singleton (start, 0)) Set.empty
  where
    bfs' acc Seq.Empty _ = acc
    bfs' acc ((current@(i, j), len) :<| rest) visited
      | len > maxDist = bfs' acc rest (Set.insert current visited)
      | current `Set.member` visited = bfs' acc rest visited
      | otherwise =
          let acc' = if grid ! current /= '#' then ((current, len) : acc) else acc
           in bfs' acc' (rest <> Seq.fromList neighbors) (Set.insert current visited)
      where
        neighbors = [((i + di, j + dj), len + 1) | (di, dj) <- directions, inBounds grid (i + di, j + dj)]

barriers grid cheatTime =
  let allPaths = [pos | (pos, x) <- assocs grid, x /= '#']
      reachablePaths = findPaths grid cheatTime
   in [(s, e, l) | s <- allPaths, (e, l) <- reachablePaths s]

gridFind grid target = head [pos | (pos, x) <- assocs grid, x == target]

computeSavings grid cheatTime thresh =
  let start = gridFind grid 'S'
      end = gridFind grid 'E'
      fromStart = distanceFrom grid start
      toEnd = distanceFrom grid end
      origTime = fromStart ! end
      possibleSkips = barriers grid cheatTime
      savings = map ((\x -> origTime - x) . distWithSkip grid fromStart toEnd) possibleSkips
      validSavings = filter (>= thresh) savings
   in length validSavings

main = do
  content <- readFile "data20.txt"
  let contentLines = lines content
  let (m, n) = (length contentLines, length $ head contentLines)
  let grid = listArray ((0, 0), (m - 1, n - 1)) (concat contentLines)
  let cheatTime = 2 :: Int
  let thresh = 100
  putStrLn $ "ഭാഗം 1: " ++ (show $ computeSavings grid cheatTime thresh)
  let cheatTime2 = 20
  putStrLn $ "ഭാഗം 2: " ++ (show $ computeSavings grid cheatTime2 thresh)

import Data.Char (isDigit)
import Data.IORef
import Data.List (zip4)
import Data.Map (Map)
import qualified Data.Map as M
import System.IO.Unsafe (unsafePerformIO)

type Keypad = [String]

type Pos = (Int, Int)

dirKeypad :: Keypad
dirKeypad = [".^A", "<v>"]

dirKeypadInv :: Map Char Pos
dirKeypadInv = buildInv dirKeypad

keypad :: Keypad
keypad = ["789", "456", "123", ".0A"]

keypadInv :: Map Char Pos
keypadInv = buildInv keypad

buildInv :: Keypad -> Map Char Pos
buildInv kp =
  M.fromList
    [ (c, (r, cx))
    | (r, row) <- zip [0 ..] kp,
      (cx, c) <- zip [0 ..] row
    ]

inBounds :: Keypad -> Pos -> Bool
inBounds kp (r, c) = r >= 0 && r < length kp && c >= 0 && c < length (head kp)

neighbors :: Keypad -> Pos -> [(Pos, Char)]
neighbors kp (r, c) =
  let ds = [(0, 1), (0, -1), (1, 0), (-1, 0)]
      dch = ['>', '<', 'v', '^']
   in [ ((r + dr, c + dc), ch)
      | ((dr, dc), ch) <- zip ds dch,
        inBounds kp (r + dr, c + dc),
        (kp !! (r + dr)) !! (c + dc) /= '.'
      ]

getDirections :: Keypad -> Pos -> Pos -> [String]
getDirections kp start target = bfs [(start, "")]
  where
    bfs [] = error "No path found"
    bfs q =
      let found = [path | (p, path) <- q, p == target]
       in if not (null found)
            then found
            else
              let nxt =
                    [ (npos, path ++ [dir])
                    | (pos, path) <- q,
                      (npos, dir) <- neighbors kp pos
                    ]
               in bfs nxt

getCodeDirections :: Keypad -> Map Char Pos -> Pos -> String -> [String]
getCodeDirections kp kpinv st keys =
  let sc = (kp !! fst st) !! snd st
   in foldl
        ( \dirs (sK, tK) ->
            let nds = getDirections kp (kpinv M.! sK) (kpinv M.! tK)
             in [d ++ nd ++ "A" | d <- dirs, nd <- nds]
        )
        [""]
        (zip (sc : keys) keys)

{-# NOINLINE memoMap #-}
memoMap :: IORef (Map (Pos, Pos, Int) Int)
memoMap = unsafePerformIO (newIORef M.empty)

shortestDirectionsPairwise :: Pos -> Pos -> Int -> Int
shortestDirectionsPairwise start end depth = unsafePerformIO $ do
  m <- readIORef memoMap
  case M.lookup (start, end, depth) m of
    Just v -> return v
    Nothing -> do
      let dirs = getDirections dirKeypad start end
          dirsAct = map (++ "A") dirs
      let val =
            if depth == 1
              then minimum (map length dirsAct)
              else
                let ps = map (\d -> zip ('A' : d) d) dirsAct
                 in minimum
                      [ sum
                          [ shortestDirectionsPairwise
                              (dirKeypadInv M.! sC)
                              (dirKeypadInv M.! eC)
                              (depth - 1)
                          | (sC, eC) <- pair
                          ]
                      | pair <- ps
                      ]
      writeIORef memoMap (M.insert (start, end, depth) val m)
      return val

shortestPath :: String -> Int -> Int
shortestPath code padDepth =
  let initDirs = getCodeDirections keypad keypadInv (3, 2) code
   in minimum $
        map
          ( \d ->
              let pairs = zip ('A' : d) d
               in sum
                    [ shortestDirectionsPairwise
                        (dirKeypadInv M.! sC)
                        (dirKeypadInv M.! eC)
                        padDepth
                    | (sC, eC) <- pairs
                    ]
          )
          initDirs

parseNum :: String -> Int
parseNum = read . filter isDigit

part1 :: [String] -> Int
part1 codes =
  let nums = map parseNum codes
      lens = map (`shortestPath` 2) codes
   in sum (zipWith (*) nums lens)

part2 :: [String] -> Int
part2 codes =
  let nums = map parseNum codes
      lens = map (`shortestPath` 25) codes
   in sum (zipWith (*) nums lens)

input :: String
input =
  unlines
    [ "789A",
      "968A",
      "286A",
      "349A",
      "170A"
    ]

main :: IO ()
main = do
  let args = lines input
  print (part1 args)
  print (part2 args)