115 lines
2.8 KiB
Haskell
115 lines
2.8 KiB
Haskell
|
{-# options_ghc -Wall #-}
|
|||
|
|
{-# language BlockArguments #-}
|
|||
|
|
import Data.List
|
|||
|
|
import System.Environment
|
|||
|
|
import qualified Data.Map as M
|
|||
|
|
import Data.Maybe
|
|||
|
|
|
|||
|
|
|
|||
|
|
data Block = Rock | Space | Wall deriving (Eq, Ord, Show)
|
|||
|
|
|
|||
|
|
block :: Char -> Maybe Block
|
|||
|
|
block 'O' = Just Rock
|
|||
|
|
block '.' = Just Space
|
|||
|
|
block '#' = Just Wall
|
|||
|
|
block _ = Nothing
|
|||
|
|
|
|||
|
|
type Board = [[Block]]
|
|||
|
|
|
|||
|
|
board :: String -> Board
|
|||
|
|
board = map (map block') . lines where
|
|||
|
|
block' :: Char -> Block
|
|||
|
|
block' c = fromMaybe (error $ "unrecognised " ++ show c) $ block c
|
|||
|
|
|
|||
|
|
chunks :: (a -> Bool) -> [a] -> [[a]]
|
|||
|
|
chunks _ [] = []
|
|||
|
|
chunks want (x : xs)
|
|||
|
|
| want x = let (as, bs) = span want xs in (x : as) : chunks want bs
|
|||
|
|
| otherwise = let (as, bs) = break want xs in (x : as) : chunks want bs
|
|||
|
|
|
|||
|
|
fall :: Ord a => (a -> Bool) -> [a] -> [a]
|
|||
|
|
fall p = concat . map sort . chunks p
|
|||
|
|
|
|||
|
|
rotateLeft :: [[a]] -> [[a]]
|
|||
|
|
rotateLeft = transpose . map reverse
|
|||
|
|
|
|||
|
|
rotateRight :: [[a]] -> [[a]]
|
|||
|
|
rotateRight = map reverse . transpose
|
|||
|
|
|
|||
|
|
rotate180 :: [[a]] -> [[a]]
|
|||
|
|
rotate180 = reverse . map reverse
|
|||
|
|
|
|||
|
|
fallLeft, fallUp, fallRight, fallDown :: Board -> Board
|
|||
|
|
fallLeft = map $ fall (/= Wall)
|
|||
|
|
fallUp = rotateRight . fallLeft . rotateLeft
|
|||
|
|
fallRight = rotate180 . fallLeft . rotate180
|
|||
|
|
fallDown = rotateLeft . fallLeft . rotateRight
|
|||
|
|
|
|||
|
|
scoreWith :: (a -> Bool) -> [[a]] -> Int
|
|||
|
|
scoreWith p xss =
|
|||
|
|
let ℓ = length xss; ℓs = [ℓ, ℓ-1 .. 0] in
|
|||
|
|
sum $ zipWith (\xs y -> length (filter p xs) * y) xss ℓs
|
|||
|
|
|
|||
|
|
score :: Board -> Int
|
|||
|
|
score = scoreWith (== Rock)
|
|||
|
|
|
|||
|
|
part1 :: Board -> Int
|
|||
|
|
part1 = score . fallUp
|
|||
|
|
|
|||
|
|
type Cycle = (Board, Board, Board, Board)
|
|||
|
|
|
|||
|
|
cycle1 :: Board -> Cycle
|
|||
|
|
cycle1 xs =
|
|||
|
|
let as = fallUp xs
|
|||
|
|
bs = fallLeft as
|
|||
|
|
cs = fallDown bs
|
|||
|
|
ds = fallRight cs in
|
|||
|
|
(as, bs, cs, ds)
|
|||
|
|
|
|||
|
|
nextCycle :: Cycle -> Cycle
|
|||
|
|
nextCycle (_, _, _, xs) = cycle1 xs
|
|||
|
|
|
|||
|
|
cycles :: Board -> [Cycle]
|
|||
|
|
cycles start = let c = cycle1 start in iterate nextCycle c
|
|||
|
|
|
|||
|
|
fourth :: (a,b,c,d) -> d
|
|||
|
|
fourth (_,_,_,d) = d
|
|||
|
|
|
|||
|
|
findRepeat :: Ord a =>
|
|||
|
|
M.Map a Int -> M.Map Int a ->
|
|||
|
|
Int -> [a] -> (Int, Int, M.Map Int a)
|
|||
|
|
findRepeat ai ia i (a:as)
|
|||
|
|
| Just j <- M.lookup a ai = (j, i, ia)
|
|||
|
|
| otherwise = findRepeat ai' ia' (i + 1) as
|
|||
|
|
where ai' = M.insert a i ai; ia' = M.insert i a ia
|
|||
|
|
findRepeat _ _ _ _ = error "you said it was infinite"
|
|||
|
|
|
|||
|
|
part2 :: Board -> Int
|
|||
|
|
part2 ℓs =
|
|||
|
|
let loops = 1_000_000_000
|
|||
|
|
(m, n, xs) = findRepeat M.empty M.empty 0 $ cycles ℓs
|
|||
|
|
index = (loops - n) `mod` (n - m) - 1 in
|
|||
|
|
score $ fourth $ xs M.! (m + index)
|
|||
|
|
|
|||
|
|
main :: IO ()
|
|||
|
|
main = do
|
|||
|
|
[part, file] <- getArgs
|
|||
|
|
ℓs <- board <$> readFile file
|
|||
|
|
case part of
|
|||
|
|
"1" -> print $ part1 ℓs
|
|||
|
|
"2" -> print $ part2 ℓs
|
|||
|
|
_ -> error "usage: $0 <part> <file>"
|
|||
|
|
|
|||
|
|
example1 :: [String]
|
|||
|
|
example1 =
|
|||
|
|
["O....#....",
|
|||
|
|
"O.OO#....#",
|
|||
|
|
".....##...",
|
|||
|
|
"OO.#O....O",
|
|||
|
|
".O.....O#.",
|
|||
|
|
"O.#..O.#.#",
|
|||
|
|
"..O..#O..O",
|
|||
|
|
".......O..",
|
|||
|
|
"#....###..",
|
|||
|
|
"#OO..#...."]
|