70 lines
2.4 KiB
Haskell
70 lines
2.4 KiB
Haskell
module AtomicUpdates (main) where
|
|
|
|
import Control.Concurrent (forkIO, threadDelay)
|
|
import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_)
|
|
import Control.Monad (forever, forM_)
|
|
import Data.IntMap (IntMap, (!), toAscList, fromList, adjust)
|
|
import System.Random (randomRIO)
|
|
import Text.Printf (printf)
|
|
|
|
-------------------------------------------------------------------------------
|
|
|
|
type Index = Int
|
|
type Value = Integer
|
|
data Buckets = Buckets Index (MVar (IntMap Value))
|
|
|
|
makeBuckets :: Int -> IO Buckets
|
|
size :: Buckets -> Index
|
|
currentValue :: Buckets -> Index -> IO Value
|
|
currentValues :: Buckets -> IO (IntMap Value)
|
|
transfer :: Buckets -> Index -> Index -> Value -> IO ()
|
|
|
|
-------------------------------------------------------------------------------
|
|
|
|
makeBuckets n = do v <- newMVar (fromList [(i, 100) | i <- [1..n]])
|
|
return (Buckets n v)
|
|
|
|
size (Buckets n _) = n
|
|
|
|
currentValue (Buckets _ v) i = fmap (! i) (readMVar v)
|
|
currentValues (Buckets _ v) = readMVar v
|
|
|
|
transfer b@(Buckets n v) i j amt | amt < 0 = transfer b j i (-amt)
|
|
| otherwise = do
|
|
modifyMVar_ v $ \map -> let amt' = min amt (map ! i)
|
|
in return $ adjust (subtract amt') i
|
|
$ adjust (+ amt') j
|
|
$ map
|
|
|
|
-------------------------------------------------------------------------------
|
|
|
|
roughen, smooth, display :: Buckets -> IO ()
|
|
|
|
pick buckets = randomRIO (1, size buckets)
|
|
|
|
roughen buckets = forever loop where
|
|
loop = do i <- pick buckets
|
|
j <- pick buckets
|
|
iv <- currentValue buckets i
|
|
transfer buckets i j (iv `div` 3)
|
|
|
|
smooth buckets = forever loop where
|
|
loop = do i <- pick buckets
|
|
j <- pick buckets
|
|
iv <- currentValue buckets i
|
|
jv <- currentValue buckets j
|
|
transfer buckets i j ((iv - jv) `div` 4)
|
|
|
|
display buckets = forever loop where
|
|
loop = do threadDelay 1000000
|
|
bmap <- currentValues buckets
|
|
putStrLn (report $ map snd $ toAscList bmap)
|
|
report list = "\nTotal: " ++ show (sum list) ++ "\n" ++ bars
|
|
where bars = concatMap row $ map (*40) $ reverse [1..5]
|
|
row lim = printf "%3d " lim ++ [if x >= lim then '*' else ' ' | x <- list] ++ "\n"
|
|
|
|
main = do buckets <- makeBuckets 100
|
|
forkIO (roughen buckets)
|
|
forkIO (smooth buckets)
|
|
display buckets
|