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


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


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 =
  [ "
  , "
  , "
  , "
  , "
  , "00000
  , "
  , "00000
  , "
  , "
  , "
  , "
  , "
  ]

main :: IO ()
main =
  forM_
    [tourExA, tourExB]
    (\board ->
        case solveKnightTour $ toBoard board of
          Nothing -> putStrLn "No solution.\n"
          Just solution -> putStrLn $ showBoard solution ++ "\n")