Finds solutions to the Knight's Tour problem on arbitrarily-sized boards and from any starting position.

Knight.hs

import Control.Applicative
import Data.Maybe
import Debug.Trace

data Board =    Board [[Bool]]
                deriving (Eq, Show)

newBoard :: Board
newBoard = newBoard' 8 8
        where   newBoard' x y = Board $ take y $ repeat $ take x $ repeat False

data Position a = Position (a, a)
                deriving (Eq, Show)

instance Functor Position where
    fmap f (Position (x, y)) = Position (f x, f y)

instance Applicative Position where
    pure x = Position (x, x)
    (Position (f, g)) <*> (Position (x, y)) = Position (f x, g y)

instance Num a => Num (Position a) where
    (+)         = (<*>) . (<$>) (+)
    (-)         = (<*>) . (<$>) (-)
    (*)         = (<*>) . (<$>) (*)
    abs         = fmap abs
    signum      = fmap signum
    fromInteger = pure . fromInteger

start :: Position Int
start = Position (0, 0)

solve :: Board -> [Position Int] -> (Position Int) -> [Position Int]
--solve b m p | trace (show b) False = undefined
solve b m p | (boardFull b)             = m
            | positionVisited b p       = []
            | otherwise                 = if next /= [] then head next else []
            where   updatedBoard        = updateBoard b p
                    next                = filter (/= []) $ map (solve updatedBoard (p:m)) (nextPositions updatedBoard p)

updateBoard :: Board -> (Position Int) -> Board
updateBoard = replaceBoardElement True

replaceBoardElement :: Bool -> Board -> (Position Int) -> Board
replaceBoardElement bool (Board board) (Position (x, y)) = Board (replacexy board)
        where   replacexy = replace (\ y' a -> if y' == y then (replacex a) else a)
                replacex  = replace (\ x' b -> if x' == x then bool else b)

replace :: (Int -> a -> b) -> [a] -> [b]
replace = replace' 0
        where   replace' _ _ [] = []
                replace' counter f (x:xs) = (f counter x):(replace' (counter + 1) f xs)

boardFull :: Board -> Bool
boardFull (Board b) = and $ concat b

nextPositions :: Board -> (Position Int) -> [Position Int]
nextPositions b p = filter (withinBoard b) ((+ p) <$> relativePositions)
        where   relativePositions = [(Position (i, j)) | i <- [-2, -1, 1, 2], j <- [-2, -1, 1, 2], (abs i) /= (abs j)]
                withinBoard (Board board) (Position (x, y)) = (withinDimension board y) && (withinDimension (board !! y) x)
                        where   withinDimension list position = 0 <= position && position < (length list)

positionVisited :: Board -> (Position Int) -> Bool
positionVisited (Board b) (Position (x, y)) = (b !! y) !! x

main = print $ solve newBoard [] start