
Chess coaches have been known to inflict a kind of torture on beginners by taking a chess board, placing pennies on some squares and requiring that a Knight's tour be constructed that avoids the squares with pennies.

This kind of knight's tour puzzle is similar to   Hidato.

The present task is to produce a solution to such problems. At least demonstrate your program by solving the following:



Example

  0 0 0 
  0   0 0 
  0 0 0 0 0 0 0
0 0 0     0   0
0   0     0 0 0
1 0 0 0 0 0 0
    0 0   0
      0 0 0

Note that the zeros represent the available squares, not the pennies.

Extra credit is available for other interesting examples.



Related tasks

 A* search algorithm
 Knight's tour
 N-queens problem
 Solve a Hidato puzzle
 Solve a Hopido puzzle
 Solve a Numbrix puzzle
 Solve the no connection puzzle


import Data.Array
       (Array, (//), (!), assocs, elems, bounds, listArray)
import Data.Foldable (forM_)
import Data.List (intercalate, transpose)
import Data.Maybe
 
type Position = (Int, Int)
 
type KnightBoard = Array Position (Maybe Int)
 
toSlot :: Char -> Maybe Int
toSlot '0' = Just 0
toSlot '1' = Just 1
toSlot _ = Nothing
 
toString :: Maybe Int -> String
toString Nothing = replicate 3 ' '
toString (Just n) = replicate (3 - length nn) ' ' ++ nn
  where
    nn = show n
 
chunksOf :: Int -> [a] -> [[a]]
chunksOf _ [] = []
chunksOf n xs =
  let (chunk, rest) = splitAt n xs
  in chunk : chunksOf n rest
 
showBoard :: KnightBoard -> String
showBoard board =
  intercalate "\n" . map concat . transpose . chunksOf (height + 1) . map toString $
  elems board
  where
    (_, (_, height)) = bounds board
 
toBoard :: [String] -> KnightBoard
toBoard strs = board
  where
    height = length strs
    width = minimum (length <$> strs)
    board =
      listArray ((0, 0), (width - 1, height - 1)) . map toSlot . concat . transpose $
      take width <$> strs
 
add
  :: Num a
  => (a, a) -> (a, a) -> (a, a)
add (a, b) (x, y) = (a + x, b + y)
 
within
  :: Ord a
  => ((a, a), (a, a)) -> (a, a) -> Bool
within ((a, b), (c, d)) (x, y) = a <= x && x <= c && b <= y && y <= d
 
-- Enumerate valid moves given a board and a knight's position.
validMoves :: KnightBoard -> Position -> [Position]
validMoves board position = filter isValid plausible
  where
    bound = bounds board
    plausible =
      add position <$>
      [(1, 2), (2, 1), (2, -1), (-1, 2), (-2, 1), (1, -2), (-1, -2), (-2, -1)]
    isValid pos = within bound pos && maybe False (== 0) (board ! pos)
 
isSolved :: KnightBoard -> Bool
isSolved = all (maybe True (0 /=))
 
-- Solve the knight's tour with a simple Depth First Search.
solveKnightTour :: KnightBoard -> Maybe KnightBoard
solveKnightTour board = solve board 1 initPosition
  where
    initPosition = fst $ head $ filter ((== Just 1) . snd) $ assocs board
    solve boardA depth position =
      let boardB = boardA // [(position, Just depth)]
      in if isSolved boardB
           then Just boardB
           else listToMaybe $
                mapMaybe (solve boardB $ depth + 1) $ validMoves boardB position
 
tourExA :: [String]
tourExA =
  [ " 000    "
  , " 0 00   "
  , " 0000000"
  , "000  0 0"
  , "0 0  000"
  , "1000000 "
  , "  00 0  "
  , "   000  "
  ]
 
tourExB :: [String]
tourExB =
  [ "-----1-0-----"
  , "-----0-0-----"
  , "----00000----"
  , "-----000-----"
  , "--0--0-0--0--"
  , "00000---00000"
  , "--00-----00--"
  , "00000---00000"
  , "--0--0-0--0--"
  , "-----000-----"
  , "----00000----"
  , "-----0-0-----"
  , "-----0-0-----"
  ]
 
main :: IO ()
main =
  forM_
    [tourExA, tourExB]
    (\board ->
        case solveKnightTour $ toBoard board of
          Nothing -> putStrLn "No solution.\n"
          Just solution -> putStrLn $ showBoard solution ++ "\n")