62 lines
2.1 KiB
Haskell
62 lines
2.1 KiB
Haskell
import Common hiding (Grid)
|
|
import Data.List (foldl', elemIndices)
|
|
import Data.Maybe (mapMaybe, catMaybes)
|
|
|
|
data Direction = North | West | East | South
|
|
deriving (Eq, Show, Enum)
|
|
|
|
parse :: String -> [Pos]
|
|
parse s = concat $ zipWith (\y l -> map fst $ filter (\(pos, t) -> t == '#') $ zipWith (\x t -> ((x, y), t)) [0..] l) [0..] $ lines s
|
|
|
|
directionOrder = [North, South, West, East]
|
|
|
|
consideredPositions North = [(0, -1), (-1, -1), (1, -1)]
|
|
consideredPositions South = [(0, 1), (-1, 1), (1, 1)]
|
|
consideredPositions West = [(-1, 0), (-1, -1), (-1, 1)]
|
|
consideredPositions East = [(1, 0), (1, -1), (1, 1)]
|
|
|
|
directPosition North = (0, -1)
|
|
directPosition South = (0, 1)
|
|
directPosition West = (-1, 0)
|
|
directPosition East = (1, 0)
|
|
|
|
removeDuplicatesBy :: (Eq b) => (a -> b) -> [a] -> [a]
|
|
removeDuplicatesBy f l = filter (\e -> length (f e `elemIndices` l') == 1) l
|
|
where l' = map f l
|
|
|
|
removeDuplicates :: (Eq a) => [a] -> [a]
|
|
removeDuplicates = removeDuplicatesBy id
|
|
|
|
unwrap :: (a, Maybe b) -> Maybe (a, b)
|
|
unwrap (a, Just b) = Just (a, b)
|
|
unwrap (a, Nothing) = Nothing
|
|
|
|
step :: [Pos] -> Int -> Maybe [Pos]
|
|
step elves round = if null newElves then Nothing else Just movedElves
|
|
where
|
|
movedElves = map snd newElves ++ filter (`notElem` map fst newElves) elves
|
|
|
|
newElves = removeDuplicatesBy snd $ mapMaybe unwrap $ zip elves $ map getElfPosition elves
|
|
|
|
getElfPosition :: Pos -> Maybe Pos
|
|
getElfPosition pos
|
|
| (not $ or positions) || (and positions) = Nothing
|
|
| otherwise = Just firstPos
|
|
where
|
|
firstPos = (pos `addPos`) $ directPosition firstDir
|
|
firstDir = fst $ head $ filter snd $ zip order positions
|
|
positions = map (all ((`notElem` elves) . (pos `addPos`)) . consideredPositions) order
|
|
|
|
order = map ((cycle directionOrder !!) . flip (-) 1 . (+ round)) [0..3]
|
|
|
|
repeatStepUntilStill :: [Pos] -> Int -> Int
|
|
repeatStepUntilStill elves round = case newElves of
|
|
Just e -> repeatStepUntilStill e (round + 1)
|
|
Nothing -> round
|
|
where
|
|
newElves = step elves round
|
|
|
|
main = interact $
|
|
show
|
|
. (\elves -> repeatStepUntilStill elves 1)
|
|
. parse |