Contents

Sudoku Checker

An easy problem. We use a bitset to check each digit appears exactly once, though a set or map would be fine too.

import Jam
import Data.Array
import Data.Bool

main = jam $ do
  [n] <- getints
  a <- listArray ((1, 1), (n^2, n^2)) . concat <$> getintsn (n^2)
  let
    rangeCheck a = and $ (\x -> x >= 1 && x <= n^2) <$> a
    cksum xs = 2^(n^2) - 1 == sum xs
    bit i j = 2^(a!(i,j) - 1)
  pure $ bool "No" "Yes" $ rangeCheck a && and (concat
     [ [cksum [bit i j | j <- [1..n^2]] | i <- [1..n^2]]
     , [cksum [bit j i | j <- [1..n^2]] | i <- [1..n^2]]
     , [cksum [bit (x + i) (y + j) | j <- [1..n], i <- [1..n]] |
       x <- [0,n..n^2-n], y <- [0,n..n^2-n]]
     ])

Meet and party

For the small input, we compute the cost of holding the party at each point in a straightforward manner and take the minimum, using the x-coordinate or y-coordinate to break ties as described in the problem.

Sorting a list of type [(a, b)] automatically does what we want: this sorts by a first and b second. We rely on an undocumented(?) feature of minimumBy: we need it to return the first minimum found.

import Jam
import Data.List
import Data.Ord

main = jam $ do
  [b] <- getints
  rs <- getintsn b
  let
    ps = concatMap (\[x1, y1, x2, y2] ->
      [(x, y) | x <- [x1..x2], y <- [y1..y2]]) rs
    d (x1, y1) (x2, y2) = abs (x2 - x1) + abs (y2 - y1)
    f p = sum $ map (d p) ps
    (a, b) = minimumBy (comparing f) $ sort ps
  pure $ unwords $ map show [a, b, f (a, b)]

Let’s first focus on one dimension. For now, assume we have at least two points. Consider only the x-coordinates. Sort them, and let a, b be the minmum and maximum respectively. Now if the party is held anywhere in the interval [a..b], the sum of the cost for these two points is b - a, and if the party is held anywhere outside [a..b] then the cost is strictly greater.

If we discard a, b and recursively apply this argument, we surmise that our total cost is minimized if the party is held at the median point when the number of points is odd, or at any point between the two middle points (the innermost interval) when the number of points is even.

The same applies for the y-coordinate. Thus by looking at medians, we can determine the region where the total cost is minimized. However, it may be that nobody lives in that region.

To address this, for each given point, we will compute the extra cost for holding the party at that point.

Again, let us focus on x-coordinates first. Suppose the number of points is even, and let m0, m1 be the two middle points (which may be equal). From before, the cost is minimized when the party is held in [m0..m1].

Let x be the point after m1 in the sorted list of x-coordinates, and suppose we hold the party at x. The total cost for the people living at m0 and m1 is x - m1 + x - m0; if the party were in [m0..m1] then the total would be m1 - m0 instead. For everybody else, there is no extra cost, so the total difference from the minimal cost is 2 * (x - m1).

Let y be the point after x in the sorted list of x-coordinates, and suppose we hold the party at y. We find the cost differs from the minimal cost by 2 * x - m1) + 2*(y - x.

If we let ds = [d1, d2, ..] be the differences between successive x-coordinates starting from m1 in the sorted list of x-coordinates, by induction we find the extra cost of holding the party at the nth point after m1 is 2 * (d1 + 2*d2 + 3*d3 + …​ + n*dn), that is:

sum $ zipWith (*) ds $ map (2*) [1..]

Now suppose the number of points is odd, so that m0, m1 refer to the same median point. Then the above formula overcounts the cost: there’s only one person living at m0, not two. We find the correct formula in this case is:

sum $ zipWith (*) ds $ map (subtract 1 . (2*)) [1..]

These formulas are just for show; for efficiency, we compute the cost inductively. Namely, to compute the penalty for holding the party at a point, we simply add a certain value to the penalty for the previous point.

We treat the y-coordinates similarly. Adding the results gives us the penalty for each point. The point with the minimum penalty is the answer.

import Jam
import Data.Array
import Data.List
import qualified Data.Map as M
import Data.Ord

main = jam $ do
  [b] <- getints
  rs <- getintsn b
  let
    ps = sort $ concatMap (\[x1, y1, x2, y2] ->
      [(x, y) | x <- [x1..x2], y <- [y1..y2]]) rs
    n = length ps
    xs = listArray (0, n - 1) $ sort $ map fst ps
    ys = listArray (0, n - 1) $ sort $ map snd ps
    cx = M.fromList $ zip (elems xs) (elems $ cost xs)
    cy = M.fromList $ zip (elems ys) (elems $ cost ys)
    cost as = cs
      where
        i0 = div (n - 1) 2
        i1 = div n       2
        cs = array (0, n - 1) $ bot ++ top
        top = (i1, 0) : [(i, cs!(i - 1) + f k * (as!i - as!(i - 1))) |
          (i, k) <- zip [i1 + 1..n - 1] [1..]]
        bot = (i0, 0) : [(i, cs!(i + 1) + f k * (as!(i + 1) - as!i)) |
          (i, k) <- zip [i0 - 1, i0 - 2..0] [1..]]
        f k | i0 == i1  = 2*k - 1
            | otherwise = 2*k
    d (x1, y1) (x2, y2) = abs (x2 - x1) + abs (y2 - y1)
    g p@(x, y) = unwords $ map show [x, y, sum $ map (d p) ps]
  pure $ g $ minimumBy (comparing (\(x, y) -> cx M.! x + cy M.! y)) ps

Our code violates the Haskell report: giving the array constructor a repeated key causes undefined behaviour. But GHC guarantees this will still work: the value taken by the key is the last one provided in the list. If we cared, we could avoid prepending (i0, 0) to bot when i0 == i1.

Hex

Because the players alternately place one stone per turn and because the game finishes as soon as one player completes a path, a game is valid if and only if all of the following hold:

  1. The number of stones per player can differ by at most one.

  2. If a player won, then they have as least as many stones as the loser.

  3. If a player won, there must be at least one stone whose absence means there is no winning path. otherwise what was the last move?

The first condition is easy to check. For the second, we can flood-fill to determine if a path connects one side to the other.

The third condition is trickiest. In graph theory terms, the min-cut must be one, where we consider the two sides of the winning player to be nodes along with each stone belonging to the player, and focus only on the nodes connected to the two sides. Presumably, a min-cut algorithm would work here, but firstly, a far simpler method exists due to the nature of the board, and secondly, brute force will do for the small input: we simply remove each stone in turn and re-apply flood-fill to see if the player still wins.

import Jam
import Data.Array
import qualified Data.Set as S

main = jam $ do
  [n] <- getints
  board <- listArray ((1, 1), (n, n)) . concat <$> getsn n
  let
    count c = length $ filter (== c) $ elems board
    [bCount, rCount] = map count "BR"
    wins _ _ _ _    []      = False
    wins f c b done (s:ss)
      | f s == n          = True
      | s `S.member` done = wins f c b done ss
      | otherwise         = wins f c b (S.insert s done) $
        [p | p <- nbrs s, b!p == c] ++ ss
    bWins b = wins snd 'B' b S.empty
      [p | i <- [1..n], let p = (i, 1), b!p == 'B']
    rWins b = wins fst 'R' b S.empty
      [p | i <- [1..n], let p = (1, i), b!p == 'R']
    nbrs p@(i, j) = filter (inRange $ bounds board) $
      add p <$> [(1, 0), (0, 1), (-1, 0), (0, -1), (1, -1), (-1, 1)]

    cutOne c = [board // [(p, '.')] | p <- indices board, board!p == c]

    solve
      | abs (bCount - rCount) > 1 = "Impossible"
      | bWins board = if bCount < rCount || (all bWins $ cutOne 'B')
        then "Impossible" else "Blue wins"
      | rWins board = if bCount > rCount || (all rWins $ cutOne 'R')
        then "Impossible" else "Red wins"
      | otherwise = "Nobody wins"
  pure $ solve

add (a, b) (c, d) = (a + c, b + d)

For the large input, in a way to apply graph theory. By the max-flow min-cut theorem, the third condition is equivalent to a max flow of one from one side to the other for a winning player, that is, at some point the path must go through a one-stone bottleneck. (Alternatively, we could eyeball the problem and intuitively sense this equivalence.)

We can find the max flow with the left-hand rule for solving a maze. For Blue, for the topmost stone in the leftmost column, we attempt to reach the rightmost column by following the left-hand rule. If we make it, then we remove all the stones we traversed, and try again the next topmost stone in the leftmost column. If we make it again, then the max flow is at least 2 thus the game is impossible.

Our code actually tries starting from all stones in the leftmost column, whether they have been removed or not. This is slightly wasteful, but still works because if we try starting from a removed stone, we’re stuck in place because we’ve already removed all the stones that were connected to it.

We can similarly determine the max flow for Red, by looking at stones in the topmost row. Here, we must be careful to start from the rightmost stone, since we’re using the left-hand rule.

import Jam
import Data.Array
import Data.List
import Safe
import qualified Data.Set as S

add (a, b) (c, d) = (a + c, b + d)
neg (a, b) = (-a, -b)

cw = [(-1, 0), (-1, 1), (0, 1), (1, 0), (1, -1), (0, -1)]

cwFrom dir = take (length cw) $ tail $ dropWhile (/= dir) $ cycle cw

main = jam $ do
  [n] <- getints
  board <- listArray ((1, 1), (n, n)) . concat <$> getsn n
  let
    count c = length $ filter (== c) $ elems board
    [bCount, rCount] = map count "BR"
    maze _ _ _ [] = []
    maze f c b (s:ss)
      | b!fst s == c = walk [s]
      | otherwise    = continue
      where
        continue = maze f c b ss
        walk ps@((p, dir):_)
          | f p == n = ps
          | head ps `elem` tail ps = continue
          | otherwise = case headMay [(q, dir') | dir' <- cwFrom $ neg dir,
            let q = add p dir', inRange (bounds b) q && b!q == c] of
              Nothing -> continue
              Just next -> walk $ next:ps

    bMaze b = maze snd 'B' b $ map (\i -> ((i, 1), (0, 1))) [1..n]
    rMaze b = maze fst 'R' b $ map (\i -> ((1, i), (1, 0))) [n, n-1..1]
    delPath path = board // zip (map fst path) (repeat '.')
    solve
      | abs (bCount - rCount) > 1 = "Impossible"
      | not $ null bPath = if bCount >= rCount && null (bMaze $ delPath bPath)
        then "Blue wins"
        else "Impossible"
      | not $ null rPath = if rCount >= bCount && null (rMaze $ delPath rPath)
        then "Red wins"
        else "Impossible"
      | otherwise = "Nobody wins"
      where
        bPath = bMaze board
        rPath = rMaze board

  pure $ solve

I was saved by my brute force solution. Many mistakes were exposed when I compared the two solutions on the small input. The first time around:

  • I forgot to handle the single stone maze, so my program hung on some inputs.

  • I forgot to copy over the stone count checks.

  • I went left to right for the Red stones in the topmost row.

  • My start direction for the Red victory check was wrong; I had copied it from the Blue victory check, which went right. It should be down. (Actually, other directions work, but not right.)

  • On failing to reach the other side, my code failed to try again from the next candidate. This was disconcerting since in my head I wanted to do this; somehow it got lost when I wrote the code.

Dragon Maze

Straightforward, though a little tedious: a breadth-first search where we exhaust the current level before considering returning.

import Jam
import Data.Array
import Data.List
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Maybe

main = jam $ do
  [n, m] <- getints
  [enx, eny, exx, exy] <- map (+1) <$> getints
  a <- listArray ((1, 1), (n, m)) . concat <$> getintsn n
  let
    fill best live
      | S.null live = Nothing
      | (exx, exy) `M.member` best = Just $ best M.! (exx, exy)
      | otherwise = fill (foldl' (\m (k, v) -> M.insertWith max k v m)
        best next) (S.fromList $ map fst next)
      where
        next = concatMap f $ S.elems live
        f p = [(q, best M.! p + a!q) |
          q <- add p <$> [(0, 1), (1, 0), (0, -1), (-1, 0)],
          inRange (bounds a) q, a!q >= 0, not $ M.member q best]

  pure $ maybe "Mission Impossible." show $
     fill (M.singleton (enx, eny) (a!(enx, eny))) (S.singleton (enx, eny))

add (a, b) (c, d) = (a + c, b + d)

Ignore all my comments

An easy problem with a confusing description and worth a surprising number of points. Perhaps they originally wanted to ignore comments in string constants or something, but then they simplified the problem? We’re just looking for nested pairs of "/" and "/"; nothing else matters.

We use plain Haskell (no Jam monad) because of the peculiar input.

import Data.List

main = interact $ ("Case #1:\n" ++) . f 0

f _ "" = ""
f n s@(c:cs)
  | Just t <- stripPrefix "/*" s = f (n + 1) t
  | n > 0,
    Just t <- stripPrefix "*/" s = f (n - 1) t
  | n == 0                       = c:f n cs
  | otherwise                    = f n cs
Contents
Ben Lynn blynn@cs.stanford.edu 💡