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

[Donald Bruce Stewart]

Perhaps you could post a new entry page on our shootout wiki?

    http://www.haskell.org/hawiki/ShootoutEntry

This makes it easier for people to keep contributing.

Cheers,
  Don

daniel.is.fischer:
> 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.
> 
> A slightly less naive approach to determining the possible moves dramatically 
> reduces the effort, while Josh Goldfoot's code did not finish within 4 1/2 
> hours on my machine, a simple modification (see below) reduced runtime for 
> N = 5 to 4.3 s, for N = 6 to 86.5 s. 
> Unfortunately, the squares are now delivered in a different order, so my 
> programme would probably be rejected :-(
> 
> >
> > 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
> 
> Modified code, still best-first search:
> 
> import Data.Array.Unboxed
> import Data.List
> import System.Environment (getArgs)
> 
> main :: IO ()
> main = getArgs >>= return . read . head >>= msquare
> 
> msquare :: Int -> IO ()
> msquare n = let mn = (n*(n*n+1)) `quot` 2
>                 grd = listArray ((1,1),(n,n)) (repeat 0)
>                 unus = [1 .. n*n]
>                 ff  = findFewestMoves n mn grd unus
>                 ini = Square grd unus ff (2*n*n)
>                 allSquares = bestFirst (successorNodes n mn) [ini]
>             in  putStrLn $ showGrid n . grid $ head allSquares
> 
> data Square = Square { grid :: UArray (Int,Int) Int
>                      , unused :: [Int]
>                      , ffm :: ([Int], Int, Int, Int)
>                      , priority :: !Int
>                      } deriving Eq
> 
> instance Ord Square where
>     compare (Square g1 _ _ p1) (Square g2 _ _ p2)
>         = case compare p1 p2 of
>             EQ -> compare g1 g2
>             ot -> ot
> 
> showMat :: [[Int]] -> ShowS
> showMat lns = foldr1 ((.) . (. showChar '\n')) $ showLns
>               where
>                 showLns = map (foldr1 ((.) . (. showChar ' ')) . map shows) 
> lns
> 
> showGrid :: Int -> UArray (Int,Int) Int -> String
> showGrid n g = showMat [[g ! (r,c) | c <- [1 .. n]] | r <- [1 .. n]] ""
> 
> bestFirst :: (Square -> [Square]) -> [Square] -> [Square]
> bestFirst _ [] = []
> bestFirst successors (front:queue)
>     | priority front == 0 = front : bestFirst successors queue
>     | otherwise = bestFirst successors $ foldr insert queue (successors front)
> 
> successorNodes n mn sq
>     = map (place sq n mn (r,c)) possibilities
>       where
>         (possibilities,_,r,c) = ffm sq
> 
> place :: Square -> Int -> Int -> (Int,Int) -> Int -> Square
> place (Square grd unus _ _) n mn (r,c) k
>     = Square grd' uns moveChoices p
>       where
>         grd' = grd//[((r,c),k)]
>         moveChoices@(_,len,_,_) = findFewestMoves n mn grd' uns
>         uns = delete k unus
>         p = length uns + len
> 
> findFewestMoves n mn grid unus
>     | null unus = ([],0,0,0)
>     | otherwise = (movelist, length movelist, mr, mc)
>       where
>         openSquares = [(r,c) | r <- [1 .. n], c <- [1 .. n], grid ! (r,c) == 
> 0]
>         pm = possibleMoves n mn grid unus
>         openMap = map (\(x,y) -> (pm x y,x,y)) openSquares
>         mycompare (a,_,_) (b,_,_) = compare (length a) (length b)
>         (movelist,mr,mc) = minimumBy mycompare openMap
> 
> possibleMoves n mn grid unus r c
>     | grid ! (r,c) /= 0 = []
>     | otherwise = intersect [mi .. ma] unus -- this is the difference that
>       -- does it: better bounds
>       where
>         cellGroups
>             | r == c && r + c == n + 1 = [d1, d2, theRow, theCol]
>             | r == c = [d1, theRow, theCol]
>             | r + c == n + 1 = [d2, theRow, theCol]
>             | otherwise = [theRow, theCol]
>         d1 = diag1 grid n
>         d2 = diag2 grid n
>         theRow = gridRow grid n r
>         theCol = gridCol grid n c
>         lows = scanl (+) 0 unus
>         higs = scanl (+) 0 $ reverse unus
>         rge cg = let k = count0s cg - 1
>                      lft = mn - sum cg
>                  in (lft - (higs!!k),lft - (lows!!k))
>         (mi,ma) = foldr1 mima $ map rge cellGroups
>         mima (a,b) (c,d) = (max a c, min b d)
> 
> gridRow grid n r = [grid ! (r,i) | i <- [1 .. n]]
> gridCol grid n c = [grid ! (i,c) | i <- [1 .. n]]
> diag1 grid n     = [grid ! (i,i) | i <- [1 .. n]]
> diag2 grid n     = [grid ! (i,n+1-i) | i <- [1 .. n]]
> count0s = length . filter (== 0)
> 
> 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