Tom Moertel's Weblog: Tag puzzles

ClusterBy: a handy little function for the toolbox

Tom Moertel — Sat, 01 Sep 2007 15:39:00 -0400

Via Reddit I found Mark Nelson’s post about a recent word puzzle from NPR’s Weekend Edition:

Take the names of two U.S. States, mix them all together, then rearrange the letters to form the names of two other U.S. States. What states are these?

The puzzle is fairly straightforward to solve by hand (think about it), but let’s write a program to solve it. That will give us a convenient excuse to discuss a super-handy function I use all the time: clusterBy. In Haskell, it looks like this:

import Control.Arrow ((&&&))
import qualified Data.Map as M

clusterBy :: Ord b => (a -> b) -> [a] -> [[a]]
clusterBy f = M.elems . M.map reverse . M.fromListWith (++)
            . map (f &&& return)

What clusterBy does is group a list of values by their signatures, as computed by a given signature function f, and returns the groups in order of ascending signature. For example, we can cluster the words “the tan ant gets some fat” by length, by first letter, or by last letter just by changing the signature function we give to clusterBy:

*Main> let antwords = words "the tan ant gets some fat"

*Main> clusterBy length antwords
[["the","tan","ant","fat"],["gets","some"]]

*Main> clusterBy head antwords
[["ant"],["fat"],["gets"],["some"],["the","tan"]]

*Main> clusterBy last antwords
[["the","some"],["tan"],["gets"],["ant","fat"]]

If we use sort as the signature function, we can find anagrams:

*Main> clusterBy sort antwords
[["fat"],["tan","ant"],["gets"],["the"],["some"]]

And that brings us back to the original puzzle. To find the solution, we must consider each unique pair of state names to form a “word” and find the anagrams among a list of such “words.”

Assuming we are given a list of state names on standard input, one state per line, we can write the shell of our solution as follows:

main = mapM_ print . solve . lines =<< getContents

The shell delegates the real work to solve. It’s job is to compute the unique, 2-state combinations from the original list of states, and then find the anagrams among these combinations. As before, finding the anagrams is simply a matter of calling clusterBy with the right signature function. We also filter out the trivial results, which are not valid solutions:

solve = filter ((>1) . length) . clusterBy signature . ucombos
ucombos xs = [[x,y] | x <- xs, y <- xs, x < y]
signature = sort . filter isAlpha . concat   -- sort letters

That’s it. Now we can solve the puzzle by feeding our program a list of states:

$ runhaskell anagrams2.hs < states.txt

[["NORTH CAROLINA","SOUTH DAKOTA"],
 ["NORTH DAKOTA","SOUTH CAROLINA"]]

What a handy little function, that clusterBy.

Update: made clear that clusterBy returns clusters in order of ascending signature.

Update 2007-10-31: For more interesting discussion of clusterBy and the original puzzle from NPR, see Anders Pearson’s blog: A Simple Programming Puzzle Seen Through Three Different Lenses.

Solving the Google Code Jam "countPaths" problem in Perl

Tom Moertel — Thu, 17 Aug 2006 02:21:00 -0400

As promised, here’s a Perl version of a dynamic-programming-based solver for the Google Code Jam “countPaths” problem. It is a straight translation of my improved Ruby implementation. As you might expect, the Perl version was pretty fast. It proved faster than the other scripting-language implementations I tried (in this rather unscientific benchmark, not to be taken seriously):

Implementation	Run time (s)
Haskell	0.9
Perl (code below)	1.7
Python	2.8
Ruby	4.2

All timings were taken while solving the maximum-size, all-the-same-letter problem on my 1.8-GHz Opteron box.

Here’s the Perl implementation:

#!/usr/bin/perl

# Tom Moertel <tom@moertel.com>
# 2006-08-16
#
# Perl-based solution to the Google Code Jam problem "countPaths".
# See http://www.cs.uic.edu/~hnagaraj/articles/code-jam/ for more.

use strict;
use warnings;

use List::Util 'sum';
use Math::BigInt;

sub count_paths {

  my ($grid, $word) = @_;

  my $rword  = reverse $word;
  my $rowmax = $#$grid;
  my $colmax = length($grid->[0]);
  my ($slab, $sum);

  for my $i (0 .. length($rword) - 1) {
    my $char = substr $rword, $i, 1;
    ($slab, my $previous_slab) = ([], $slab);
    for my $r (0 .. $rowmax) {
      my ($row, $line) = ($grid->[$r], $slab->[$r] ||= []);
      for my $c (0 .. $colmax) {
        $line->[$c] = $char ne substr($row,$c,1) ? 0 : $i == 0 ? 1 : do {
          $sum = 0;
          my $clo = $c > 0 ? $c - 1 : $c;
          my $chi = $c < $colmax ? $c + 1 : $c;
          for my $nr (($r>0 ? $r-1 : $r) .. ($r<$rowmax ? $r+1 : $r)) {
            for my $nc ($clo .. $chi) {
              $sum += $previous_slab->[$nr][$nc]
                if $nr != $r || $nc != $c;
            }
          }
          $sum;
        }
      }
    }
  }

  sum map @$_, @$slab;
}

print count_paths([("A"x50)x50], "A"x50), $/;
# 3.03835410591851e+47

Update: I simplified the code a whisper by removing an unnecessary variable $counts. Here’s a diff if you’re curious about what’s changed:

--- countpaths.pl.orig  2006-08-18 00:16:56.000000000 -0400
+++ /countpaths.pl      2006-08-18 00:19:30.000000000 -0400
@@ -19,11 +19,11 @@
   my $rword  = reverse $word;
   my $rowmax = $#$grid;
   my $colmax = length($grid->[0]);
-  my ($counts, $slab, $sum);
+  my ($slab, $sum);

   for my $i (0 .. length($rword) - 1) {
     my $char = substr $rword, $i, 1;
-    ($slab, my $previous_slab) = ($counts->[$i] ||= [], $slab);
+    ($slab, my $previous_slab) = ([], $slab);
     for my $r (0 .. $rowmax) {
       my ($row, $line) = ($grid->[$r], $slab->[$r] ||= []);
       for my $c (0 .. $colmax) {

Update 2: Augmented the introductory paragraph with a parenthetical comment that reminds readers that these single-fuzzy-data-point-style timings should not be taken seriously. Also removed the word “bested,” which might suggest that there is an optimization contest in play. Please, no wagering.

Update 3: Stripped another variable ($j), which was completely unused and leftover from previous implementation. (See why you shouldn’t code late at night?)

Solving the Google Code Jam "countPaths" problem in Haskell

Tom Moertel — Tue, 15 Aug 2006 17:01:00 -0400

Via the article on this year’s Google Code Jam on Slashdot earlier today, I found Hareesh Nagarajan’s write-up of a previous year’s Code-Jam problem. Since Google often comes up with interesting problems, I decided to give this one a go.

The problem: count the ways to find a word by walking on a grid

You are given a rectangular grid of letters and a word to find. You must compute the number of ways to find the word within the grid using the following rules:

start at any cell within the grid
from there, move to any of the cell’s eight neighboring cells
continue moving from that neighbor to its neighbors, and so on, until you have spelled out the word
you may visit cells more than once, but you cannot visit the same cell twice in a row (i.e., you must move for each turn)

For instance, consider the following grid, taken from the examples in the problem statement:

ABC
FED
GAI

If you were asked to find the word “AEA” on this grid, you could do it in four ways:

Way  --Move---
     1   2   3

1:  *BC ABC *BC
    FED F*D FED
    GAI GAI GAI

2:  *BC ABC ABC
    FED F*D FED
    GAI GAI G*I

3:  ABC ABC *BC
    FED F*D FED
    G*I GAI GAI

4:  ABC ABC ABC
    FED F*D FED
    G*I GAI G*I

If you were asked to find “ABCD”, you could do it in only one way:

Way  --Move-------- 
     1   2   3   4 

1:  *BC A*C AB* ABC
    FED FED FED FE*
    GAI GAI GAI GAI

If you were asked to find “AAB”, you could not: there are no “A” cells on the grid that have other “A” cells as neighbors.

The tricksy nature of the problem

As you might expect from Google, this puzzle was designed to see whether your solution can scale. A simple search will quickly bog down because each step in the search can expand into vastly more possibilities, as searching for “AAAA” on a seemingly harmless 2×2 grid of all “A” cells shows – there are 108 solutions.

The problem statement says that the grid may be up to 50×50 in size and the word to find may be up to 50 letters long. Imagine, then, that you are asked to find a word composed of 50 “A” letters within a 50×50 grid of “A” cells. All of the cells will be valid starting points, and each will have, on average, slightly less than 8 valid neighbors. Thus there will be about 50 × 50 × 8^49 = 4.5e47 ways to find the word¹. Tracing them all would take forever.

The trick is figuring out a more efficient way to solve the problem. Since that’s the fun part of this problem, I won’t spoil it for you by telling you how I did it. (If you truly want spoilers, you can study my code.)

My solution

Here is what I came up with. I’ll present the code first and then discuss how to use it.

Note: The code below is out of date but printed here for continuity. See Update 5 for the most-recent revision.

{-

Tom Moertel <tom@moertel.com>
2006-08-15

Haskell-based solution to the Google Code Jam problem "countPaths";
see http://www.cs.uic.edu/~hnagaraj/articles/code-jam/ for more.

-}

module Main (main) where

import Control.Monad
import Data.Array
import qualified Data.Map as M

main = do
    word:gridspec <- liftM words getContents
    print $ (countPaths word (toGridArray gridspec) :: Integer)

countPaths word@(p:_) gridArray =
    sum . M.elems $ foldl step state0 (zip word (tail word))
  where
    state0 = M.fromList [(cell, 1) | (cell, q) <- assocs gridArray, p == q]
    neighbors = toNeighborMap gridArray
    step state fromto = M.fromListWith (+) $ do
        steps <- M.lookup fromto neighbors
        (start, count) <- M.assocs state
        cells <- M.lookup start steps
        cell <- cells
        return (cell, count)

toGridArray gridspec@(l1:_) =
    listArray ((1,1), (length gridspec, length l1)) (concat gridspec)

toNeighborMap gridArray =
    M.fromListWith (M.unionWith (flip (++))) $ do
        (cell, p) <- assocs gridArray
        cell' <- neighbors8 cell
        guard $ inRange (bounds gridArray) cell'
        return ((p, gridArray!cell'), M.singleton cell [cell'])

neighbors8 (r,c) =
    [(r+h, c+v) | h <- [-1..1], v <- [-1..1], h /= 0 || v /= 0]

-- Local Variables:  ***
-- compile-command: "ghc -O2 -o wordpath --make WordPath.hs" ***
-- End: ***

My solution generalizes upon the problem statement in a few ways:

the grid can be any size and the word any length
the grid and word can be composed of any comparable data type, not just A–Z letters (if you use the stdin interface, the code will use Unicode characters)
the code will compute exact counts instead of returning -1 for counts greater than 1e9

You can enter problems from the command line. Enter the word first and then the grid, each row separated by whitespace. For example:

$ ./wordpath
AAAAAAAAAAA

AAAAA
AAAAA
AAAAA
AAAAA
AAAAA
^D

2745564336

Give it a try

This was a fun problem to solve. If you have a little spare time, give it a try. I would love to compare results and talk about strategies.

Update: Fixed typo: Finding “AAAA” – not “AA” – on a 2×2 grid of all “A” letters results in a count of 108. Thanks to Joshua Volz for pointing out my mistake.

Update 2: Here’s a dynamic-programming-based implementation of countPaths that is about six times faster than my original implementation when solving the maximum-size, all-the-same-letter problem:

countPaths word gridArray =
    sum [counts ! (length word, cell) | cell <- cells]
  where
    counts = listArray ((1, (1, 1)), (length word, gridSize)) $
             [countFrom i cell | i <- [1..length word], cell <- cells]

    countFrom i cell
        | i == 1 && match = 1
        | match           = sum [counts!((i-1),n) | n <- neighbors!cell]
        | otherwise       = 0
      where
        match = rword ! i == gridArray ! cell

    neighbors = listArray (bounds gridArray) $
        [filter (inRange (bounds gridArray)) (neighbors8 cell)
            | cell <- cells ]

    rword    = listArray (1, length word) (reverse word)
    cells    = indices gridArray
    gridSize = snd (bounds gridArray)

See the thread started by ‘psykotic’ on reddit.com for more.

Update 3: Ivan Peev has solved the problem in Python: Solving the Google Code Jam ‘countPaths’ problem in Python. Because his implementation uses the same algorithm that my implementation in Update 2 does, it makes a good vehicle for Haskell-versus-Python speed comparisons, an interesting topic in light of the warning Google provides about using Python in the Google Code Jam:

NOTE: All submissions have a maximum of 2 seconds of runtime per test case. This limit is used in harder problems to force submissions to be of a certain complexity. Because of the inherent speed differences between Python and the other offered languages is large, some problems may require extra optimization or not be solvable using the Python language.

Ivan reports that his Python implementation solves the maximum-size, all-the-same-letter problem in about 8 seconds on an old 1-GHz AMD Athlon. The Haskell version comes in somewhat faster at 0.9 second on a 1.8-GHz AMD Opteron. (On the same Opteron, Ivan’s code clocks in at 2.8 seconds, which is impressive.)

Update 4: I have added a Ruby implementation and a Perl implementation and timings, too. On the the maximum-size, all-the-same-letter problem, Ruby clocks in at 4.2 seconds; Perl in 1.7 seconds. See the Perl implementation for a summary table of the timings.

Update 5: As I promised reader Kartik in a comment, here is a further-simplified, yet 25-percent-faster, version of my implementation in Update 2. This version eliminates the cache in favor of a current-state array that is folded through the successive letters of the target word. The result of the fold operation is the final state array, whose elements are summed to yield the final result. Here’s the complete code:

{-

Tom Moertel <tom@moertel.com>
2006-08-15 (revised 2006-09-01)

Haskell-based solution to the Google Code Jam problem "countPaths" 
See http://www.cs.uic.edu/~hnagaraj/articles/code-jam/ for more.

This implementation is based on the dynamic-programming strategy
mentioned by reddit.com user "psykotic":
http://programming.reddit.com/info/dni1/comments/cdp59.

-}

module Main (main) where

import Control.Monad
import Data.Array

main = do
    word:gridspec <- liftM words getContents
    print $ (countPaths word (toGridArray gridspec) :: Integer)

countPaths word grid =
    sum . elems $ foldl move counts0 (tail (reverse word))
  where
    move counts c  = step c $ sum . map (counts!) . neighbors
    counts0        = step (last word) (const 1)
    step c f       = listArray (bounds grid) $ map (match c f) cells
    match c f cell = if c == grid!cell then f cell else 0
    neighbors cell = filter (inRange (bounds grid)) (neighbors8 cell)
    cells          = indices grid

toGridArray gridspec@(l1:_) =
    listArray ((1,1), (length gridspec, length l1)) (concat gridspec)

neighbors8 (r,c) =
    [(h, v) | h <- [r-1..r+1], v <- [c-1..c+1], h /= r || v /= c]

-- Local Variables:  ***
-- compile-command: "ghc -O2 -o wordpathdp --make WordPathDP.hs" ***
-- End: ***

¹ I believe that the exact count is 303 835 410 591 851 117 616 135 618 108 340 196 903 254 429 200 (approx. 3.04e47). It takes about ~~six seconds~~ 0.75 second to compute on a 1.8-GHz AMD64 box running Linux.

The "perfect shuffles" puzzle (solved in Haskell)

Tom Moertel — Thu, 23 Mar 2006 16:51:00 -0500

I ran across a fun programming puzzle (via Raganwald):

Given a deck of n unique cards, cut the deck i cards from top and perform a perfect shuffle. A perfect shuffle begins by putting down the bottom card from the top portion of the deck followed by the bottom card from the bottom portion of the deck followed by the next card from the top portion, etc., alternating cards until one portion is used up. The remaining cards go on top. The problem is to find the number of perfect shuffles required to return the deck to its original order. Your function should be declared as:

static long shuffles(int nCards,int iCut);

Please send the result of shuffles(1002,101) along with your program and your resume to ‘resume’ at nextag.com.

It’s a fun problem, so give it a try before reading on.

Warning: small spoilers ahead

The first thing I usually do when I encounter a new problem is explore it until I have a feel for its essence. For this problem, the shuffle algorithm seemed like a good starting point:

shuffle n i =
    reverse . uncurry (flip interleave) . splitAt (n-i) . reverse

interleave (x:xs) (y:ys) = x : y : interleave xs ys
interleave xs     []     = xs
interleave []     ys     = ys

From within GHCi, I watched a few iterations, using a ten-card deck as input:

*Main> mapM_ print . take 10 $ iterate (shuffle 10 3) [0..9]
[0,1,2,3,4,5,6,7,8,9]
[3,4,5,6,7,0,8,1,9,2]
[6,7,0,8,1,3,9,4,2,5]
[8,1,3,9,4,6,2,7,5,0]
[9,4,6,2,7,8,5,1,0,3]
[2,7,8,5,1,9,0,4,3,6]
[5,1,9,0,4,2,3,7,6,8]
[0,4,2,3,7,5,6,1,8,9]
[3,7,5,6,1,0,8,4,9,2]
[6,1,0,8,4,3,9,7,2,5]

After a bit of study, a light-bulb appeared over my head, and I realized something about the fundamental nature of the problem that I had overlooked earlier. (I won’t spoil the fun by saying what it was.) From that point, the solution was easy to implement:

module Main (main) where

import Control.Monad (liftM)
import Data.Array
import Data.Set (Set, empty, insert, member)
import System.Environment (getArgs)

main = do
    n:i:_ <- liftM (map read) getArgs
    print (shuffles n i)

shuffles :: Int -> Int -> Integer
shuffles n i =
    foldl lcm 1 . map toInteger . fst . foldl dfs ([], empty) $ deck'
  where
    (deck, deck')  = ([0 .. n-1], shuffle n i deck)
    perms          = array (0, n-1) (zip deck' deck)
    dfs (ls, vs) j = if member j vs then (ls, vs) else (l:ls, vs')
                     where (l, vs') = follow 0 j vs
    follow n i vs  = if member i vs then (n,vs)
                     else follow (n+1) (perms!i) (insert i vs)

shuffle n i =
    reverse . uncurry (flip interleave) . splitAt (n-i) . reverse

interleave (x:xs) (y:ys) = x : y : interleave xs ys
interleave xs     []     = xs
interleave []     ys     = ys

The following command compiles the program:

$ ghc -O2 -o shuffle --make PerfectShuffle.hs

The program computes the requested solution in about 4 ms on my 1.8-GHz box:

$ time ./shuffle 1002 101
5812104600

real    0m0.006s
user    0m0.004s
sys     0m0.004s

If you Google around, you can find other solutions, most of them implemented in Java.

Solve puzzles! They’re good for you.

Solving programming puzzles is a fun way to exercise parts of the brain that day-to-day coding rarely uses. If you are looking for some more puzzles, check out what’s archived at the Programming Fun Challenge page. Some are simple but others are downright tricksy.

Update 2006-03-24: Last night I thought of a simple optimization to my original implementation, and this morning I revised my code. The optimization reduces the run time for the (1002, 101) case from about 16 ms to about 4 ms. I have replaced the original code from this article with the new code, which is slightly longer. For comparison, here is the original implementation:

shuffles :: Int -> Int -> Integer
shuffles n i =
    foldl lcm 1 . map (fromIntegral . cycleLength) $ deck'
  where
    (deck, deck') = ([0..n-1], shuffle n i deck)
    perms         = array (0, n-1) (zip deck' deck)
    cycleLength j = follow j 1 (perms!j) :: Int
    follow i0 n i = if i == i0 then n else follow i0 (n+1) (perms!i)

Update 2006-03-25: I replaced the optimized code with a slightly more idiomatic version. I did this because I was guilt-tripped by a comment on Reddit saying that Haskell looked “ugly.” This code is, in fact, pretty ugly as far as Haskell goes. (Tip: Don’t judge a language based on a single sample, especially if it’s this one. If you want to see more beautiful code, my Haskell solutions to the 1996 ACM International Collegiate Programming Contest are much less offensive.)

Update 2006-11-04: Colorized the Haskell snippets.