[Haskell-cafe] Where is a good place to place code like this, so if I may be so bold, people can learn from it?

[Casey Hawthorne]

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 at istar.ca>
   Maintainer?: Jeff Newbern <jnewbern at 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