The splitPlaces and group functions make short work of this problem.

```import Jam
import Data.Char
import Data.List
import Data.List.Split

ns = words "zero one two three four five six seven eight nine"
ms = "":"":"double":"triple":((++"uple") <\$>
words "quadr quint sext sept oct non dec")

speak s@(c:_)
| m == 1 || m > 10 = unwords \$ replicate m d
| otherwise        = ms!!m ++ " " ++ d
where d = ns!!digitToInt c
m = length s

main = jam \$ do
(n, f) <- (\[n, f] -> (n, map read \$ splitOn "-" f)) . words <\$> gets
pure \$ unwords \$ map (unwords . map speak . group) \$ splitPlaces f n```

Rational Number Tree

We solve question 1 by considering the binary expansion of n. The bits tell us whether to take the left or right path at each level.

For question 2, if the numerator exceeds the denominator, then we have just taken the right path, otherwise we have taken the left. We work backwards using this rule and build the index one bit at a time.

```import Jam

main = jam \$ do
(id:p:q) <- getintegers
pure \$ case id of
1 -> (\(p, q) -> show p ++ " " ++ show q) \$ f p
2 -> show \$ g p \$ head q

f 1 = (1, 1)
f n | r == 1    = (a + b, b)
| otherwise = (a, a + b)
where (q, r) = divMod n 2
(a, b) = f q

g p q | p > q = 1 + 2 * g (p - q) q
| p < q = 2 * g p (q - p)
| otherwise = 1```

Sorting

We use partition to separate odd and even numbers, sort them independently, then recursively put them back together, using the original list as a guide.

```import Jam
import Data.List
import Data.Ord

main = jam \$ do
gets
ns <- getints
let (as, bs) = partition odd ns
pure \$ unwords \$ map show \$ f [] (sort as) (sortBy (flip compare) bs) ns

f acc [] [] [] = reverse acc
f acc as bs (n:ns)
| odd n     = f (head as:acc) (tail as) bs ns
| otherwise = f (head bs:acc) as (tail bs) ns```

Cross the maze

Tedious but straightforward.

If we start in the first row, facing east guarantees there will be a wall on our left, and similarly for facing west if we start in the last row.

If we start completely surrounded by walls, we immediately return Nothing, which represents failure. Otherwise we proceed with the left-hand rule; if we reach the exit within 10000 steps then we return Just the number of steps taken, otherwise we return Nothing.

```import Jam
import Data.Array
import Data.Maybe

main = jam \$ do
[n] <- getints
as <- getsn n
[sx, sy, ex, ey] <- getints
let
maze = listArray ((1, 1), (n, n)) \$ concat as
(dx, dy) | sx == 1   = (0, 1)
| otherwise = (0, -1)
f acc (x, y) (dx, dy)
| (x, y) == (ex, ey) = Just \$ reverse acc
| length acc == 10000 = Nothing
| not \$ isWall (x + hx, y + hy) = go (hx, hy)
| not \$ isWall (x + dx, y + dy) = go (dx, dy)
| otherwise = f acc (x, y) \$ turnR (dx, dy)
where
(hx, hy) = turnL (dx, dy)
go (dx, dy) = f (compass (dx, dy):acc) (x + dx, y + dy) (dx, dy)
isWall (x, y)
| x == 0 || y == 0 || x > n || y > n = True
| otherwise = maze!(x, y) == '#'

pure \$ maybe "Edison ran out of energy." out \$
if all (isWall . (\(dx, dy) -> (sx + dx, sy + dy)))
[(0, 1), (1, 0), (0, -1), (-1, 0)]
then Nothing
else f "" (sx, sy) (dx, dy)

compass ( 1,  0) = 'S'
compass (-1,  0) = 'N'
compass ( 0,  1) = 'E'
compass ( 0, -1) = 'W'

turnL (x, y) = (-y, x)
turnR (x, y) = (y, -x)

out s = show (length s) ++ "\n" ++ s```

Spaceship Defence

The inputs are obfuscated graphs. Each node is a colour, and each turbolift is an edge. When converting to a graph, we remove self-edges and only keep the edges of minimum weight.

Then we apply Dijkstra’s algorithm on each soldier to find the shortest paths.

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

main = jamLnCat \$ do
[n] <- getints
cs <- getsn n
[m] <- getints
ts <- getintsn m
[s] <- getints
pqs <- getintsn s
let
aa = listArray (1, n) cs
keepBest [x@(k, v)] ds = case lookup k ds of
Nothing -> x:ds
Just v' -> if v < v' then x:delete (k, v') ds else ds
mm = M.fromListWith keepBest \$ [(ca, [(cb, t)]) | [a, b, t] <- ts,
let ca = aa!a, let cb = aa!b, ca /= cb]
nbrs x = if x `M.notMember` mm then [] else mm M.! x
shortest p q
| p == q = 0
| otherwise = f S.empty (S.singleton p) q \$ M.singleton p 0
f done todo q ds
| null todo = -1
| x == q = c
| otherwise = f (S.insert x done) (foldl' (flip S.insert) (S.delete x todo) (map fst u)) q \$
foldl' (\ds (n,m) -> M.insertWith min n m ds) ds [(n, c + m) | (n, m) <- u]
where x = minimumBy (comparing (ds M.!)) todo
c = ds M.! x
u = filter ((`S.notMember` done) . fst) \$ nbrs x

pure \$ unlines \$ map show \$ [shortest (aa!p) (aa!q) | [p, q] <- pqs]```

Ben Lynn blynn@cs.stanford.edu 💡