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

[Daniel Fischer]

Am Mittwoch, 5. Juli 2006 21:28 schrieben Sie:
> Hi Daniel,
>
> In the paragraph below it looks like you improved the performance of
> 5x5 from one and one half hours to one second.  Is that a typo or
> should I be very, very impressed. :-)
>
> Cheers, David

Err, neither, really. Apparently, I haven't expressed myself immaculately 
clearly, so let me try again.
Josh Goldfoot's original code produced a 5x5 magic square on the benchmarking 
computer in 8063.01s, on my computer, I hit ctrl-C after about 4 1/2 hours.
My first version produced a 5x5 square in a little over 4 seconds (or was it a 
little over 5s, I'm not sure), and a 6x6 square in 86.5s, but since I used 
better bounds for the possible moves - e.g., if we regard a 5x5 square with 
two entries, 1 at (1,1) and 2 at (1,2), JG's code would give [3 .. 25] as the 
list of possible moves for (1,3), whereas I took into account that the sum of 
(1,4) and (1,5) is at most 24 + 25 = 49 (and at least 3+4, but that doesn't 
help here), thus finding that (1,3) must be at leat 65 - (1+2) - 49 = 13 and 
[13 .. 25] as the list of possible moves. So I avoided a lot of dead ends, 
but produced a different magic square.
This code I have pushed down to 1s for the 5x5 square and 5.4s for the 6x6 
square (simply by replacing "intersect [a .. b]" with "takeWhile (<= b) : 
dropWhile (< a)").
I have then tuned Josh Goldfoot's code (throwing out the List <-> Set 
conversions, keeping a list of unused numbers and not much else), so that it 
produced a 5x5 square in 1 1/2 hours on my computer, giving the same list of 
possible moves as the original and hence the same magic square.
That's not bad, but not really awe-inspiring.
However, I've also combined the algorithms, using my better bounds, thus 
avoiding many dead ends, but calculating the priorities as if I used the 
original bounds, so exploring the branches in the same order and producing 
the same square as the original.
This took about 12 minutes for a 5x5 square and impressed me - I expected it 
to be significantly slower than the fast code, but a factor of 720 was much 
more than I dreamed of.

Cheers,
Daniel

>
> On Jul 4, 2006, at 6:48 AM, Daniel Fischer wrote:
> > 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
> >
> > _______________________________________________
> > Haskell-Cafe mailing list
> > Haskell-Cafe at haskell.org
> > http://www.haskell.org/mailman/listinfo/haskell-cafe
>
> --------------------------------
> David F. Place
> mailto:d at vidplace.com

-- 

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