[Haskell-cafe] Re: Fun with Haskell, runST, MArray, and a few queens. (Imperative Haskell Version)

[David Sankel]

> 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))]]