N-queens solver

nqueens.hs

import Data.List
import Data.Maybe
import Data.Monoid

-- The hard stuff

solve' :: Int -> [(Int, Int)] -> [(Int, Int)] -> Solutions
solve' nq queens board
    | length queens == nq = Solutions [Solution nq queens]
    | length board == 0   = mempty
    | otherwise           = mconcat $ map (attempt) board
    where attempt q = solve' nq (q:queens) $ next q
          next p = filter (not . threatened p) board

-- Typestypestypes

data Solution = Solution {
    boardSize :: Int,
    list :: [(Int,Int)]
} deriving (Ord)

newtype Solutions = Solutions { solutions :: [Solution] } deriving (Show)

permute (Solution n l) = sort
  . map (sort) . concat
  . map (take 2 . iterate (map (swap)))
  . take 4 $ iterate (map (rotate)) l
    where swap (x,y) = (y,x)
          rotate (x,y) = (n-1-y,x)

instance Monoid Solutions where
    mempty = Solutions []
    (Solutions a) `mappend` (Solutions b) = Solutions (union a b)

instance Eq Solution where
    a == b = elem (sort $ list a) (permute b)

instance Show Solution where
    show s = unwords ["Solution",size s,list' s]
        where size = show . boardSize
              list' = show . sort . list

-- For great GHCI justice

draw (Solution n l) = unlines
  . map (map (snd)) . groupBy (first)
  . map (row) . group . sort $ l ++ boardSized n
    where first (a,_) (b,_) = a == b
          row l@((x,y):ps)
            | null ps   = (x,'.')
            | otherwise = (x,'Q')

threatened :: (Int, Int) -> (Int,Int) -> Bool
threatened (qx,qy) (x,y) = x == qx || y == qy || x + y == qx + qy || y - x == qy - qx

boardSized :: Int -> [(Int, Int)]
boardSized w = [(x,y) | x <- [0..w-1], y <- [0..w-1]]

solve :: Int -> Solutions
solve n = solve' n [] $ boardSized n