beala/eightQueens.hs

## eightQueens.hs
import Control.Monad.Logic
import Control.Monad.Logic.Class
import Data.Foldable (msum, traverse_)
import Data.List (elem)

main :: IO ()
main = do
  let allSolutions = observeAll queens
  traverse_ (putStrLn . prettyBoard) allSolutions
  putStrLn ("Number of solutions: " ++ (show (length allSolutions)))


type Pos = (Int, Int)
type Board = [Pos]

-- Return boards that are solutions to the 8 queens problem.
queens :: Logic Board
queens = do
  board <- boards    -- Get all boards where no queens are on the same row or column.
  ifte (do threatened <- fromList board >>= diag -- Get all diagonally threatened positions.
           occupied   <- fromList board          -- Get the position of every queen on the board.
           guard (occupied == threatened))       -- Check if any queen is on any threatened position.
       (const mzero)  -- Yield nothing if a queen is on a threatened position.
       (return board) -- Otherwise, yield the board.

-- Return all positions diagonal from the position specified.
diag :: Pos -> Logic Pos
diag (x,y) = do
  offset <- fromList ([-7..(-1)] ++ [1..7])
  -- Diagonals are:
  mplus (return (x+offset, y+offset)) -- Positions with an equal offset.
        (return (x+offset, y-offset)) -- Positions with an equal and opposite offset.

-- Generate board states that have the potential to be solutions.
-- Concretely, this means only one queen per row and column.
boards :: Logic Board
boards = do
  rows <- permute [1..8]   -- Permute all rows.
  return (zip [1..8] rows) -- Join each row with a column.

-- Generate all permutations of a list. I could use permute in the
-- standard library, but I couldn't pass up this beautiful
-- implementation from the original LogicT paper: "Backtracking,
-- Interleaving, and Terminating Monad Transformers"
permute :: [a] -> Logic [a]
permute [] = return []
permute (h:t) = do
  t' <- permute t
  insert h t'

-- Insert the element into every position.
insert :: a -> [a] -> Logic [a]
insert e [] = return [e]
insert e l@(h:t) =
  return (e:l) `mplus` do
    t' <- insert e t
    return (h:t')

-- Utility function from transforming [a] into Logic a
fromList :: [a] -> Logic a
fromList = msum . fmap return

-- Pretty print the board.
prettyBoard :: Board -> String
prettyBoard board = do
  r <- [1..8]
  c <- [1..9]
  symbol (r,c)
  where
    symbol (r,c)
      | elem (r,c) board = " Q "
      | c == 9         = "\n"
      | otherwise      = " - "
	import Control.Monad.Logic
	import Control.Monad.Logic.Class
	import Data.Foldable (msum, traverse_)
	import Data.List (elem)

	main :: IO ()
	main = do
	let allSolutions = observeAll queens
	traverse_ (putStrLn . prettyBoard) allSolutions
	putStrLn ("Number of solutions: " ++ (show (length allSolutions)))


	type Pos = (Int, Int)
	type Board = [Pos]

	-- Return boards that are solutions to the 8 queens problem.
	queens :: Logic Board
	queens = do
	board <- boards -- Get all boards where no queens are on the same row or column.
	ifte (do threatened <- fromList board >>= diag -- Get all diagonally threatened positions.
	occupied <- fromList board -- Get the position of every queen on the board.
	guard (occupied == threatened)) -- Check if any queen is on any threatened position.
	(const mzero) -- Yield nothing if a queen is on a threatened position.
	(return board) -- Otherwise, yield the board.

	-- Return all positions diagonal from the position specified.
	diag :: Pos -> Logic Pos
	diag (x,y) = do
	offset <- fromList ([-7..(-1)] ++ [1..7])
	-- Diagonals are:
	mplus (return (x+offset, y+offset)) -- Positions with an equal offset.
	(return (x+offset, y-offset)) -- Positions with an equal and opposite offset.

	-- Generate board states that have the potential to be solutions.
	-- Concretely, this means only one queen per row and column.
	boards :: Logic Board
	boards = do
	rows <- permute [1..8] -- Permute all rows.
	return (zip [1..8] rows) -- Join each row with a column.

	-- Generate all permutations of a list. I could use permute in the
	-- standard library, but I couldn't pass up this beautiful
	-- implementation from the original LogicT paper: "Backtracking,
	-- Interleaving, and Terminating Monad Transformers"
	permute :: [a] -> Logic [a]
	permute [] = return []
	permute (h:t) = do
	t' <- permute t
	insert h t'

	-- Insert the element into every position.
	insert :: a -> [a] -> Logic [a]
	insert e [] = return [e]
	insert e l@(h:t) =
	return (e:l) `mplus` do
	t' <- insert e t
	return (h:t')

	-- Utility function from transforming [a] into Logic a
	fromList :: [a] -> Logic a
	fromList = msum . fmap return

	-- Pretty print the board.
	prettyBoard :: Board -> String
	prettyBoard board = do
	r <- [1..8]
	c <- [1..9]
	symbol (r,c)
	where
	symbol (r,c)
	\| elem (r,c) board = " Q "
	\| c == 9 = "\n"
	\| otherwise = " - "