Sync

Task/Atomic-updates/Haskell/atomic-updates-1.hs

@@ -0,0 +1,69 @@
+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

Task/Atomic-updates/Haskell/atomic-updates-2.hs

@@ -0,0 +1,33 @@
+global mtx
+
+procedure main(A)
+    nBuckets := integer(A[1]) | 10
+    nShows := integer(A[2]) | 4
+    showBuckets := A[3]
+    mtx := mutex()
+    every !(buckets := list(nBuckets)) := ?100
+
+    thread repeat {
+        every (b1|b2) := ?nBuckets   # OK if same!
+        critical mtx: xfer((buckets[b1] - buckets[b2])/2, b1, b2)
+        }
+    thread repeat {
+        every (b1|b2) := ?nBuckets   # OK if same!
+        critical mtx: xfer(integer(?buckets[b1]), b1, b2)
+        }
+    wait(thread repeat {
+        delay(500)
+        critical mtx: {
+            every (sum := 0) +:= !buckets
+            writes("Sum: ",sum)
+            if \showBuckets then every writes(" -> "|right(!buckets, 4))
+            }
+        write()
+        if (nShows -:= 1) <= 0 then break
+        })
+end
+
+procedure xfer(x,b1,b2)
+    buckets[b1] -:= x
+    buckets[b2] +:= x
+end