Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
105 lines (90 sloc) 2.87 KB
{-# LANGUAGE BangPatterns #-}
{- The Computer Language Benchmarks Game
http://shootout.alioth.debian.org/
contributed by Louis Wasserman
This should be compiled with:
-threaded -O2 -fexcess-precision -fasm
and run with:
+RTS -N<number of cores> -RTS <input>
-}
import Control.Concurrent
import Control.Monad
import System
import Foreign hiding (rotate)
import Data.Monoid
type Perm = Ptr Word8
data F = F {-# UNPACK #-} !Int {-# UNPACK #-} !Int
instance Monoid F where
mempty = F 0 0
F s1 m1 `mappend` F s2 m2 = F (s1 + s2) (max m1 m2)
incPtr = (`advancePtr` 1)
decPtr = (`advancePtr` (-1))
flop :: Int -> Perm -> IO ()
flop k xs = flopp xs (xs `advancePtr` k)
where flopp i j = when (i < j) $ swap i j >> flopp (incPtr i) (decPtr j)
swap i j = do
a <- peek i
b <- peek j
poke j a
poke i b
flopS :: Perm -> (Int -> IO a) -> IO a
flopS !xs f = do
let go !acc = do
k <- peekElemOff xs 0
if k == 0 then f acc else flop (fromIntegral k) xs >> go (acc+1)
go 0
increment :: Ptr Word8 -> Ptr Word8 -> IO ()
increment !p !ct = do
first <- peekElemOff p 1
pokeElemOff p 1 =<< peekElemOff p 0
pokeElemOff p 0 first
let go !i !first = do
ci <- peekElemOff ct i
if fromIntegral ci < i then pokeElemOff ct i (ci+1) else do
pokeElemOff ct i 0
let !i' = i + 1
moveArray p (incPtr p) i'
pokeElemOff p i' first
go i' =<< peekElemOff p 0
go 1 first
genPermutations :: Int -> Int -> Int -> Ptr Word8 -> Ptr Word8 -> IO F
genPermutations !n !l !r !perm !count = allocaArray n $ \ destF -> do
let upd j !f run = do
p0 <- peekElemOff perm 0
if p0 == 0 then increment perm count >> run f else do
copyArray destF perm n
increment perm count
flopS destF $ \ flops ->
run (f `mappend` F (checksum j flops) flops)
let go j !f = if j >= r then return f else upd j f (go (j+1))
go l mempty
where checksum i f = if i .&. 1 == 0 then f else -f
facts :: [Int]
facts = scanl (*) 1 [1..12]
unrank :: Int -> Int -> (Ptr Word8 -> Ptr Word8 -> IO a) -> IO a
unrank !idx !n f = allocaArray n $ \ p -> allocaArray n $ \ count ->
allocaArray n $ \ pp -> do
mapM_ (\ i -> pokeElemOff p i (fromIntegral i)) [0..n-1]
let go i !idx = when (i >= 0) $ do
let fi = facts !! i
let (q, r) = idx `quotRem` fi
pokeElemOff count i (fromIntegral q)
copyArray pp p (i+1)
let go' j = when (j <= i) $ do
let jq = j + q
pokeElemOff p j =<< peekElemOff pp (if jq <= i then jq else jq - i - 1)
go' (j+1)
go' 0
go (i-1) r
go (n-1) idx
f p count
main = do
n <- fmap (read.head) getArgs
let fact = product [1..n]
let bk = fact `quot` 4
vars <- forM [0,bk..fact-1] $ \ ix -> do
var <- newEmptyMVar
forkIO (unrank ix n $ \ p -> genPermutations n ix (min fact (ix + bk)) p >=> putMVar var)
return var
F chksm mflops <- liftM mconcat (mapM takeMVar vars)
putStrLn $ (show chksm) ++ "\nPfannkuchen(" ++ (show n) ++ ") = " ++ (show $ mflops)