import Data.Vector.Unboxed ( Vector )
import qualified Data.Vector.Unboxed as V
import Control.Parallel
import qualified GHC.Conc
import System.Environment ( getArgs )
import Prelude hiding ( foldr, foldl, sum, maximum )
import Data.Foldable
import Data.List ( inits )
import qualified Data.Time
import qualified System.IO
import Test.SmallCheck
-- | compile: ghc --make -O2 -threaded -rtsopts mps-vector.hs
-- | use : ./mps-vector 100000000 +RTS -N2
main = do
[ nn ] <- getArgs ; let n = read nn :: Int
print ( "numCap", GHC.Conc.numCapabilities )
let xs = paper n
timed "sum xs" $ print $ foldb_cap GHC.Conc.numCapabilities 0 id (+) xs
timed "mpss_as_foldl" $ print $ mpss_as_foldl xs
timed "mpss_as_foldr" $ print $ mpss_as_foldr xs
timed "mpss_as_foldb" $ print $ mpss_as_foldb xs
timed "mpss_as_foldb_cap" $ print $ mpss_as_foldb_cap xs
mps xs = maximum $ fmap sum $ inits xs
mpss xs = ( mps xs, sum xs )
mpss_as_foldl, mpss_as_foldr,
mpss_as_foldb, mpss_as_foldb_cap :: Vector Int -> (Int,Int)
mpss_as_foldl = V.foldl'
( \ (p,s) x ->
let s' = s + x
p' = max p s'
in seq p' $ seq s' $ (p',s') )
(0,0)
mpss_as_foldr = V.foldr'
( \ x (p,s) ->
let p' = max 0 (p+x)
s' = x+s
in seq p' $ seq s' $ (p',s') )
(0,0)
mpss' (p,s) = [ p, s - p ]
weak_inv = \ xs -> mpss ( mpss' ( mpss xs )) == mpss xs
mpss_as_foldb = foldb (0,0) eff h1
mpss_as_foldb_cap =
let nc = GHC.Conc.numCapabilities
in foldb_cap nc (0,0) eff h1
eff x = let m = max 0 x in seq m (m, x)
h0 x y =
mpss (mpss' x ++ mpss' y)
h1 (p1,s1) (p2,s2) =
let p = max p1 ( s1 + p2 )
s = s1 + s2
in seq p $ seq s $ (p,s)
-- | fold balanced, make a spark for every branch node
foldb :: V.Unbox a
=> b
-> ( a -> b )
-> ( b -> b -> b )
-> Vector a
-> b
foldb e f g s = case V.length s of
0 -> e
1 -> f $! V.head s
n -> let splitAt k v =
( V.take k v, V.drop k v )
( s1, s2 ) = splitAt ( div n 2 ) s
v1 = foldb e f g s1
v2 = foldb e f g s2
in par v1 $ pseq v2 $ g v1 v2
-- | fold balanced,
-- | make sparks only for top level nodes,
-- | use linear fold at leaves of tree.
-- | for implementation,
-- | cf. http://thread.gmane.org/gmane.comp.lang.haskell.cafe/90204/focus=90210
foldb_cap :: ( V.Unbox a, V.Unbox b )
=> Int
-> b
-> ( a -> b )
-> ( b -> b -> b )
-> Vector a
-> b
foldb_cap cp strt f g xs = work cp strt xs
where
work cap e s =
if cap <= 1
then V.foldl' g e $ V.map f s
else case V.length s of
0 -> e
1 -> f $! V.head s
n -> let splitAt k v =
( V.take k v, V.drop k v )
( s1, s2 ) = splitAt ( div n 2 ) s
cap' = div cap 2
v1 = work cap' e s1
v2 = work cap' e s2
v = g v1 v2
in par v1 $ pseq v2 $ v
-- | the paper folding sequence, to length 2^k
-- http://oeis.org/A014577
paper_exp :: Int -> Vector Int
paper_exp k =
if k > 0
then let s = paper_exp (k-1)
in s V.++ ( V.cons 1 ( V.map negate $ V.reverse s ) )
else V.empty
-- | the paper folding sequence, to length n
paper n = V.take n $ paper_exp $ log2 $ n + 1
-- | integer approximation for log2
log2 :: Int -> Int
log2 n = if n <= 1 then 0 else 1 + log2 ( n - div n 2 )
timed :: String -> IO a -> IO a
timed msg action = do
start <- Data.Time.getCurrentTime
x <- action
end <- Data.Time.getCurrentTime
let duration = Data.Time.diffUTCTime end start
System.IO.hPutStrLn System.IO.stderr
$ unwords [ msg, show duration ]
return x