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:
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))