Knight Tour at Haskell Hoodlums

KnightTour.hs

module Main where

import Data.Array
import Data.List
import Data.Ord
import Text.Printf

type Coord = (Int, Int)
type Size = (Int, Int)

data Board = Board (Array Coord Int) Coord Int

instance Show Board where
  show (Board arr _ _) = unlines $
                         map printRow (rows arr)

    where rows arr = map (map snd) $
                     groupBy (\((x, _), _) ((y, _), _) -> x == y) $
                     assocs arr
          printRow = unwords . map (printf "%3d")

newBoard :: Size -> Board
newBoard (x, y) = Board (listArray ((1,1), (x,y)) (repeat 0)) (0,0) 0

visit :: Coord -> Board -> Board
visit c (Board arr _ no) = Board (arr // [(c, no + 1)]) c (no + 1)

isVisited :: Coord -> Board -> Bool
isVisited c (Board arr _ _) = arr ! c /= 0

size :: Board -> Size
size (Board arr _ _) = snd $ bounds arr

b5 :: Board
b5 = newBoard (5, 5)

moves :: Size -> Coord -> [Coord]
moves (m, n) (x, y) =
  filter isInside
  [ (x-2, y-1)
  , (x-2, y+1)
  , (x-1, y-2)
  , (x-1, y+2)
  , (x+1, y-2)
  , (x+1, y+2)
  , (x+2, y-1)
  , (x+2, y+1)
  ]
  where
    isInside (x, y) = x >= 1 && x <= m && y >= 1 && y <= n

legalMoves :: Board -> Coord -> [Coord]
legalMoves b c = filter (not . flip isVisited b) $ moves sz c
  where sz = size b

start :: Board -> Board
start = visit (1,1)

next :: Board -> [Board]
next b@(Board _ lastMove _) = [visit nextMove b | nextMove <- legalMoves b lastMove]

nextHeur :: Board -> [Board]
nextHeur board = [minimumBy (comparing f) nb]
  where f b@(Board _ lastMove _) = length $ legalMoves b lastMove
        nb = next board

nextHeur10 :: Board -> [Board]
nextHeur10 board = (sortBy (comparing f) $ take 10 nb) ++ drop 10 nb
  where f b@(Board _ lastMove _) = length $ legalMoves b lastMove
        nb = next board

tour :: (Board -> [Board]) -> Coord -> Board -> Board
tour nextFunc s0 b = head $ (!!(sz-1)) $
                     iterate (concatMap nextFunc) [visit s0 b]
  where
    (m, n) = size b
    sz = m * n

main :: IO ()
main = print $ tour nextHeur (1, 1) $ newBoard (20, 20)