Code Jam 2021 round 1A’s problem B, “Prime Time”, asks us to split a bag of prime numbers in two non-empty parts such that the sum of the numbers in one part is equal to the product of the numbers in the other part. Maximizing that sum/product if multiple are feasible; detecting infeasibility.

Original content warning: nobody solved it in Haskell during the event, so you won’t find a solution by browsing the site.

The noteworthy problem structure here is the fact the numbers on the cards are all prime. So given a hand’s value, we can directly deduce which cards are a part of the product counterpart: the fundamental theorem of arithmetic guarantees there’s only one possibility.

A given hand can have up to 10¹⁵ cards, but the cards’ values are restricted to the 95 distinct primes smaller than 500. We’ve got an easy upper bound for a hand value as the sum of all cards: Σ = 5 × 10¹⁷. Without a lower bound, that’s a bit much to consider searching. And the problem lets the door open to there not being a solution, so we’d actually have to check all of them to know. Intractable.

The difference between Σ and the hand value happens to be the sum of the cards not in the sum part. So the sum of the primes in the product part. What’s the largest that sum can get? It’s easy to think the same bound as above applies—truth be told, it does… it’s just not very useful. But broad strokes can give us an idea: we can’t need any more than log₂Σ ≤ 59 cards, any multiplication above that exceeds the maximum possible hand value. And primes can be up to 499, so the maximum sum of the primes in the product part is 59 × 499 = 29441.

Sounds like a plan. We can iterate on candidate hand values from Σ down to Σ − 29441, and check whether it’s an actual solution. It’s an actual solution if we can construct a split on it. The cards in the product side are given by factoring the candidate. The cards in the sum part are the remaining ones. It’s a valid split if they’re equal, so we’d still need verify that.

How efficiently do we need to factor? We already know which primes are possible.¹ So we can simply divide by them until we reach 1. It sounds scary because we can have up to 10¹⁵ cards, but remember 60 cards/divisions exceeds it. So our factoring only needs to attempt division 60 + 95 = 155 times.

We’ve got a 155 × 39441 ≈ 4, 5 × 10⁶-division solution. Seems tractable. Let’s implement.

Cards are provided as (prime,count) pairs.

type Factor = (Int,Int)
readPair :: String -> Factor
readPair l = (a,b) where [a,b] = map read (words l)

Now to factor.

factor :: [Factor] -> Int -> Maybe [Factor]
factor = go where
  go _ i | i < 1 = Nothing
  go _ 1         = Just []
  go [] _        = Nothing
  go ((p,c):ps) i =
    let qrs = takeWhile ((== 0) . snd) $ tail $ iterate ((`divMod` p) . fst) (i,0)
    in case qrs of
         [] -> go ps i
         fs | c' <- length fs ->  
                if c' <= c
                then fmap ((p,c') :) (go ps (fst (last fs)))
                else Nothing

No overthinking. For each (prime,count) pair, generate a chain of (quotient,zero remainder) pairs; if it’s fewer than count long, move on to the next prime. This ensures factoring only succeeds if it’s possible to generate the product part of the pair.

Solving is then just a matter of attempting to factor the specific subset of the space we’re interested in, and verifying the sum of the remaining factors is the same as the product.

solve :: [Factor] -> Maybe Int
solve fs = find isSol [total-2,total-3..total-bound*fst (last fs)]
  where total = fSum fs
        bound = ceiling $ logBase (fromIntegral (fst (head fs)))
                                  (fromIntegral total :: Double)
        isSol s | Just ps@(_:_) <- factor fs s = total - fSum ps == s 
        isSol _ = False
        fSum = sum . map (uncurry (*))

As a minor optimization, I skipped the two highest values from Σ (split parts can’t be empty), and computed a finer bound by taking into account the provided primes instead of the statement worst cases.

A main wrapper and we’re done.

main :: IO ()
main = do
  t <- readLn :: IO Int
  forM_ [1..t] $ \i -> do
    m <- readLn
    ps <- replicateM m (readPair <$> getLine)
    putStrLn $ "Case #" ++ show i ++ ": " ++ maybe "0" show (solve ps)

This concludes today’s solution. The full code is on github.