[Haskell-cafe] New Benchmark Under Review: Magic Squares

[Daniel Fischer]

Hi,
I have now tuned Josh Goldfoot's code without changing the order in which the 
magic squares are produced, for a 5x5 magic square, my machine took about 1 
1/2 hours and used 2Mb memory (considering that the original code did not 
finish within 4 1/2 hours here, that should push time on the benchmarking 
machine under 3000s and put us in the lead, I hope).
However, with the improved bounds for the possibilities, I can now get a 5x5 
square in 1s, a 6x6 square in 5.5s (replacing intersect by takeWhile & 
dropWhile), so it's still sloooowwww.

Brent, can I informally submit the code thus, or what formalities would I have 
to perform to submit my code?

---------------------------------------------------------------------------------------------------
{- The Computer Language Shootout
   http://shootout.alioth.debian.org/

   benchmark implementation
   contributed by Josh Goldfoot
   modified by Daniel Fischer to improve performance -}

{- An implementation using Data.Graph would be much faster.  This 
implementation
  is designed to demonstrate the benchmark algorithm. -}

import Data.Array
import Data.List
import System (getArgs)

main = do
    n <- getArgs >>= return . read . head
    let mn = (n * (1 + n * n)) `div` 2 -- the magic number
        initialNode = makeSquare n mn (listArray ((1,1),(n,n)) (repeat 0), [1 
.. n^2])
        allSquares = bestFirst (successorNodes n mn) (initialNode:[])
    putStrLn $ printMatrix n $ grid $ head allSquares
    where
        printMatrix n grid = unlines [ (rowlist grid n y) | y <- [1..n]]
            where
                rowlist grid n y = unwords [show $ grid ! (x,y) | x <- [1..n]]

data Square = Square { grid :: Array (Int,Int) Int,
                       ffm :: ([Int], Int, Int),
                       unused :: [Int],
                       priority :: !Int }

{- bestFirst:  Given a queue with one initial node and a function, successors,
    that takes a node and returns a list of nodes that are created by making
    all possible moves in a single cell, implements the Best-First algorithm,
    and returns a list of all nodes that end up with priority zero.  In this
    implementation we only ever use the first node.
-}
bestFirst _ [] = []
bestFirst successors (frontnode:priorityq)
    | priority frontnode == 0 = frontnode:bestFirst successors priorityq
    | otherwise = bestFirst successors $ foldr (insertBy compSquare) priorityq 
(successors frontnode)
    where
        {- The priority queue is sorted first by
           the node's calculated priority; then, if the priorities
           are equal, by whichever node has the lowest numbers
           in the top-left of the array (or the next cell over,
           and so on). -}
        compSquare a b = case compare (priority a) (priority b) of
                            EQ -> compare (grid a) (grid b)
                            ot -> ot

{- successorNodes: Find the cell with the fewest
    possible moves left, and then creates a new node for each possible move
    in that cell.
-}
successorNodes n mn squarenode =
    map (makeSquare n mn) [(thegrid//[((x, y), i)], delete i un) | i <- 
possibilities]
    where
        thegrid = grid squarenode
        un = unused squarenode
        (possibilities, x, y) = ffm squarenode

{- makeSquare: Creates a node for the priority queue.  In the process, this
    calculates the cell with the fewest possible moves, and also calculates
    this node's priority.  The priority function is:
        (number of zeros in the grid)
           plus
        (number of possible moves in the cell with the fewest possible moves)
    the lower the priority, the sooner the node will be popped from the queue.
-}
makeSquare n mn (thegrid,un) =
    Square { grid = thegrid, ffm = moveChoices, unused = un, priority = 
calcPriority }
    where
        moveChoices@(poss,_,_) = findFewestMoves n mn thegrid un
        calcPriority = length un + length poss

{- findFewestMoves:  Go through the grid (starting at the top-left, and moving
     right and down), checking all 0 cells to find the cell with the fewest
     possible moves.
-}
findFewestMoves n mn grid un
    | null un = ([],0,0)
    | otherwise = (movelist, mx, my)
    where
        openSquares = [ (x,y) | y <- [1..n], x <- [1..n], (grid ! (x,y)) == 0]
        pm = possibleMoves n mn grid un
        openMap = map (\(x,y) -> (pm (x,y), (x,y))) openSquares
        mycompare f g = compare ((length . fst) f) ((length . fst) g)
        (movelist, (mx, my)) = minimumBy mycompare openMap

{- possibleMoves: Return all moves that can go in the cell x,y for a given
    grid.  A move is possible if the move (number) is not already
     in the grid, and if, after making that move, it is still possible to
     satisfy the magic square conditions (all rows, columns, diagonals adding
     up to mn, the magic number)
-}
possibleMoves n mn grid un (x,y)
    | grid ! (x,y) /= 0 = []
    | null oneZeroGroups = takeWhile (<= highest) un -- [1 .. highest] 
`intersect` un
    | otherwise = case onePossible of
                    [p] | p `elem` un -> [p]
                    _                 -> []
    where
        cellGroups
            | x + y == n + 1 && x == y = [diag1 grid n, diag2 grid n, theRow, 
theCol]
            | x == y = [diag1 grid n, theRow, theCol]
            | x + y == n + 1 = [diag2 grid n, theRow, theCol ]
            | otherwise = [theRow, theCol]
        theRow = gridRow grid n x y
        theCol = gridCol grid n x y
        oneZeroGroups = filter (\x -> count 0 x == 1) cellGroups
        onePossible = nub ( [mn - (sum g) | g <- oneZeroGroups ] )
        highest = minimum ( (n*n):[mn - (sum g) | g <- cellGroups] )

{- Utility functions to extract a single row, column, or diagonal. -}
gridRow grid n _ y = [grid ! (xx, y) | xx <- [1..n]]
gridCol grid n x _ = [grid ! (x, yy) | yy <- [1..n]]
diag1 grid n = [grid ! (i, i) | i <- [1..n]]
diag2 grid n = [grid ! (i, n - i + 1) | i <- [1..n]]

{- Returns the number of times n appears n list xs -}
count n xs = length $ filter ((==) n) xs

---------------------------------------------------------------------------------------------------

Am Sonntag, 2. Juli 2006 01:58 schrieb Brent Fulgham:
> We recently began considering another benchmark for the shootout,
> namely a Magic Square via best-first search.  This is fairly
> inefficient, and we may need to shift to another approach due to the
> extremely large times required to find a solution for larger squares.
>
> I thought the Haskell community might be interested in the
> performance we have measured so far (see "http://
> shootout.alioth.debian.org/sandbox/fulldata.php?
> test=magicsquares&p1=java-0&p2=javaclient-0&p3=ghc-0&p4=psyco-0"
>
> Interestingly, Java actually beats the tar out of GHC and Python for
> N=5x5 (and I assume higher, though this already takes on the order of
> 2 hours to solve on the benchmark machine).  Memory use in GHC stays
> nice and low, but the time to find the result rapidly grows.
>
> I was hoping for an order of magnitude increase with each increase in
> N, but discovered that it is more like an exponential...
>
> Thanks,
>
> -Brent

Cheers,
Daniel

-- 

"In My Egotistical Opinion, most people's C programs should be
indented six feet downward and covered with dirt."
	-- Blair P. Houghton