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

[Daniel Fischer]

Am Dienstag, 4. Juli 2006 18:20 schrieben Sie:
> -----BEGIN PGP SIGNED MESSAGE-----
> Hash: SHA1
>
> Daniel,
>
> > 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).
>
> Thanks for your efforts on this project.  I'm actually more
> interested in using your earlier solution, since it is so much
> faster.  Right now, the magic square code rises in runtime from 1.5
> seconds to 4 hours with an increase of 1 in the square's dimension.
> I would much rather use a technique that had a more linear (or even
> exponential) increase!
>
> I would propose modifying the other entries (since there are only a
> handful) to match the output of your original solution.
>
> What do you think?

Cool, though the problem of exploding runtime remains, it's only pushed a 
little further. Now I get a 5x5 magig square in 1 s, a 6x6 in 5.4 s, but 7x7 
segfaulted after about 2 1/2 hours - out of memory, I believe.
And, as mentioned in passing, using 'intersect' in the first version is 
slowing things down, so here is my currently fastest (undoubtedly, the 
experts could still make it faster by clever unboxing):


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 :: Int -> Int -> UArray (Int,Int) Int -> [Int] -> 
([Int],Int,Int,Int)
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 :: Int -> Int -> UArray (Int,Int) Int -> [Int] -> Int -> Int -> 
[Int]
possibleMoves n mn grid unus r c
    | grid ! (r,c) /= 0 = []
    | otherwise = takeWhile (<= ma) $ dropWhile (< mi) unus
      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 :: [Int] -> (Int,Int)
        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, gridCol :: UArray (Int,Int) Int -> Int -> Int -> [Int]
diag1, diag2 :: UArray (Int,Int) Int -> Int -> [Int]
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 :: [Int] -> Int
count0s = length . filter (== 0)

>
> - -Brent
> -----BEGIN PGP SIGNATURE-----
> Version: GnuPG v1.4.2.2 (Darwin)
>
> iD8DBQFEqpVmzGDdrzfvUpURAkPpAJ9oKTwzmUyTAoA6yQdOo7APKnXCqACghJEV
> id5EqEyVKrvSlJlLH9JZTN0=
> =jNXB
> -----END PGP SIGNATURE-----

Cheers,
Daniel

-- 

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