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^2n], y < [0,n..n^2n]] ])
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.
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 xcoordinate or ycoordinate 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 xcoordinates. 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 ycoordinate. 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 xcoordinates 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 xcoordinates, 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 xcoordinates, 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
xcoordinates starting from m1
in the sorted list of xcoordinates, 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 ycoordinates 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:

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

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

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 floodfill to determine if a path connects one side to the other.
The third condition is trickiest. In graph theory terms, the mincut 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 mincut 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 reapply floodfill 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 maxflow mincut 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 onestone bottleneck. (Alternatively, we could eyeball the problem and intuitively sense this equivalence.)
We can find the max flow with the lefthand 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 lefthand 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 lefthand 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, n1..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 breadthfirst 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