Contents

Read Phone Number

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]
Contents
Ben Lynn blynn@cs.stanford.edu 💡