2016 Round 1B

Getting the Digits

Some spelled-out digits contain unique letters. For example, only "ZERO" contains the letter "Z". Thus so long as we see a "Z", we know we can remove "ZERO" from the input and append "0" to the output.

After handling these cases, we find that the remaining spelled-out digits now contain unique letters. For example, once we have rmeoved all "FOUR" strings from the input, the presence of an "F" can only indicate "FIVE".

import Data.List
import Jam

main = jam $ concatMap show . sort . f [] <$> gets

f a "" = a
f a s  | 'Z' `elem` s = f (0:a) $ s \\ "ZERO"
       | 'W' `elem` s = f (2:a) $ s \\ "TWO"
       | 'X' `elem` s = f (6:a) $ s \\ "SIX"
       | 'U' `elem` s = f (4:a) $ s \\ "FOUR"
       | 'G' `elem` s = f (8:a) $ s \\ "EIGHT"
       | 'F' `elem` s = f (5:a) $ s \\ "FIVE"
       | 'V' `elem` s = f (7:a) $ s \\ "SEVEN"
       | 'O' `elem` s = f (1:a) $ s \\ "ONE"
       | 'N' `elem` s = f (9:a) $ s \\ "NINE"
       | otherwise    = f (3:a) $ s \\ "THREE"

I could have written the function more succinctly, but in contest conditions I found it was easiest to copy and paste, and edit the changes from line to line by hand.

Close Match

Brute force works great for the small input. We generate a list of all possibilities from replacing each "?" with each digit, which can be expressed succinctly with Haskell’s list monad.

Tuples are automatically sorted by the first element and then the second, which we exploit so our code picks the preferred minimum when there are multiple possibilities.

import Data.List
import Data.Ord
import Jam

main = jam $ do
  [x, y] <- map (mapM expand) . words <$> gets
  pure $ unwords [minimumBy (comparing (\a -> (diff y a, a))) x,
                  minimumBy (comparing (\a -> (diff x a, a))) y]

diff as b = minimum $ abs . (read b -) . read <$> as

expand '?' = ['0'..'9']
expand d   = [d]

A little recursion solves the large input. We start from the most-significant character of both scores and work our way to the least-significant digits.

If neither of the current character in each score is a question mark, then we simply move on to the next character. Otherwise, at least one of the current char is a question mark. If the parts of the scores we have already processed differ, then our job is easy: to make the final score as close a possible, we replace "?" with "9" for the losing side, and with "0" for the winning side.

This leaves the tough case: the digits of both scores we’ve seen so far match exactly. We lack information to make the right decision, because we have yet to reach to digits of lower significance. Fortunately, there’s only a few possibilities, and we can simply try them all. To be as close as possible, we should choose so the digits of both scores are the same or one apart.

If we can choose both digits, that is, both are ?", then we should try 0 for both, 0 for the Coders and 1 for the Jammers, then lastly 1 for the Coders and 0 for the Jammers, so that we find the preferred minimum when there are multiple possibilities.

If one of the digits is known to be d while the other is "?", then we try [d - 1, d, d + 1] in that order, again so we find the preferred minimum when there are multiple possibilities.

We rely on the minimum library function to return the first minimum found.

import Data.Char
import Data.Bool
import Data.List
import Data.Ord
import Jam

main = jam $ unwords . f ["", ""] . words <$> gets

f acc    ["", ""]        = acc
f [a, b] [x:xs, y:ys]
  | x /= '?' && y /= '?' = c x   y
  | a < b                = c '9' '0'
  | a > b                = c '0' '9'
  | otherwise            = g [a, b] [x:xs, y:ys]
  where c i j = f [a ++ [bool x i (x == '?')],
                   b ++ [bool y j (y == '?')]] [xs, ys]

g [a, b] [x:xs, y:ys]
  | x == '?' && y == '?' = minDiff [c '0' '0', c '0' '1', c '1' '0']
  | y /= '?'             = minDiff [c y' y  | y' <- smear y]
  | x /= '?'             = minDiff [c x  x' | x' <- smear x]
  where c i j = f [a ++ [i], b ++ [j]] [xs, ys]

minDiff = minimumBy $ comparing $ \[a, b] -> abs (read a - read b)

smear c = filter isDigit $ chr <$> [ord c - 1..ord c + 1]


Brute force works well on the small input. The subsequences function conveniently enumerates all subsets of the topics. We take each one in turn, and see if can generate the other topics, and return the length of the largest such subset.

import Data.List
import Jam

main = jam $ do
  [n] <- getints
  es <- map words <$> getsn n
  pure $ show $ maximum [length s | s <- subsequences es, all (f $ es \\ s) s]

f []   topic = False
f real topic = not (null a || null b) && a /= b
  where [a, b] = zipWith elemIndices topic $ transpose real

In my haste, my eye had skipped over the line stipulating that first words are always used as first words and similarly for second words. Luckily the small input caught this, so I was able to correct my program for the large input.

As for the large input, we observe we have a bipartite graph, with the first words on one side and the second words on the other. Then if we take the topics corresponding to a maximal matching (which cover two vertices each), along with one topic for each of the unmatched vertices, we can generate all the other topics. A little thought shows this is optimal, that is, this minimizes the number of real topics.

During the contest, I was unable to find a well-known Haskell library that performs bipartite matching. I began coding one, but I soon decided it would be faster to download code posted to the Haskell-cafe mailing list [see accompanying message]. It worked well for my solution:

import Data.List
import qualified Data.Map as M
import qualified Data.Set as S
import Jam
import MaxMatching

main = jam $ do
  [n] <- getints
  es <- map words <$> getsn n
    vcount = sum $ length . nub <$> transpose es
    matched = M.size $ matching $ S.fromList $ (\[a, b] -> (a, b)) <$> es
  pure $ show $ n - vcount + matched

I do intend to write my own bipartite matching routine in Haskell some day, as it is good exercise.

Ben Lynn blynn@cs.stanford.edu 💡