[Haskell-cafe]
Re: Fun with Haskell, runST, MArray, and a few queens. (Imperative
Haskell Version)
David Sankel
camio at yahoo.com
Thu Mar 4 19:21:03 EST 2004
> I say this is a case of bad code. Of course language <foo> is faster and
> better if you write horribly bad code in language <bar>.
> Taking the first solution found by searching with google I get times
> around 0.015s (real) for the Haskell version and 1.7s for your Java
> solution (which also seems to be overcomplicated to me).
That's cool. Although the java algorithm is beyond any doubt
overcomplicated, I'd like to reproduce it using Haskell's imperative
constructs because not all backtracking algorithms have a simple closed form
solution. What I've done using monads is a little better in speed, but not
the huge improvement I was expecting. Any comments as to what I'm doing
wrong here?
Updated Table:
ghc 58.749s
ghc -O 12.580s
ghc -O (monad version) 8.284s
javac 1.088s
David
-------------- next part --------------
module Main where
import Control.Monad.ST
import GHC.Arr
import Maybe
import Ix
main = print $ runST something
n = 10
-- Used only for output
data Board = Board Int (Array (Int,Int) Int) deriving Eq
instance Show Board where
show (Board n b) = concat [ (printLine b a) ++ "\n" | a <- [n,n-1..1] ]
where
printLine board row = concat [ (str (board ! (row,a))) | a <- [1..n] ]
str (-1) = "q" --It's a queen
str 0 = "." --It's an empty spot
str a = show a --It's a spot that can be attacked by a queen
--Finds a solution given a board and a number of queens to put on it
solution board 0 = return True
solution board i =
do
possibleP <- (possiblePositions board)
trySolution possibleP
where
trySolution [] = return False
trySolution (c:cs) =
do
addQueen board c
good <- solution board (i-1)
if good then return True
else do
removeQueen board c
trySolution cs
--Returns all the positions on the board that do not have a queen and cannot
--be attacked by a queen already on the board.
-- possiblePositions board =
-- do
-- p <- sequence [ readSTArray board (row,column) >>=
-- (\a -> return (a == 0,(row,column)))
-- | row <- [1..n], column <- [1..n] ]
-- return $ map (\(_,b)->b) $ filter (\(a,_)-> a) p
possiblePositions board =
do
-- let indices = range $! boundsSTArray board
let indices = [ (row,column) | row <- [1..n], column <- [1..n] ]
p <- sequence $ map (\i -> readSTArray board i >>=
(\a -> if a == 0 then return $ Just i
else return Nothing
)) indices
-- return $ map (\(_,b)->b) $ filter fst p
return $ catMaybes p
arrayToBoard board =
do
it <- sequence [ readSTArray board (a,b) >>=
(\s -> return ((a,b),s))
| a <- [1..n], b <- [1..n] ]
return (Board n (array ((1,1),(n,n)) it))
emptyBoard = newSTArray ((1,1),(n,n)) 0
something = do
board <- emptyBoard
solution board n
arrayToBoard board
--Adds a queen to the board and adds 1 in all the positions the queen
--could feasible move.
addQueen b c = do
queenHelper b (+1) c
writeSTArray b c (-1)
--Removes a queen from the board and subtracts 1 in all the positions the queen
--could have feasibly moved.
removeQueen b c = do
queenHelper b (\a -> a - 1) c
writeSTArray b c 0
--Helper function to update arrays
(/-) array s =
do sequence_ [
readSTArray array b >>=
\n -> writeSTArray array b $! (c n) | (b,c) <- s ]
return array
queenHelper board f (row,column) = do
board /- (horizontal ++ vertical ++ negPosDiag ++ posNegDiag ++ negNegDiag ++ posPosDiag)
where
vertical = [ ((r,column),f) | r <- [1..n] ]
horizontal = [ ((row,c),f) | c <- [1..n] ]
negPosDiag = [ ((row-i,column+i),f)| i <- [1..(min (n-column) (row-1))]]
posNegDiag = [ ((row+i,column-i),f)| i <- [1..(min (column-1) (n-row))]]
negNegDiag = [ ((row-i,column-i),f)| i <- [1..(min (column-1) (row-1))]]
posPosDiag = [ ((row+i,column+i),f)| i <- [1..(min (n-column) (n-row))]]
More information about the Haskell-Cafe
mailing list