# 2009 Round 1A

## Multi-base happiness

We’ll skip an brute force solution for the small input, as it is a sub-problem we encounter when solving the large input.

The "Important Note" in the problem description suggests one strategy is to precompute all the answers, because there are only 502 possible inputs, because each input is a subset of [2..10] containing at least two elements.

However, we still need a little ingenuity to find all the happy numbers in a reasonable time.

The only reasonable way to find the smallest happy number in a given set of bases is by trying each number in turn. Even if there were advanced and esoteric mathematical tricks that tell us surprising information about the properties of sums of squares of digits in various bases, it would be unfair to expect a Code Jam contestant to find it within a few hours.

Thus for the worst case, that is, the smallest happy number in all bases [2..10], since we must try each number one by one, the answer must be less than about 10^10. This means the sum of the squares of its digits is at most 810.

Let’s call it an even 1000. For all bases in [2..10], we determine if each number in [1..1000] is happy by brute force, and record the result. Then for any number greater than 1000, we can perform a single summation of its squared digits and one array lookup to see if it ss happy.

To check that 1000 is sufficiently high, we find the minimum happy number for all bases in [2..10], arranging our program to halt with an error message if the limit is exceeded:

import Data.Array

main = print $minHappy [2..10] minHappy bs = head$ filter ((all bs) . happy) [2..]

next n b = sum $(^2) <$> rBase n b

lim = 1000

caches = listArray ((2, 1), (10, lim)) $build [] <$> [2..10] <*> [1..lim]
build _ b 1 = True
build s b n | n elem s = False
| otherwise  = build (n:s) b $next n b rBase 0 _ = [] rBase n b = r : rBase q b where (q, r) = divMod n b happy n b | next n b > lim = error "overflow" | otherwise = caches!(b, next n b) We compute the digit representation in a given base in reverse, due to our use of Haskell lists. We can skip reversing them, because the sum of their squares is the same either way. After about a minute and a half on my laptop, this program prints 11814485, whose sum-of-squared-digits is well within our limit. We can compute a lookup table for all subsets of [2..10] and print it: table = [(bs, show$ minHappy bs) | bs <- subsequences [2..10]]

genMain = print $show table If we then paste the output back into our program into a string named pre, we can solve the large input almost instantly with: import Data.List import Jam main = jam$ fromMaybe undefined . (lookup read pre) <$> getints pre = "..." // Replace with precomputed lookup table. It turns out we could have avoided this dance. Computing the entire table only takes about two and a half minutes on my laptop, so we could have used the following solution instead: import Data.Array import Data.List import Data.Maybe import Jam main = jam$ fromMaybe undefined . (lookup table) <$> getints table = [(bs, show$ minHappy bs) | bs <- subsequences [2..10]]

minHappy bs = head $filter ((all bs) . happy) [2..] next n b = sum$ (^2) <$> rBase n b lim = 1000 caches = listArray ((2, 1), (10, lim))$ build [] <$> [2..10] <*> [1..lim] build _ b 1 = True build s b n | n elem s = False | otherwise = build (n:s) b$ next n b

rBase 0 _ = []
rBase n b = r : rBase q b where (q, r) = divMod n b

happy n b = caches!(b, next n b)

Our instincts may cause us to believe this is a graph search problem, with each corner of each intersection being a node, and the street crossings and sides of blocks being edges. However, the traffic lights mean that the weight of the edges change over time.

We need new ideas. One obvious observation is that we know the minimum time needed to reach our starting point: zero! Also obvious is the minimum time needed to reach the corner in the direction of the green traffic light from our starting point is 1 minute. We can build on this a little: from the 1-minute corner, we know the best times for reaching the next corner along the block is 3 minutes.

Thus we may wonder what we can learn from knowing the minimum time needed to reach a given location. Unfortunately, we quickly see this is too little information. Even if we can walk immediately to a nearby location, how do we know going via our current location is the quickest way?

However, suppose we alter the question slightly. What can we learn from knowing the minimum time to reach all locations that can be reached within t minutes?

This line of thinking leads to us to consider a priority queue where each element is a location p ordered by the minimum known time t needed to reach it. Initially it holds just the starting point and the zero time.

Each iteration, we delete the minimum element (t, p). If p has already been visited, that is, we already deleted an element containing p, then we ignore it. Otherwise, we record that we have visited p, and set the minimum time needed to reach p to t. Next, we compute the time taken to reach the adjacent locations from p, and insert the unvisited ones into the queue.

We can inductively show this method produces the fastest way of reach each location: because p is first deleted when its associated time t is the minimum in the priority queue, there can be no faster way to reach p, for all other ways require first reaching a location further along the priority queue, and hence must take longer.

import Data.Array
import Data.Bool
import Data.List
import Data.List.Split
import qualified Data.PQueue.Min as PQ
import qualified Data.Set as S
import Jam

main = jam $do [n, m] <- getints a <- listArray ((1, 1), (n, m)) . chunksOf 3 . map read . words . unwords <$> getsn n
let
tgt = ((1, m), (-1, 1))
f v q
| p == tgt     = t
| S.member p v = f v q'
| otherwise    = f (S.insert p v) $foldl' (flip PQ.insert) q' nbrs where ((t, p@((x, y), (dx, dy))), q') = PQ.deleteFindMin q [s, w, offset] = a!(x, y) tc = mod (t - offset) (s + w) nbrs = filter (inRange (bounds a) . fst . snd) [ (t + 2, ((x + dx, y), (-dx, dy))) , (t + 2, ((x, y + dy), (dx, -dy))) , (t + bool (s + w - tc + 1) 1 (tc < s), ((x, y), (-dx, dy))) , (t + bool 1 (s - tc + 1) (tc < s), ((x, y), (dx, -dy))) ] pure$ show $f S.empty$ PQ.singleton (0, ((n, 1), (1, -1)))

The words . unwords seems redundant at first glance, but we have a list of strings containing spaces, and we must insert spaces between them when concatenating them before passing the whole lot to words.

The first time I attempted this problem I overlooked that the best solution may involve walking south or west, thus I was unable to pass even the small input.

## Collecting Cards

Despite being worth the most points, this problems seems to be the easiest to code. Or maybe Haskell happens to be especially suitable for these sorts of problems.

If we have all c cards, then we stop buying booster packs, giving an expected value of 0. Otherwise, if we have k < c cards, then we must buy at least one more booster pack to complete the set.

Let f k be the expected number of packs we must buy, and let p k i be the probability that we have i of the c cards after buying one booster pack and having started out with k cards. Then:

f k = 1 + sum [p k i * f i | i <- [0..c]]

We must possess at least k cards after buying one pack, so p k i = 0 for i ← [0..k-1]. Thus we can rearrange to:

f k = 1 / (1 - p k k) *
(1 + sum [p k (k + d) * f (k + d) | d <- [0..c - k]])

It reamins to compute p k (k + d). For each d, we count the number of n-subsets of [1..c] such that d of them are cards are new to us (so the other n - d cards are cards we already own). Then p k (k + d) is this count divided by the number of all n-subsets of [1..c], namely choose c n.

Out of the c - k cards we are missing, there are choose (c - k) d different d-subsets, and of the k cards we already own, there are choose k (n - d) different (n - d)-subsets, so the number of different types of booster packs that increase our collection by d is:

choose (c - k) d * choose k (n - d)

Whence:

import Data.Ratio
import Math.Combinatorics.Exact.Binomial
import Jam

main = jam $do [c, n] <- getintegers let f k | k == c = 0 % 1 | otherwise = 1 / (1 - (choose k n % choose c n)) * (1 + sum [choose (c - k) (i - k) * choose k (n - (i - k)) % choose c n * f i | i <- [k + 1..c]]) pure$ show (fromRational $f 0 :: Double) This suffices for the small input. For the large, we memoize: import Data.MemoTrie import Data.Ratio import Math.Combinatorics.Exact.Binomial import Jam main = jam$ do
[c, n] <- getintegers
let
mf k
| k == c    = 0 % 1
| otherwise = 1 / (1 - (choose k n % choose c n)) *
(1 + sum [choose (c - k) (i - k) *
choose k (n - (i - k)) % choose c n * f i | i <- [k + 1..c]])
f = memo mf
pure $show (fromRational$ f 0 :: Double)

The limits even for the large input are small enough that we could give exact answers in the form of rationals, but the problem asks for a floating-point approximation. To show off, we convert to a double at the last possible moment.

Ben Lynn blynn@cs.stanford.edu 💡