[Haskell-cafe] New Benchmark Under Review: Magic Squares
Daniel Fischer
daniel.is.fischer at web.de
Wed Jul 5 19:18:21 EDT 2006
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
More information about the Haskell-Cafe
mailing list