module G500.Generate
( generate
) where
import Control.Concurrent
import Control.Monad
import Control.Monad.State
import Data.Array.IO
import Data.Bits
import System.Random.Mersenne.Pure64
import G500.Index
type GenM a = StateT PureMT IO a
a, b, c, ab, c_norm, a_norm:: Float
(a, b, c) = (0.57, 0.19, 0.19 :: Float)
ab = a + b
c_norm = c / (1ab)
a_norm = a / ab
genRandomIndexMask :: Index -> GenM Index
genRandomIndexMask indexMask = do
g <- get
let (!r,!g') = randomIndex indexMask g
put g'
return r
genRandomIndex :: Index -> GenM Index
genRandomIndex maxIndex = do
v <- genRandomIndexMask (mask 1)
if v < maxIndex then return v else genRandomIndex maxIndex
where
mask n
| n > maxIndex = n1
| otherwise = mask (2*n)
getRandomFloat :: GenM Float
getRandomFloat = do
g <- get
let (!i,!g') = randomInt64 g
put g'
return $ fromIntegral (i .&. max') / fromIntegral (max' + 1)
where
max' = 0x3fffffff
ii_jj_bits :: GenM (Index, Index)
ii_jj_bits = do
iiR <- getRandomFloat
jjR <- getRandomFloat
let iiBit = iiR > ab
let jjThresh = if iiBit then c_norm else a_norm
let jjBit = jjR > jjThresh
return (fromBool iiBit, fromBool jjBit)
where
fromBool = fromIntegral . fromEnum
type GraphArr = IOUArray Index Index
generate :: Int
-> Int
-> IO (GraphArr, GraphArr)
generate scale edgeFactor = do
start <- newIndexArr
end <- newIndexArr
std <- newPureMT
runGenM std $ go start end
return (start,end)
where
runGenM g genM = runStateT genM g >> return ()
newIndexArr = liftIO $ newArray (0,maxEdgeIndex) 0
n = shiftL 1 scale
m = n*fromIntegral edgeFactor
maxEdgeIndex = m1
maxIndex = n1
incrIndex arr i incr = do
v <- readArray arr i
writeArray arr i (v+incr)
go start end = do
gen (shiftL 1 (scale 1)) start end
p <- permutation maxIndex
permute maxEdgeIndex p start
permute maxEdgeIndex p end
p1 <- permutation maxEdgeIndex
permuteIndices maxEdgeIndex p1 end
return ()
permutation :: Index -> GenM GraphArr
permutation maxIndex' = do
p <- liftIO $ newArray (0,maxIndex') 0
liftIO $ forM_ [0..maxIndex'] $ \i -> writeArray p i i
forM_ (concat $ replicate 1 [0..maxIndex']) $ \i -> do
j <- genRandomIndex maxIndex'
liftIO $ do
a1 <- readArray p i
b1 <- readArray p j
writeArray p i b1
writeArray p j a1
return p
permute :: Index -> GraphArr -> GraphArr -> GenM ()
permute n1 p arr = liftIO $ forM_ [0..n1] $ \i -> do
a1 <- readArray arr i
pa <- readArray p a1
writeArray arr i pa
permuteIndices :: Index -> GraphArr -> GraphArr -> GenM ()
permuteIndices n1 p arr = liftIO $ forM_ [0..n1] $ \i -> do
j <- readArray p i
a1 <- readArray arr i
b1 <- readArray arr j
writeArray arr i b1
writeArray arr j a1
gen pow2 start end
| pow2 < 1 = return ()
| otherwise = do
parallelGeneration pow2 start end
gen (shiftR pow2 1) start end
parallelPortion :: Index
parallelPortion = fromIntegral edgeFactor*1024
parallelGeneration pow2 start end = do
let number = fromIntegral $ div (maxEdgeIndex+1) parallelPortion
runningCount <- liftIO $ newMVar (number :: Int)
forM_ [0..fromIntegral number 1] $ \nt -> do
threadG <- lift newPureMT
let startI = parallelPortion * nt
let endI = parallelPortion * (nt+1) 1
liftIO $ forkIO $ runGenM threadG $ do
forM_ [startI..endI] $
genBit pow2 start end
liftIO $ modifyMVar_ runningCount $ return . (+(1))
let wait = do
n1 <- takeMVar runningCount
if n1 > 0 then do
putMVar runningCount n1
yield
wait
else return ()
liftIO wait
genBit pow2 start end i = do
(startBit, endBit) <- ii_jj_bits
liftIO $ do
incrIndex start i (startBit * pow2)
incrIndex end i (endBit * pow2)