Where is a good place to place code like this, so if I may be so bold, people can learn from it? {- Author Modifications: Casey Hawthorne Author Original: Jeff Newbern Maintainer: Casey Hawthorne <caseyh@istar.ca> Maintainer?: Jeff Newbern <jnewbern@nomaware.com> Time-stamp: Jeff <Tue Aug 19 09:31:32 2003> Time-stamp: Casey <Sat Nov 14 10:10 2009> License: GPL The N-queens puzzle is to place N queens on an N by N chess board so that no queen can attack another one. Compiler Flags: ghc -O2 -fvia-c --make N-Queens.hs Description http://www.haskell.org/all_about_monads/html/stacking.html#example Original Code http://www.haskell.org/all_about_monads/examples/example25.hs -} {- Description Example 25 - Using the StateT monad transformer with the List monad to achieve non-deterministic stateful computations, and the Writer monad to do logging Usage: Compile the code and run it with an argument between 1 and 8. It will print a solution to the N-queens puzzle along with a log of the number of choices it had at each step. The N-queens puzzle is to place N queens on a chess board so that no queen can attack another one. The original version always used an 8x8 board. Try: ./ex25 8 ./ex25 1 ./ex25 7 Added by Casey: - different board sizes -- up to a maximum 26x26 square board - updated imports list -} import IO import System import Monad import Data.Maybe import Data.List import Data.Char (toLower) import Control.Monad.State import Control.Monad.Writer -- describe Chess Units and positions type Rank = Int data File = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | X | Y | Z deriving (Eq, Show, Ord, Enum) data Position = Pos {file::File, rank::Rank} deriving Eq instance Show Position where show (Pos f r) = (map toLower (show f)) ++ (show r) instance Ord Position where compare p1 p2 = case (rank p1) `compare` (rank p2) of LT -> GT GT -> LT _ -> (file p1) `compare` (file p2) data Kind = Pawn | Knight | Bishop | Rook | Queen | King deriving (Eq, Ord, Enum) instance Show Kind where show Pawn = "P" show Knight = "N" show Bishop = "B" show Rook = "R" show Queen = "Q" show King = "K" data Color = Black | White deriving (Eq, Ord, Enum) instance Show Color where show Black = "b" show White = "w" data Unit = Unit {color::Color, kind::Kind} deriving (Eq, Ord) instance Show Unit where show (Unit c k) = ((show c) ++ (show k)) data Board = Board {size::Int, psns::[(Unit,Position)]} -- newtype Board = Board [(Unit,Position)] -- newtype BoardMax = BoardMax Int instance Show Board where show (Board n ps) = let ordered = (sort . swap) ps ranks = map (showRank ordered) [n,(n-1)..1] board = intersperse (concat (take n (repeat "--+"))) ranks rlabels = intersperse " " (map (\n->(twoSpaces n)++" ") [n,(n-1)..1]) flabels = take (n*3) " a b c d e f g h i j k l m n o p q r s t u v w x y z" twoSpaces n | length (show n) == 2 = show n | otherwise = " " ++ (show n) in unlines $ zipWith (++) rlabels board ++ [flabels] where swap = map (\(a,b)->(b,a)) showRank ps r = let rnk = filter (\(p,_)->(rank p)==r) ps cs = map (showUnit rnk) (take n [A .. Z]) in concat (intersperse "|" cs) showUnit ps f = maybe " " (show . snd) (find (\(p,_)->(file p)==f) ps) data Diagonal = Ascending Position | Descending Position deriving (Eq, Show) -- define the diagonal according to its interesction with rank 1 or size of board) -- or with file a normalize :: Int -> Diagonal -> Diagonal normalize n d@(Ascending psn) | (rank psn) == 1 = d | (file psn) == A = d | otherwise = normalize n (Ascending (Pos (pred (file psn)) ((rank psn)-1))) normalize n d@(Descending psn) | (rank psn) == n = d | (file psn) == A = d | otherwise = normalize n (Descending (Pos (pred (file psn)) ((rank psn)+1))) -- get the diagonals corresponding to a location on the board getDiags :: Int -> Position -> (Diagonal,Diagonal) getDiags n p = (normalize n (Ascending p), normalize n (Descending p)) -- this is the type of our problem description data NQueensProblem = NQP {board::Board, ranks::[Rank], files::[File], asc::[Diagonal], desc::[Diagonal]} -- initial state = empty board, all ranks, files, and diagonals free initialState n = let fileA = map (\r->Pos A r) [1..n] rankMax = map (\f->Pos f n) (take n [A .. Z]) rank1 = map (\f->Pos f 1) (take n [A .. Z]) asc = map Ascending (nub (fileA ++ rank1)) desc = map Descending (nub (fileA ++ rankMax)) in NQP (Board n []) [1..n] (take n [A .. Z]) asc desc -- this is our combined monad type for this problem type NDS a = WriterT [String] (StateT NQueensProblem []) a -- Get the first solution to the problem, by evaluating the solver computation with -- an initial problem state and then returning the first solution in the result list, -- or Nothing if there was no solution. getSolution :: NDS a -> NQueensProblem -> Maybe (a,[String]) getSolution c i = listToMaybe (evalStateT (runWriterT c) i) -- add a Queen to the board in a specific position addQueen :: Position -> NDS () addQueen p = do (Board n b) <- gets board rs <- gets ranks fs <- gets files as <- gets asc ds <- gets desc let b' = (Unit Black Queen, p):b rs' = delete (rank p) rs fs' = delete (file p) fs (a,d) = getDiags n p as' = delete a as ds' = delete d ds tell ["Added Queen at " ++ (show p)] put (NQP (Board n b') rs' fs' as' ds') -- test if a position is in the set of allowed diagonals inDiags :: Int -> Position -> NDS Bool inDiags n p = do let (a,d) = getDiags n p as <- gets asc ds <- gets desc return $ (elem a as) && (elem d ds) -- add a Queen to the board in all allowed positions addQueens :: NDS () addQueens = do rs <- gets ranks fs <- gets files (Board n b) <- gets board allowed <- filterM (inDiags n) [Pos f r | f <- fs, r <- rs] tell [show (length allowed) ++ " possible choices"] msum (map addQueen allowed) -- Start with an empty chess board and add the requested number of queens, -- then get the board and print the solution along with the log main :: IO () main = do args <- getArgs let n = read (args!!0) cmds = replicate n addQueens sol = (`getSolution` (initialState n)) $ do sequence_ cmds gets board case sol of Just (b,l) -> do putStr $ show b -- show the solution putStr $ unlines l -- show the log Nothing -> putStrLn "No solution" -- END OF FILE -- Regards, Casey