Finding one solution to Knight's Tour in Haskell

Question

I'm trying to solve Knight's Open Tour in Haskell，and come up with a solution to generate all possible solutions:

knightsTour :: Int -> [[(Int, Int)]]
knightsTour size = go 1 [(1, 1)]
  where
    maxSteps = size^2
    isValid (x, y) = x >= 1 && x <= size && y >= 1 && y <= size

    go :: Int -> [(Int, Int)] -> [[(Int, Int)]]
    go count acc | count == maxSteps = return $ reverse acc
    go count acc = do
      next <- nextSteps (head acc)
      guard $ isValid next && next `notElem` acc
      go (count + 1) (next : acc)


fs = replicateM 2 [(*1), (*(-1))]
nextSteps :: (Int, Int) -> [(Int, Int)]
nextSteps (x, y) = do
  (x', y') <- [(1, 2), (2, 1)]
  [f, f'] <- fs
  return (x + f x', y + f' y')

However, when tested with 8-by-8 chess board, the above function never stops, which is because the solution space is insanely large(19,591,828,170,979,904 different open tours according to 1). So I want to find only one solution. Fisrt, I tried:

-- First try    
head (knightsTour 8)

with the hope that Haskell's lazy evaluation may come to save the day. But that didn't happen, the solution still runs forever. Then, I tried：

-- second try

import Data.List (find)
import Data.Maybe (fromMaybe)

knightsTour' :: Int -> [(Int, Int)]
knightsTour' size = go 1 [(1, 1)]
  where
    maxSteps = size^2
    isValid (x, y) = x >= 1 && x <= size && y >= 1 && y <= size

    go :: Int -> [(Int, Int)] -> [(Int, Int)]
    go count acc | count == maxSteps = reverse acc
    go count acc =
      let
        nextSteps' = [step | step <- nextSteps (head acc), isValid step && step `notElem` acc]
      in
        fromMaybe [] (find (not . null) $ fmap (\step -> go (count+1) (step:acc)) nextSteps')
fs = replicateM 2 [(*1), (*(-1))]
nextSteps :: (Int, Int) -> [(Int, Int)]
nextSteps (x, y) = do
  (x', y') <- [(1, 2), (2, 1)]
  [f, f'] <- fs
  return (x + f x', y + f' y')

But the solution above still cannot deliver, because it still runs forever. My questions are:

1. Why can't lazy evaluation work as I expected to produce only the first solution found? In my opinion, in both tries, only the first solution is required.
2. How to change the code above to produce only the first solution?

Answer 1

So first the good news: your code is doing what you expect, and only producing the first solution!

That's also the bad news: it really is taking this long to even find the first solution. I think something you underestimate greatly is how many "dead ends" need to be encountered in order to produce a solution.

For example, here's a tweak of your initial version using the Debug.Trace module to let us know how many dead ends you encounter while trying to find the first path:

import Control.Monad
import Debug.Trace (trace)
import System.Environment (getArgs)

knightsTour :: Int -> [[(Int, Int)]]
knightsTour size = go 1 [(1, 1)]
  where
    maxSteps = size * size
    isValid (x, y) = x >= 1 && x <= size && y >= 1 && y <= size

    go :: Int -> [(Int, Int)] -> [[(Int, Int)]]
    go count acc | count == maxSteps = return $ reverse acc
    go count acc = do
      let nextPossible' = [ next |
                            next <- nextSteps (head acc)
                            , isValid next && next `notElem` acc]
          nextPossible = if null nextPossible'
            then trace ("dead end; count: " ++ show count) []
            else nextPossible'
      next <- nextPossible
      -- guard $ isValid next && next `notElem` acc
      go (count + 1) (next : acc)


fs = replicateM 2 [(*1), (*(-1))]
nextSteps :: (Int, Int) -> [(Int, Int)]
nextSteps (x, y) = do
  (x', y') <- [(1, 2), (2, 1)]
  [f, f'] <- fs
  return (x + f x', y + f' y')

main :: IO ()
main = do
  [n] <- getArgs
  print (head $ knightsTour (read n))

Now, let's see how much output that gives us for different board sizes:

/tmp$ ghc -o kntest -O2 kntest.hs 
[1 of 1] Compiling Main             ( kntest.hs, kntest.o )
Linking kntest ...
/tmp$ ./kntest 5 2>&1 | wc
   27366  109461  547424
/tmp$ ./kntest 6 2>&1 | wc
  783759 3135033 15675378
/tmp$ ./kntest 7 2>&1 | wc
  818066 3272261 16361596

Okay, so we encountered 27,365 dead ends on a board size of 5 and over 800 thousand dead ends on a board size of 7. For a board size of eight, I redirected it to a file:

/tmp$ ./kntest 8 2> kn8.deadends.txt

It's still running. At this point, it's encountered over 38 million dead ends:

/tmp$ wc -l kn8.deadends.txt 
 38178728 kn8.deadends.txt

How many of those dead ends were really close to the end?

/tmp$ wc -l kn8.deadends.txt ; fgrep 'count: 61' kn8.deadends.txt | wc -l ; fgrep 'count: 62' kn8.deadends.txt | wc -l; fgrep 'count: 63' kn8.deadends.txt | wc -l ; wc -l kn8.deadends.txt
 52759655 kn8.deadends.txt
    1448
       0
       0
 64656651 kn8.deadends.txt

So it's up to well over 64 million dead ends now and it still hasn't found a dead end longer than 61 steps.

And now it's at 85 million, and if I take too long to write the rest of this it could be at over 100 million by the time I finish this answer.

There are some things you might do to speed up your program (such as using a vector to track already visited spots rather than the O(n) notElem lookup), but fundamentally it's taking so long to get just the first answer because it's really much, much longer to the first answer than you initially thought.

---

EDIT: If you add a very simple, naive implementation of Warnsdorf's rule then you get the first knight's tour almost instantly even for very large (40x40) boards:

import Control.Monad
import System.Environment (getArgs)
import Data.List (sort)

knightsTour :: Int -> [[(Int, Int)]]
knightsTour size = go 1 [(1, 1)]
  where
    maxSteps = size * size
    isValid (x, y) = x >= 1 && x <= size && y >= 1 && y <= size

    getValidFor from acc = do
      next <- nextSteps from
      guard $ isValid next && next `notElem` acc
      return next

    go :: Int -> [(Int, Int)] -> [[(Int, Int)]]
    go count acc | count == maxSteps = return $ reverse acc
    go count acc = do
      let allPoss = getValidFor (head acc) acc
          sortedPossible = map snd $ sort $
                           map (\x -> (length $ getValidFor x acc, x))
                           allPoss
      next <- sortedPossible
      go (count + 1) (next : acc)

fs = replicateM 2 [(*1), (*(-1))]
nextSteps :: (Int, Int) -> [(Int, Int)]
nextSteps (x, y) = do
  (x', y') <- [(1, 2), (2, 1)]
  [f, f'] <- fs
  return (x + f x', y + f' y')

main :: IO ()
main = do
  [n] <- getArgs
  print (head $ knightsTour (read n))