82 lines
2.3 KiB
Haskell
82 lines
2.3 KiB
Haskell
import Prelude
|
|
import Data.List.Split (splitOn)
|
|
import qualified Data.Map.Lazy as M
|
|
import Data.Map.Lazy ((!))
|
|
import GHC.IO (unsafePerformIO)
|
|
import Control.DeepSeq (deepseq)
|
|
|
|
data Tile = Wall | Sand
|
|
deriving (Eq)
|
|
|
|
instance Show Tile where
|
|
show Wall = "#"
|
|
show Sand = "o"
|
|
|
|
type Pos = (Int, Int)
|
|
type Grid a = M.Map Pos a
|
|
|
|
(!!!) :: Grid a -> Pos -> a
|
|
(!!!) = (!)
|
|
|
|
-- parsing time...
|
|
|
|
writeWall :: Grid Tile -> [Pos] -> Grid Tile
|
|
writeWall startGrid positions = snd $ foldl (\(oldPos, grid) newPos -> (newPos, writeWall' grid (oldPos, newPos))) (head positions, startGrid) positions
|
|
where
|
|
writeWall' :: Grid Tile -> (Pos, Pos) -> Grid Tile
|
|
writeWall' grid ((x1, y1), (x2, y2)) = grid `M.union` wallsGrid
|
|
where
|
|
wallsGrid = M.fromList $ concatMap (\y -> map (\x -> ((x, y), Wall)) [minX .. maxX]) [minY .. maxY]
|
|
minX = min x1 x2
|
|
minY = min y1 y2
|
|
maxX = max x1 x2
|
|
maxY = max y1 y2
|
|
|
|
writeWalls :: [[Pos]] -> Grid Tile
|
|
writeWalls = foldl writeWall M.empty
|
|
|
|
parsePos :: String -> Pos
|
|
parsePos p = (read $ split !! 0, read $ split !! 1)
|
|
where split = splitOn "," p
|
|
|
|
parseWall :: String -> [Pos]
|
|
parseWall = map parsePos . splitOn " -> "
|
|
|
|
{-# NOINLINE debug #-}
|
|
debug :: Show a => a -> ()
|
|
debug = unsafePerformIO . print
|
|
|
|
trace :: Show b => b -> a -> a
|
|
trace s = deepseq (debug s)
|
|
|
|
sandPos = (500, 0)
|
|
|
|
dropSand :: Grid Tile -> Maybe (Grid Tile)
|
|
dropSand grid = case sandGrain of
|
|
(Just pos) -> Just $ grid `M.union` M.singleton pos Sand
|
|
Nothing -> Nothing
|
|
where
|
|
sandGrain = resolveSand sandPos
|
|
groundY = maxY + 2
|
|
maxY = maximum $ map snd $ M.keys $ M.filter (== Wall) grid
|
|
|
|
resolveSand :: Pos -> Maybe Pos
|
|
resolveSand (x, y)
|
|
| y >= (groundY - 1) = Just (x, y)
|
|
| null validPositions && (x, y) == sandPos = Nothing
|
|
| null validPositions = Just (x, y)
|
|
| otherwise = resolveSand $ head validPositions
|
|
where
|
|
validPositions = filter (not . (`M.member` grid)) [(x, y + 1), (x - 1, y + 1), (x + 1, y + 1)]
|
|
|
|
repeatUntilNothing :: (a -> Maybe a) -> a -> a -> a
|
|
repeatUntilNothing f previous input = case f input of
|
|
Just x -> repeatUntilNothing f input x
|
|
Nothing -> previous
|
|
|
|
main = interact $
|
|
show
|
|
. (+ 2) . length . M.filter (== Sand)
|
|
. (\grid -> repeatUntilNothing dropSand grid grid)
|
|
. writeWalls
|
|
. map parseWall . lines |