{-# 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..#...."]