Data commit

Task/Dining-philosophers/Haskell/dining-philosophers-1.hs

@@ -0,0 +1,65 @@
+module Philosophers where
+
+import Control.Monad
+import Control.Concurrent
+import Control.Concurrent.STM
+import System.Random
+
+-- TMVars are transactional references. They can only be used in transactional actions.
+-- They are either empty or contain one value. Taking an empty reference fails and
+-- putting a value in a full reference fails. A transactional action only succeeds
+-- when all the component actions succeed, else it rolls back and retries until it
+-- succeeds.
+-- The Int is just for display purposes.
+type Fork = TMVar Int
+
+newFork :: Int -> IO Fork
+newFork i = newTMVarIO i
+
+-- The basic transactional operations on forks
+takeFork :: Fork -> STM Int
+takeFork fork = takeTMVar fork
+
+releaseFork :: Int -> Fork -> STM ()
+releaseFork i fork = putTMVar fork i
+
+type Name = String
+
+runPhilosopher :: Name -> (Fork, Fork) -> IO ()
+runPhilosopher name (left, right) = forever $ do
+  putStrLn (name ++ " is hungry.")
+
+  -- Run the transactional action atomically.
+  -- The type system ensures this is the only way to run transactional actions.
+  (leftNum, rightNum) <- atomically $ do
+    leftNum <- takeFork left
+    rightNum <- takeFork right
+    return (leftNum, rightNum)
+
+  putStrLn (name ++ " got forks " ++ show leftNum ++ " and " ++ show rightNum ++ " and is now eating.")
+  delay <- randomRIO (1,10)
+  threadDelay (delay * 1000000) -- 1, 10 seconds. threadDelay uses nanoseconds.
+  putStrLn (name ++ " is done eating. Going back to thinking.")
+
+  atomically $ do
+    releaseFork leftNum left
+    releaseFork rightNum right
+
+  delay <- randomRIO (1, 10)
+  threadDelay (delay * 1000000)
+
+philosophers :: [String]
+philosophers = ["Aristotle", "Kant", "Spinoza", "Marx", "Russel"]
+
+main = do
+  forks <- mapM newFork [1..5]
+  let namedPhilosophers  = map runPhilosopher philosophers
+      forkPairs          = zip forks (tail . cycle $ forks)
+      philosophersWithForks = zipWith ($) namedPhilosophers forkPairs
+
+  putStrLn "Running the philosophers. Press enter to quit."
+
+  mapM_ forkIO philosophersWithForks
+
+  -- All threads exit when the main thread exits.
+  getLine

Task/Dining-philosophers/Haskell/dining-philosophers-2.hs

@@ -0,0 +1,29 @@
+global forks, names
+
+procedure main(A)
+    names := ["Aristotle","Kant","Spinoza","Marks","Russell"]
+    write("^C to terminate")
+    nP := *names
+    forks := [: |mutex([])\nP :]
+    every p := !nP do thread philosopher(p)
+    delay(-1)
+end
+
+procedure philosopher(n)
+    f1 := forks[min(n, n%*forks+1)]
+    f2 := forks[max(n, n%*forks+1)]
+    repeat {
+        write(names[n]," thinking")
+        delay(1000*?5)
+        write(names[n]," hungry")
+        repeat {
+            fork1 := lock(f1)
+            if fork2 := trylock(f2) then {
+                write(names[n]," eating")
+                delay(1000*?5)
+                break (unlock(fork2), unlock(fork1))  # full
+                }
+            unlock(fork1)  # Free first fork and go back to waiting
+            }
+        }
+end