2009 Qualification Round
We can employ a disjoint-set library to do the heavy lifting. For each cell, we determine the water flows to one of the neighbouring cells. If so, we put them in the same disjoint set.
Afterwards, we make another pass with mapAccumL from top to bottom, left to right, assigning the successive letters of the alphabet to disjoint sets and also emitting these letters. A map keeps track of the disjoint sets have already been given a letter.
Our code assumes minimumBy returns the first minimum of the input list.
import Data.Array import Data.Ord import Data.List import Data.List.Split import qualified Data.Map as M import Data.Partition import Jam nwes = [(-1, 0), (0, -1), (0, 1), (1, 0)] add (a, b) (c, d) = (a + c, b + d) main = jam $ do [h, w] <- getints a <- listArray ((1, 1), (h, w)) . concat <$> getintsn h let flow p i | null nbrs = p | otherwise = joinElems i (minimumBy (comparing (a!)) nbrs) p where nbrs = [j | j <- add i <$> nwes, bounds a `inRange` j, a!j < a!i] p = foldl' flow empty $ indices a f (m, c:cs) r | r `M.member` m = ((m, c:cs), m M.! r) | otherwise = ((M.insert r c m, cs), c) s = snd $ mapAccumL f (M.empty, ['a'..]) $ rep p <$> indices a pure $ concatMap ('\n':) $ intersperse ' ' <$> chunksOf w s
As an exercise, we also solve the problem in a classic imperative style. We initialize an array consisting of "?" to represent yet-to-be-assigned letters, a list of the unassigned letters, which initially is the lowercase alphabet.
We iterate through the array, top to bottom, left to right, and each time we come across an unassigned cell, we simulate water flow according to the problem descriptions. If we reach a letter, then we fill all cells in the flow with that letter, If we reach a "?" we assign the next available letter of the alphabet to all cells in the flow.
Thus for each cell, we either know the corresponding letter beforehand, or we figure it out on the fly.
We need a cryptic type declaration for the mutable array.
import Control.Monad.ST import Data.Array import Data.Array.ST import Data.Ord import Data.List import Data.STRef import Jam nwes = [(-1, 0), (0, -1), (0, 1), (1, 0)] add (a, b) (c, d) = (a + c, b + d) main = jam $ do [h, w] <- getints as <- listArray ((1, 1), (h, w)) . concat <$> getintsn h pure $ concatMap (('\n':) . intersperse ' ') $ runST $ do abc <- newSTRef ['a'..'z'] t <- newListArray ((1, 1), (h, w)) $ repeat '?' :: ST s (STUArray s (Int, Int) Char) let f i = readArray t i >>= g where nbrs = [j | j <- add i <$> nwes, bounds as `inRange` j, as!j < as!i] g '?' | null nbrs = do (x:xs) <- readSTRef abc writeSTRef abc xs writeArray t i x return x | otherwise = f $ minimumBy (comparing (as!)) nbrs g ch = pure ch sequence [sequence [f (r, c) | c <- [1..w]] | r <- [1..h]]
On reading this problem, the phrase “common subsequneces” comes to mind, which suggests we should seek a recursion for a solution using dynamic programming.
Let w be the string "welcome to code jam", and let s be the input string. We define f (n, k) to be the number of ways we can find the letters of drop k w as a subsequence of drop n s,
When k == length w, there is exactly one way to find no letters in drop n s. Otherwise, if n == length s then we have reached the end of s so there is no way to find the remaining letters.
Otherwise, we can look for drop k w in drop (n + 1) s, and if s!!n == w!!k, then we can also look for drop (k + 1) w in drop (n + 1) s:
We use Data.MemoTrie to memoize to make this efficient.
import Jam import Data.MemoTrie import Text.Printf w = "welcome to code jam" main = jam $ do s <- gets let f (n, k) | k == length w = 1 :: Int | n == length s = 0 | s!!n /= w!!k = g (n+1, k) | otherwise = (g (n+1, k) + g (n+1, k+1)) `mod` 10000 g = memo f return $ printf "%04d" $ f (0, 0)
The code is terser if we refer to lists instead of their indexes, but this interacts badly with the memoization.
Because we use printf, we need a type declaration somewhere to specify just which numeric type we want.