Поиск одного решения Knight's Tour в Haskell

Итак, сначала хорошие новости: ваш код делает то, что вы ожидаете, и выдает только первое решение!

Это также и плохая новость: на то, чтобы найти первое решение, действительно уходит так много времени. Я думаю, что вы сильно недооцениваете, сколько «тупиков» нужно встретить, чтобы найти решение.

Например, вот изменение вашей первоначальной версии с использованием модуля Debug.Trace, чтобы сообщить нам, сколько тупиков вы встретите, пытаясь найти первый путь:

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

Теперь давайте посмотрим, какой результат мы получаем для разных размеров платы:

/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

Итак, мы обнаружили 27 365 тупиков на доске размером 5 и более 800 тысяч тупиков на доске размером 7. Для доски размером восемь я перенаправил их в файл:

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

Он все еще работает. На данный момент он столкнулся с более чем 38 миллионами тупиков:

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

Сколько из этих тупиков были действительно близки к концу?

/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

Таким образом, сейчас уже более 64 миллионов тупиков, и он до сих пор не нашел тупика длиннее 61 шага.

И теперь это 85 миллионов, и если я буду слишком долго писать остальную часть этого, то к тому времени, когда я закончу этот ответ, их может быть более 100 миллионов.

Есть некоторые вещи, которые вы могли бы сделать, чтобы ускорить вашу программу (например, использовать вектор для отслеживания уже посещенных мест, а не поиск O(n) notElem), но в основном получение первого ответа занимает так много времени, потому что это действительно много. , гораздо дольше до первого ответа, чем вы изначально думали.

РЕДАКТИРОВАТЬ: Если вы добавите очень простую, наивную реализацию правила Варнсдорфа то вы получаете первый конный тур практически мгновенно даже для очень больших (40х40) досок:

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