parconc-examples (empty) → 0.1
raw patch · 101 files changed
+7415/−0 lines, 101 filesdep +HTTPdep +abstract-pardep +acceleratesetup-changed
Dependencies added: HTTP, abstract-par, accelerate, accelerate-cuda, accelerate-io, array, async, base, binary, bytestring, containers, deepseq, directory, distributed-process, distributed-process-simplelocalnet, distributed-static, fclabels, filepath, ghc-prim, monad-par, network, normaldistribution, parallel, random, repa, repa-devil, stm, template-haskell, time, transformers, utf8-string, vector, xml
Files
- Async.hs +118/−0
- ByteStringCompat.hs +13/−0
- CasIORef.hs +15/−0
- ConcurrentUtils.hs +27/−0
- DistribUtils.hs +41/−0
- GetURL.hs +25/−0
- LICENSE +33/−0
- Setup.hs +2/−0
- Stream.hs +97/−0
- Sudoku.hs +150/−0
- TBQueue.hs +40/−0
- TChan.hs +72/−0
- TList.hs +26/−0
- TQueue.hs +32/−0
- TimeIt.hs +14/−0
- catch-mask.hs +24/−0
- catch-mask2.hs +24/−0
- chan.hs +52/−0
- chan2.hs +66/−0
- chan3.hs +54/−0
- chat.hs +251/−0
- deadlock1.hs +10/−0
- deadlock2.hs +10/−0
- distrib-chat/chat-noslave.hs +419/−0
- distrib-chat/chat.hs +355/−0
- distrib-db/Database.hs +31/−0
- distrib-db/db.hs +32/−0
- distrib-ping/ping-fail.hs +60/−0
- distrib-ping/ping-multi.hs +66/−0
- distrib-ping/ping-tc-merge.hs +64/−0
- distrib-ping/ping-tc-notify.hs +71/−0
- distrib-ping/ping-tc.hs +61/−0
- distrib-ping/ping.hs +55/−0
- findpar.hs +43/−0
- findpar2.hs +82/−0
- findpar3.hs +81/−0
- findpar4.hs +55/−0
- findseq.hs +34/−0
- fork.hs +10/−0
- fwaccel.hs +96/−0
- fwdense.hs +83/−0
- fwdense1.hs +74/−0
- fwsparse/MapCompat.hs +19/−0
- fwsparse/SparseGraph.hs +82/−0
- fwsparse/fwsparse.hs +63/−0
- fwsparse/fwsparse1.hs +70/−0
- geturls1.hs +21/−0
- geturls2.hs +31/−0
- geturls3.hs +50/−0
- geturls4.hs +39/−0
- geturls5.hs +28/−0
- geturls6.hs +70/−0
- geturls7.hs +85/−0
- geturls8.hs +15/−0
- geturls9.hs +23/−0
- geturlscancel.hs +74/−0
- geturlscancel2.hs +88/−0
- geturlsfirst.hs +96/−0
- geturlsstm.hs +50/−0
- kmeans/GenSamples.hs +75/−0
- kmeans/KMeansCore.hs +67/−0
- kmeans/kmeans.hs +310/−0
- logger.hs +56/−0
- mandel/Config.hs +90/−0
- mandel/mandel.hs +171/−0
- modifytwo.hs +15/−0
- mvar1.hs +10/−0
- mvar2.hs +11/−0
- mvar3.hs +7/−0
- mvar4.hs +17/−0
- other/BingTranslate.hs +73/−0
- other/bingtranslator.hs +42/−0
- other/bingtranslatorconc.hs +87/−0
- parconc-examples.cabal +883/−0
- parmonad.hs +27/−0
- phonebook.hs +42/−0
- reminders.hs +17/−0
- reminders2.hs +21/−0
- rotateimage.hs +45/−0
- rsa-pipeline.hs +103/−0
- rsa.hs +94/−0
- rsa1.hs +96/−0
- rsa2.hs +96/−0
- server.hs +35/−0
- server2.hs +74/−0
- strat.hs +26/−0
- strat2.hs +31/−0
- strat3.hs +32/−0
- sudoku1.hs +16/−0
- sudoku2.hs +27/−0
- sudoku3.hs +26/−0
- sudoku4.hs +25/−0
- threadperf1.hs +11/−0
- threadperf2.hs +13/−0
- timeout.hs +35/−0
- timetable.hs +137/−0
- timetable1.hs +146/−0
- timetable2.hs +164/−0
- timetable3.hs +167/−0
- tmvar.hs +49/−0
- windowman.hs +74/−0
+ Async.hs view
@@ -0,0 +1,118 @@+module Async (+ Async,+ async,+ withAsync,+ cancel,+ waitCatch,+ waitCatchSTM,+ waitSTM,+ wait,+ waitEither,+ waitAny,+ waitBoth,+ concurrently+ ) where++import Control.Concurrent.STM+import Control.Exception+import Control.Concurrent (ThreadId, forkIO)++-- <<Async+data Async a = Async ThreadId (STM (Either SomeException a))+-- >>++forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId+forkFinally action fun =+ mask $ \restore ->+ forkIO (do r <- try (restore action); fun r)++-- <<async+async :: IO a -> IO (Async a)+async action = do+ var <- newEmptyTMVarIO+ t <- forkFinally action (atomically . putTMVar var)+ return (Async t (readTMVar var))+-- >>++-- <<Functor+instance Functor Async where+ fmap f (Async t stm) = Async t stm'+ where stm' = do+ r <- stm+ case r of+ Left e -> return (Left e)+ Right a -> return (Right (f a))+-- >>++--- <<watchCatch+waitCatch :: Async a -> IO (Either SomeException a)+waitCatch = atomically . waitCatchSTM+-- >>++-- <<waitCatchSTM+waitCatchSTM :: Async a -> STM (Either SomeException a)+waitCatchSTM (Async _ stm) = stm+-- >>++-- <<waitSTM+waitSTM :: Async a -> STM a+waitSTM a = do+ r <- waitCatchSTM a+ case r of+ Left e -> throwSTM e+ Right a -> return a+-- >>++-- <<wait+wait :: Async a -> IO a+wait = atomically . waitSTM+-- >>++-- <<cancel+cancel :: Async a -> IO ()+cancel (Async t _) = throwTo t ThreadKilled+-- >>++-- <<waitEither+waitEither :: Async a -> Async b -> IO (Either a b)+waitEither a b = atomically $+ fmap Left (waitSTM a)+ `orElse`+ fmap Right (waitSTM b)+-- >>++-- <<waitAny+waitAny :: [Async a] -> IO a+waitAny asyncs =+ atomically $ foldr orElse retry $ map waitSTM asyncs+-- >>++-- <<withAsync+withAsync :: IO a -> (Async a -> IO b) -> IO b+withAsync io operation = bracket (async io) cancel operation+-- >>++-- <<waitBoth+waitBoth :: Async a -> Async b -> IO (a,b)+waitBoth a1 a2 =+ atomically $ do+ r1 <- waitSTM a1 `orElse` (do waitSTM a2; retry) -- <1>+ r2 <- waitSTM a2+ return (r1,r2)+-- >>++-- <<concurrently+concurrently :: IO a -> IO b -> IO (a,b)+concurrently ioa iob =+ withAsync ioa $ \a ->+ withAsync iob $ \b ->+ waitBoth a b+-- >>++-- <<race+race :: IO a -> IO b -> IO (Either a b)+race ioa iob =+ withAsync ioa $ \a ->+ withAsync iob $ \b ->+ waitEither a b+-- >>
+ ByteStringCompat.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE CPP #-}+module ByteStringCompat () where++import qualified Data.ByteString.Lazy.Char8 as B+import Data.ByteString.Lazy.Char8 (ByteString)+import Control.DeepSeq++#if !MIN_VERSION_bytestring(0,10,0)++instance NFData ByteString where+ rnf x = B.length x `seq` ()++#endif
+ CasIORef.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE MagicHash, UnboxedTuples #-}+module CasIORef (casIORef) where++import GHC.IORef+import GHC.STRef+import GHC.Exts+import GHC.IO++casIORef :: IORef a -> a -> a -> IO Bool+casIORef (IORef (STRef r#)) old new = IO $ \s ->+ case casMutVar# r# old new s of+ (# s', did, val #) ->+ if did ==# 0# then (# s', True #)+ else (# s', False #)+
+ ConcurrentUtils.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}++module ConcurrentUtils (+ -- * Variants of forkIO+ forkFinally+ ) where++import Control.Concurrent.STM+import Control.Exception+import Control.Concurrent+import Prelude hiding (catch)+import Control.Monad+import Control.Applicative++import GHC.Exts+import GHC.IO hiding (finally)+import GHC.Conc++#if __GLASGOW_HASKELL__ < 706+-- | fork a thread and call the supplied function when the thread is about+-- to terminate, with an exception or a returned value. The function is+-- called with asynchronous exceptions masked.+forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId+forkFinally action and_then =+ mask $ \restore ->+ forkIO $ try (restore action) >>= and_then+#endif
+ DistribUtils.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE TemplateHaskell #-}+module DistribUtils ( distribMain ) where++import Control.Distributed.Process+import Control.Distributed.Process.Closure+import Control.Distributed.Process.Node (initRemoteTable)+import Control.Distributed.Process.Backend.SimpleLocalnet+import Control.Distributed.Static hiding (initRemoteTable)++import System.Environment+import Network.Socket hiding (shutdown)++import Language.Haskell.TH++distribMain :: ([NodeId] -> Process ()) -> (RemoteTable -> RemoteTable) -> IO ()+distribMain master frtable = do+ args <- getArgs+ let rtable = frtable initRemoteTable++ case args of+ [] -> do+ backend <- initializeBackend defaultHost defaultPort rtable+ startMaster backend master+ [ "master" ] -> do+ backend <- initializeBackend defaultHost defaultPort rtable+ startMaster backend master+ [ "master", port ] -> do+ backend <- initializeBackend defaultHost port rtable+ startMaster backend master+ [ "slave" ] -> do+ backend <- initializeBackend defaultHost defaultPort rtable+ startSlave backend+ [ "slave", port ] -> do+ backend <- initializeBackend defaultHost port rtable+ startSlave backend+ [ "slave", host, port ] -> do+ backend <- initializeBackend host port rtable+ startSlave backend++defaultHost = "localhost"+defaultPort = "44444"
+ GetURL.hs view
@@ -0,0 +1,25 @@+-- (c) Simon Marlow 2011, see the file LICENSE for copying terms.++-- Simple wrapper around HTTP, allowing proxy use++module GetURL (getURL) where++import Network.HTTP+import Network.Browser+import Network.URI+import Data.ByteString (ByteString)++getURL :: String -> IO ByteString+getURL url = do+ Network.Browser.browse $ do+ setCheckForProxy True+ setDebugLog Nothing+ setOutHandler (const (return ()))+ (_, rsp) <- request (getRequest' (escapeURIString isUnescapedInURI url))+ return (rspBody rsp)+ where+ getRequest' :: String -> Request ByteString+ getRequest' urlString =+ case parseURI urlString of+ Nothing -> error ("getRequest: Not a valid URL - " ++ urlString)+ Just u -> mkRequest GET u
+ LICENSE view
@@ -0,0 +1,33 @@+Unless stated otherwise in individual source files, the code in this+package is made available under the following license:++Copyright (c) 2012, Simon Marlow++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Simon Marlow nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Stream.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE BangPatterns, CPP #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing -fwarn-unused-imports #-}+-- -Wall ++-- A module for stream processing built on top of Control.Monad.Par++-- (In the future may want to look into the stream interface used by+-- the stream fusion framework.)++module Stream+ ( + Stream, streamFromList, streamMap, streamFold, streamFilter+ ) where++import Control.Monad.Par.Scheds.Trace as P+import Control.DeepSeq++--------------------------------------------------------------------------------+-- Types++-- <<IList+data IList a+ = Nil+ | Cons a (IVar (IList a))++type Stream a = IVar (IList a)+-- >>++instance NFData a => NFData (IList a) where+-- rnf Nil = r0+ rnf Nil = ()+ rnf (Cons a b) = rnf a `seq` rnf b++-- -----------------------------------------------------------------------------+-- Stream operators++-- <<streamFromList+streamFromList :: NFData a => [a] -> Par (Stream a)+streamFromList xs = do+ var <- new -- <1>+ fork $ loop xs var -- <2>+ return var -- <3>+ where+ loop [] var = put var Nil -- <4>+ loop (x:xs) var = do -- <5>+ tail <- new -- <6>+ put var (Cons x tail) -- <7>+ loop xs tail -- <8>+-- >>++-- <<streamMap+streamMap :: NFData b => (a -> b) -> Stream a -> Par (Stream b)+streamMap fn instrm = do+ outstrm <- new+ fork $ loop instrm outstrm+ return outstrm+ where+ loop instrm outstrm = do+ ilst <- get instrm+ case ilst of+ Nil -> put outstrm Nil+ Cons h t -> do+ newtl <- new+ put outstrm (Cons (fn h) newtl)+ loop t newtl+-- >>+++-- | Reduce a stream to a single value. This function will not return+-- until it reaches the end-of-stream.+-- <<streamFold+streamFold :: (a -> b -> a) -> a -> Stream b -> Par a+streamFold fn !acc instrm = do+ ilst <- get instrm+ case ilst of+ Nil -> return acc+ Cons h t -> streamFold fn (fn acc h) t+-- >>++streamFilter :: NFData a => (a -> Bool) -> Stream a -> Par (Stream a)+streamFilter p instr = do+ outstr <- new+ fork $ loop instr outstr+ return outstr+ where+ loop instr outstr = do+ v <- get instr+ case v of+ Nil -> put outstr Nil+ Cons x instr'+ | p x -> do+ tail <- new+ put_ outstr (Cons x tail)+ loop instr' tail+ | otherwise -> do+ loop instr' outstr+
+ Sudoku.hs view
@@ -0,0 +1,150 @@+--+-- Sudoku solver using constraint propagation. The algorithm is by+-- Peter Norvig http://norvig.com/sudoku.html; the Haskell+-- implementation is by Manu and Daniel Fischer, and can be found on+-- the Haskell Wiki http://www.haskell.org/haskellwiki/Sudoku+--+-- The Haskell wiki license applies to this code:+--+-- Permission is hereby granted, free of charge, to any person obtaining+-- this work (the "Work"), to deal in the Work without restriction,+-- including without limitation the rights to use, copy, modify, merge,+-- publish, distribute, sublicense, and/or sell copies of the Work, and+-- to permit persons to whom the Work is furnished to do so.+-- +-- THE WORK IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+-- LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+-- OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+-- WITH THE WORK OR THE USE OR OTHER DEALINGS IN THE WORK.++module Sudoku (solve, printGrid) where++import Data.List hiding (lookup)+import Data.Array+import Control.Monad+import Data.Maybe++-- Types+type Digit = Char+type Square = (Char,Char)+type Unit = [Square]+ +-- We represent our grid as an array+type Grid = Array Square [Digit]+ + +-- Setting Up the Problem+rows = "ABCDEFGHI"+cols = "123456789"+digits = "123456789"+box = (('A','1'),('I','9'))+ +cross :: String -> String -> [Square]+cross rows cols = [ (r,c) | r <- rows, c <- cols ]+ +squares :: [Square]+squares = cross rows cols -- [('A','1'),('A','2'),('A','3'),...]+ +peers :: Array Square [Square]+peers = array box [(s, set (units!s)) | s <- squares ]+ where+ set = nub . concat+ +unitlist :: [Unit]+unitlist = [ cross rows [c] | c <- cols ] +++ [ cross [r] cols | r <- rows ] +++ [ cross rs cs | rs <- ["ABC","DEF","GHI"], + cs <- ["123","456","789"]]+ +-- this could still be done more efficiently, but what the heck...+units :: Array Square [Unit]+units = array box [(s, [filter (/= s) u | u <- unitlist, s `elem` u ]) | + s <- squares]+ + +allPossibilities :: Grid+allPossibilities = array box [ (s,digits) | s <- squares ]+ +-- Parsing a grid into an Array+parsegrid :: String -> Maybe Grid+parsegrid g = do regularGrid g+ foldM assign allPossibilities (zip squares g)+ + where regularGrid :: String -> Maybe String+ regularGrid g = if all (`elem` "0.-123456789") g+ then Just g+ else Nothing+ +-- Propagating Constraints+assign :: Grid -> (Square, Digit) -> Maybe Grid+assign g (s,d) = if d `elem` digits+ -- check that we are assigning a digit and not a '.'+ then do+ let ds = g ! s+ toDump = delete d ds+ foldM eliminate g (zip (repeat s) toDump)+ else return g+ +eliminate :: Grid -> (Square, Digit) -> Maybe Grid+eliminate g (s,d) = + let cell = g ! s in+ if d `notElem` cell then return g -- already eliminated+ -- else d is deleted from s' values+ else do let newCell = delete d cell+ newV = g // [(s,newCell)]+ newV2 <- case newCell of+ -- contradiction : Nothing terminates the computation+ [] -> Nothing+ -- if there is only one value left in s, remove it from peers+ [d'] -> do let peersOfS = peers ! s+ foldM eliminate newV (zip peersOfS (repeat d'))+ -- else : return the new grid+ _ -> return newV+ -- Now check the places where d appears in the peers of s+ foldM (locate d) newV2 (units ! s)+ +locate :: Digit -> Grid -> Unit -> Maybe Grid+locate d g u = case filter ((d `elem`) . (g !)) u of+ [] -> Nothing+ [s] -> assign g (s,d)+ _ -> return g+ +-- Search+search :: Grid -> Maybe Grid+search g = + case [(l,(s,xs)) | (s,xs) <- assocs g, let l = length xs, l /= 1] of+ [] -> return g+ ls -> do let (_,(s,ds)) = minimum ls+ msum [assign g (s,d) >>= search | d <- ds]+ +solve :: String -> Maybe Grid+solve str = do+ grd <- parsegrid str+ search grd+ +-- Display solved grid+printGrid :: Grid -> IO ()+printGrid = putStrLn . gridToString+ +gridToString :: Grid -> String+gridToString g =+ let l0 = elems g+ -- [("1537"),("4"),...] + l1 = (map (\s -> " " ++ s ++ " ")) l0+ -- ["1 "," 2 ",...] + l2 = (map concat . sublist 3) l1+ -- ["1 2 3 "," 4 5 6 ", ...]+ l3 = (sublist 3) l2+ -- [["1 2 3 "," 4 5 6 "," 7 8 9 "],...] + l4 = (map (concat . intersperse "|")) l3+ -- ["1 2 3 | 4 5 6 | 7 8 9 ",...]+ l5 = (concat . intersperse [line] . sublist 3) l4+ in unlines l5 + where sublist n [] = []+ sublist n xs = ys : sublist n zs+ where (ys,zs) = splitAt n xs+ line = hyphens ++ "+" ++ hyphens ++ "+" ++ hyphens+ hyphens = replicate 9 '-'
+ TBQueue.hs view
@@ -0,0 +1,40 @@+module TBQueue (TBQueue, newTBQueue, writeTBQueue, readTBQueue) where++import Control.Concurrent.STM+ (STM, TVar, newTVar, readTVar, writeTVar, retry)++-- <<TBQueue+data TBQueue a = TBQueue (TVar Int) (TVar [a]) (TVar [a]) -- <1>++newTBQueue :: Int -> STM (TBQueue a)+newTBQueue size = do+ read <- newTVar []+ write <- newTVar []+ cap <- newTVar size+ return (TBQueue cap read write)++writeTBQueue :: TBQueue a -> a -> STM ()+writeTBQueue (TBQueue cap _read write) a = do+ avail <- readTVar cap -- <2>+ if avail == 0 -- <3>+ then retry -- <4>+ else writeTVar cap (avail - 1) -- <5>+ listend <- readTVar write+ writeTVar write (a:listend)++readTBQueue :: TBQueue a -> STM a+readTBQueue (TBQueue cap read write) = do+ avail <- readTVar cap -- <6>+ writeTVar cap (avail + 1)+ xs <- readTVar read+ case xs of+ (x:xs') -> do writeTVar read xs'+ return x+ [] -> do ys <- readTVar write+ case ys of+ [] -> retry+ _ -> do let (z:zs) = reverse ys+ writeTVar write []+ writeTVar read zs+ return z+-- >>
+ TChan.hs view
@@ -0,0 +1,72 @@+import Control.Concurrent.STM (STM, TVar, newTVar, readTVar, writeTVar, retry, atomically)++-- <<TChan+data TChan a = TChan (TVar (TVarList a))+ (TVar (TVarList a))++type TVarList a = TVar (TList a)+data TList a = TNil | TCons a (TVarList a)++newTChan :: STM (TChan a)+newTChan = do+ hole <- newTVar TNil+ read <- newTVar hole+ write <- newTVar hole+ return (TChan read write)++readTChan :: TChan a -> STM a+readTChan (TChan readVar _) = do+ listHead <- readTVar readVar+ head <- readTVar listHead+ case head of+ TNil -> retry+ TCons val tail -> do+ writeTVar readVar tail+ return val++writeTChan :: TChan a -> a -> STM ()+writeTChan (TChan _ writeVar) a = do+ newListEnd <- newTVar TNil+ listEnd <- readTVar writeVar+ writeTVar writeVar newListEnd+ writeTVar listEnd (TCons a newListEnd)+-- >>++-- <<dupTChan+dupTChan :: TChan a -> STM (TChan a)+dupTChan (TChan _ writeVar) = do+ hole <- readTVar writeVar+ newReadVar <- newTVar hole+ return (TChan newReadVar writeVar)+-- >>++-- <<unGetTChan+unGetTChan :: TChan a -> a -> STM ()+unGetTChan (TChan readVar _) a = do+ listHead <- readTVar readVar+ newHead <- newTVar (TCons a listHead)+ writeTVar readVar newHead+-- >>++-- <<isEmptyTChan+isEmptyTChan :: TChan a -> STM Bool+isEmptyTChan (TChan read _write) = do+ listhead <- readTVar read+ head <- readTVar listhead+ case head of+ TNil -> return True+ TCons _ _ -> return False+-- >>++main = do+ c <- atomically $ newTChan+ atomically $ writeTChan c 'a'+ atomically (readTChan c) >>= print+ atomically (isEmptyTChan c) >>= print+ atomically $ unGetTChan c 'a'+ atomically (isEmptyTChan c) >>= print+ atomically (readTChan c) >>= print+ c2 <- atomically $ dupTChan c+ atomically $ writeTChan c 'b'+ atomically (readTChan c) >>= print+ atomically (readTChan c2) >>= print
+ TList.hs view
@@ -0,0 +1,26 @@+module TList (TList, newTList, readTList, writeTList) where++import Control.Concurrent.STM++-- <<TList+newtype TList a = TList (TVar [a])++newTList :: STM (TList a)+newTList = do+ v <- newTVar []+ return (TList v)++writeTList :: TList a -> a -> STM ()+writeTList (TList v) a = do+ list <- readTVar v+ writeTVar v (list ++ [a])++readTList :: TList a -> STM a+readTList (TList v) = do+ xs <- readTVar v+ case xs of+ [] -> retry+ (x:xs') -> do+ writeTVar v xs'+ return x+-- >>
+ TQueue.hs view
@@ -0,0 +1,32 @@+module TQueue (TQueue, newTQueue, writeTQueue, readTQueue) where++import Control.Concurrent.STM (STM, TVar, newTVar, readTVar, writeTVar, retry)++-- <<TQueue+data TQueue a = TQueue (TVar [a]) (TVar [a])++newTQueue :: STM (TQueue a)+newTQueue = do+ read <- newTVar []+ write <- newTVar []+ return (TQueue read write)++writeTQueue :: TQueue a -> a -> STM ()+writeTQueue (TQueue _read write) a = do+ listend <- readTVar write+ writeTVar write (a:listend)++readTQueue :: TQueue a -> STM a+readTQueue (TQueue read write) = do+ xs <- readTVar read+ case xs of+ (x:xs') -> do writeTVar read xs'+ return x+ [] -> do ys <- readTVar write+ case ys of+ [] -> retry -- <1>+ _ -> do let (z:zs) = reverse ys -- <2>+ writeTVar write []+ writeTVar read zs+ return z+-- >>
+ TimeIt.hs view
@@ -0,0 +1,14 @@+-- (c) Simon Marlow 2011, see the file LICENSE for copying terms.++-- Returns the number of realtime seconds an action takes++module TimeIt (timeit) where++import Data.Time++timeit :: IO a -> IO (a,Double)+timeit io = do+ t0 <- getCurrentTime+ a <- io+ t1 <- getCurrentTime+ return (a, realToFrac (t1 `diffUTCTime` t0))
+ catch-mask.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE BangPatterns #-}+import System.IO+import System.IO.Error+import System.Environment+import Control.Exception as E++-- <<main+main = do+ fs <- getArgs+ let+ loop !n [] = return n+ loop !n (f:fs)+ = handle (\e -> if isDoesNotExistError e+ then loop n fs+ else throwIO e) $+ do+ getMaskingState >>= print+ h <- openFile f ReadMode+ s <- hGetContents h+ loop (n + length (lines s)) fs++ n <- loop 0 fs+ print n+-- >>
+ catch-mask2.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE BangPatterns #-}+import System.IO+import System.IO.Error+import System.Environment+import Control.Exception++-- <<main+main = do+ fs <- getArgs+ let+ loop !n [] = return n+ loop !n (f:fs) = do+ getMaskingState >>= print+ r <- Control.Exception.try (openFile f ReadMode)+ case r of+ Left e | isDoesNotExistError e -> loop n fs+ | otherwise -> throwIO e+ Right h -> do+ s <- hGetContents h+ loop (n + length (lines s)) fs++ n <- loop 0 fs+ print n+-- >>
+ chan.hs view
@@ -0,0 +1,52 @@+import Control.Concurrent hiding (Chan, newChan, readChan, writeChan)++-- <<Stream+type Stream a = MVar (Item a)+data Item a = Item a (Stream a)+-- >>++-- <<Chan+data Chan a+ = Chan (MVar (Stream a))+ (MVar (Stream a))+-- >>++-- <<newChan+newChan :: IO (Chan a)+newChan = do+ hole <- newEmptyMVar+ readVar <- newMVar hole+ writeVar <- newMVar hole+ return (Chan readVar writeVar)+-- >>++-- <<writeChan+writeChan :: Chan a -> a -> IO ()+writeChan (Chan _ writeVar) val = do+ newHole <- newEmptyMVar+ oldHole <- takeMVar writeVar+ putMVar oldHole (Item val newHole)+ putMVar writeVar newHole+-- >>++-- <<readChan+readChan :: Chan a -> IO a+readChan (Chan readVar _) = do+ stream <- takeMVar readVar -- <1>+ Item val tail <- takeMVar stream -- <2>+ putMVar readVar tail -- <3>+ return val+-- >>++-- <<dupChan+dupChan :: Chan a -> IO (Chan a)+dupChan (Chan _ writeVar) = do+ hole <- readMVar writeVar+ newReadVar <- newMVar hole+ return (Chan newReadVar writeVar)+-- >>++main = do+ c <- newChan+ writeChan c 'a'+ readChan c >>= print
+ chan2.hs view
@@ -0,0 +1,66 @@+import Control.Concurrent hiding (Chan, newChan, readChan, writeChan, dupChan)++-- <<Stream+type Stream a = MVar (Item a)+data Item a = Item a (Stream a)+-- >>++-- <<Chan+data Chan a+ = Chan (MVar (Stream a))+ (MVar (Stream a))+-- >>++-- <<newChan+newChan :: IO (Chan a)+newChan = do+ hole <- newEmptyMVar+ readVar <- newMVar hole+ writeVar <- newMVar hole+ return (Chan readVar writeVar)+-- >>++-- <<writeChan+writeChan :: Chan a -> a -> IO ()+writeChan (Chan _ writeVar) val = do+ newHole <- newEmptyMVar+ oldHole <- takeMVar writeVar+ putMVar oldHole (Item val newHole)+ putMVar writeVar newHole+-- >>++-- <<readChan+readChan :: Chan a -> IO a+readChan (Chan readVar _) = do+ stream <- takeMVar readVar+ Item val tail <- readMVar stream -- <1>+ putMVar readVar tail+ return val+-- >>++-- <<dupChan+dupChan :: Chan a -> IO (Chan a)+dupChan (Chan _ writeVar) = do+ hole <- takeMVar writeVar+ putMVar writeVar hole+ newReadVar <- newMVar hole+ return (Chan newReadVar writeVar)+-- >>++-- <<unGetChan+unGetChan :: Chan a -> a -> IO ()+unGetChan (Chan readVar _) val = do+ newReadEnd <- newEmptyMVar -- <1>+ readEnd <- takeMVar readVar -- <2>+ putMVar newReadEnd (Item val readEnd) -- <3>+ putMVar readVar newReadEnd -- <4>+-- >>++main = do+ c <- newChan+ writeChan c 'a'+ readChan c >>= print+ c2 <- dupChan c+ writeChan c 'b'+ readChan c >>= print+ readChan c2 >>= print
+ chan3.hs view
@@ -0,0 +1,54 @@+import Control.Concurrent hiding (Chan, newChan, readChan, writeChan, dupChan)+import Control.Exception++-- <<Stream+type Stream a = MVar (Item a)+data Item a = Item a (Stream a)+-- >>++-- <<Chan+data Chan a+ = Chan (MVar (Stream a))+ (MVar (Stream a))+-- >>++-- <<newChan+newChan :: IO (Chan a)+newChan = do+ hole <- newEmptyMVar+ readVar <- newMVar hole+ writeVar <- newMVar hole+ return (Chan readVar writeVar)+-- >>++-- <<wrongWriteChan+wrongWriteChan :: Chan a -> a -> IO ()+wrongWriteChan (Chan _ writeVar) val = do+ newHole <- newEmptyMVar+ modifyMVar_ writeVar $ \oldHole -> do+ putMVar oldHole (Item val newHole) -- <1>+ return newHole -- <2>+-- >>++-- <<writeChan+writeChan :: Chan a -> a -> IO ()+writeChan (Chan _ writeVar) val = do+ newHole <- newEmptyMVar+ mask_ $ do+ oldHole <- takeMVar writeVar+ putMVar oldHole (Item val newHole)+ putMVar writeVar newHole+-- >>++-- <<readChan+readChan :: Chan a -> IO a+readChan (Chan readVar _) = do+ modifyMVar readVar $ \stream -> do+ Item val tail <- readMVar stream+ return (tail, val)+-- >>++main = do+ c <- newChan+ writeChan c 'a'+ readChan c >>= print
+ chat.hs view
@@ -0,0 +1,251 @@+{-+ Adapted from haskell-chat-sever-example which is+ Copyright (c) 2012, Joseph Adams++ Modifications (c) 2012, Simon Marlow+-}++{-# LANGUAGE RecordWildCards #-}+module Main where++import ConcurrentUtils++import Control.Concurrent+import Control.Concurrent.STM+import Control.Concurrent.Async+import qualified Data.Map as Map+import Data.Map (Map)+import System.IO+import Control.Exception+import Network+import Control.Monad+import Text.Printf++{-+Notes++- protocol:+ Server: "Name?"+ Client: <string>+ -- if <string> is already in use, ask for another name+ -- Commands:+ -- /tell <string> message... (single-user tell)+ -- /quit (exit)+ -- /kick <string> (kick another user)+ -- message... (broadcast to all connected users)++- a client needs to both listen for commands from the socket and+ listen for activity from other clients. Therefore we're going to+ need at least two threads per client (for listening to multiple+ things). Easiest is to use STM for in-process communication, and to+ have a receiving thread that listens on the socket and forwards to a+ TChan.++- Handle all errors properly, be async-exception safe++- Consistency:+ - if two clients simultaneously kick a third client, only one will be+ successful++See doc/lab-exercises.tex for some ideas for enhancements that you+could try.++-}++-- <<main+main :: IO ()+main = withSocketsDo $ do+ server <- newServer+ sock <- listenOn (PortNumber (fromIntegral port))+ printf "Listening on port %d\n" port+ forever $ do+ (handle, host, port) <- accept sock+ printf "Accepted connection from %s: %s\n" host (show port)+ forkFinally (talk handle server) (\_ -> hClose handle)++port :: Int+port = 44444+-- >>+++-- ---------------------------------------------------------------------------+-- Data structures and initialisation++-- <<Client+type ClientName = String++data Client = Client+ { clientName :: ClientName+ , clientHandle :: Handle+ , clientKicked :: TVar (Maybe String)+ , clientSendChan :: TChan Message+ }+-- >>++-- <<newClient+newClient :: ClientName -> Handle -> STM Client+newClient name handle = do+ c <- newTChan+ k <- newTVar Nothing+ return Client { clientName = name+ , clientHandle = handle+ , clientSendChan = c+ , clientKicked = k+ }+-- >>++-- <<Server+data Server = Server+ { clients :: TVar (Map ClientName Client)+ }++newServer :: IO Server+newServer = do+ c <- newTVarIO Map.empty+ return Server { clients = c }+-- >>++-- <<Message+data Message = Notice String+ | Tell ClientName String+ | Broadcast ClientName String+ | Command String+-- >>++-- -----------------------------------------------------------------------------+-- Basic operations++-- <<broadcast+broadcast :: Server -> Message -> STM ()+broadcast Server{..} msg = do+ clientmap <- readTVar clients+ mapM_ (\client -> sendMessage client msg) (Map.elems clientmap)+-- >>++-- <<sendMessage+sendMessage :: Client -> Message -> STM ()+sendMessage Client{..} msg =+ writeTChan clientSendChan msg+-- >>++-- <<sendToName+sendToName :: Server -> ClientName -> Message -> STM Bool+sendToName server@Server{..} name msg = do+ clientmap <- readTVar clients+ case Map.lookup name clientmap of+ Nothing -> return False+ Just client -> sendMessage client msg >> return True+-- >>++tell :: Server -> Client -> ClientName -> String -> IO ()+tell server@Server{..} Client{..} who msg = do+ ok <- atomically $ sendToName server who (Tell clientName msg)+ if ok+ then return ()+ else hPutStrLn clientHandle (who ++ " is not connected.")++kick :: Server -> ClientName -> ClientName -> STM ()+kick server@Server{..} who by = do+ clientmap <- readTVar clients+ case Map.lookup who clientmap of+ Nothing ->+ void $ sendToName server by (Notice $ who ++ " is not connected")+ Just victim -> do+ writeTVar (clientKicked victim) $ Just ("by " ++ by)+ void $ sendToName server by (Notice $ "you kicked " ++ who)++-- -----------------------------------------------------------------------------+-- The main server++talk :: Handle -> Server -> IO ()+talk handle server@Server{..} = do+ hSetNewlineMode handle universalNewlineMode+ -- Swallow carriage returns sent by telnet clients+ hSetBuffering handle LineBuffering+ readName+ where+-- <<readName+ readName = do+ hPutStrLn handle "What is your name?"+ name <- hGetLine handle+ if null name+ then readName+ else mask $ \restore -> do -- <1>+ ok <- checkAddClient server name handle+ case ok of+ Nothing -> restore $ do -- <2>+ hPrintf handle+ "The name %s is in use, please choose another\n" name+ readName+ Just client ->+ restore (runClient server client) -- <3>+ `finally` removeClient server name+-- >>++-- <<checkAddClient+checkAddClient :: Server -> ClientName -> Handle -> IO (Maybe Client)+checkAddClient server@Server{..} name handle = atomically $ do+ clientmap <- readTVar clients+ if Map.member name clientmap+ then return Nothing+ else do client <- newClient name handle+ writeTVar clients $ Map.insert name client clientmap+ broadcast server $ Notice (name ++ " has connected")+ return (Just client)+-- >>++-- <<removeClient+removeClient :: Server -> ClientName -> IO ()+removeClient server@Server{..} name = atomically $ do+ modifyTVar' clients $ Map.delete name+ broadcast server $ Notice (name ++ " has disconnected")+-- >>++-- <<runClient+runClient :: Server -> Client -> IO ()+runClient serv@Server{..} client@Client{..} = do+ race server receive+ return ()+ where+ receive = forever $ do+ msg <- hGetLine clientHandle+ atomically $ sendMessage client (Command msg)++ server = join $ atomically $ do+ k <- readTVar clientKicked+ case k of+ Just reason -> return $+ hPutStrLn clientHandle $ "You have been kicked: " ++ reason+ Nothing -> do+ msg <- readTChan clientSendChan+ return $ do+ continue <- handleMessage serv client msg+ when continue $ server+-- >>++-- <<handleMessage+handleMessage :: Server -> Client -> Message -> IO Bool+handleMessage server client@Client{..} message =+ case message of+ Notice msg -> output $ "*** " ++ msg+ Tell name msg -> output $ "*" ++ name ++ "*: " ++ msg+ Broadcast name msg -> output $ "<" ++ name ++ ">: " ++ msg+ Command msg ->+ case words msg of+ ["/kick", who] -> do+ atomically $ kick server who clientName+ return True+ "/tell" : who : what -> do+ tell server client who (unwords what)+ return True+ ["/quit"] ->+ return False+ ('/':_):_ -> do+ hPutStrLn clientHandle $ "Unrecognised command: " ++ msg+ return True+ _ -> do+ atomically $ broadcast server $ Broadcast clientName msg+ return True+ where+ output s = do hPutStrLn clientHandle s; return True+-- >>
+ deadlock1.hs view
@@ -0,0 +1,10 @@+import Control.Concurrent+import Control.Exception++-- <<main+main = do+ lock <- newEmptyMVar+ complete <- newEmptyMVar+ forkIO $ takeMVar lock `finally` putMVar complete ()+ takeMVar complete+-- >>
+ deadlock2.hs view
@@ -0,0 +1,10 @@+import Control.Concurrent+import Control.Exception as E++-- <<main+main = do+ lock <- newEmptyMVar+ forkIO $ do r <- try (takeMVar lock); print (r :: Either SomeException ())+ threadDelay 1000000+ print (lock == lock)+-- >>
+ distrib-chat/chat-noslave.hs view
@@ -0,0 +1,419 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-}+import Control.Distributed.Process hiding (mask, finally)+import Control.Distributed.Process.Closure+import Control.Distributed.Process.Backend.SimpleLocalnet+import Control.Distributed.Process.Node as Node hiding (newLocalNode)+import Control.Concurrent.Async+import Control.Monad.IO.Class+import Control.Monad+import Text.Printf+import Control.Concurrent+import GHC.Generics (Generic)+import Data.Binary+import Data.Typeable+import Network+import System.IO+import Control.Concurrent.STM+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Foldable as F+import Control.Exception+import System.Environment++import ConcurrentUtils++-- ---------------------------------------------------------------------------+-- Data structures and initialisation++-- <<Client+type ClientName = String++data Client+ = ClientLocal LocalClient+ | ClientRemote RemoteClient++data RemoteClient = RemoteClient+ { remoteName :: ClientName+ , clientHome :: ProcessId+ }++data LocalClient = LocalClient+ { localName :: ClientName+ , clientHandle :: Handle+ , clientKicked :: TVar (Maybe String)+ , clientSendChan :: TChan Message+ }++clientName :: Client -> ClientName+clientName (ClientLocal c) = localName c+clientName (ClientRemote c) = remoteName c++newLocalClient :: ClientName -> Handle -> STM LocalClient+newLocalClient name handle = do+ c <- newTChan+ k <- newTVar Nothing+ return LocalClient { localName = name+ , clientHandle = handle+ , clientSendChan = c+ , clientKicked = k+ }+-- >>+++-- <<Message+data Message = Notice String+ | Tell ClientName String+ | Broadcast ClientName String+ | Command String+ deriving (Typeable, Generic)++instance Binary Message+-- >>+++-- <<PMessage+data PMessage+ = MsgServerInfo Bool ProcessId [ClientName]+ | MsgSend ClientName Message+ | MsgBroadcast Message+ | MsgKick ClientName ClientName+ | MsgNewClient ClientName ProcessId+ | MsgClientDisconnected ClientName ProcessId+ deriving (Typeable, Generic)++instance Binary PMessage+-- >>+++-- <<Server+data Server = Server+ { clients :: TVar (Map ClientName Client)+ , proxychan :: TChan (Process ())+ , servers :: TVar [ProcessId]+ , spid :: ProcessId+ }++newServer :: [ProcessId] -> Process Server+newServer pids = do+ pid <- getSelfPid+ liftIO $ do+ s <- newTVarIO pids+ c <- newTVarIO Map.empty+ o <- newTChanIO+ return Server { clients = c, servers = s, proxychan = o, spid = pid }++localClientNames :: Map ClientName Client -> [ClientName]+localClientNames m = [ localName c | ClientLocal c <- Map.elems m ]+-- >>++-- -----------------------------------------------------------------------------+-- Basic operations++-- <<sendLocal+sendLocal :: LocalClient -> Message -> STM ()+sendLocal LocalClient{..} msg = writeTChan clientSendChan msg+-- >>++-- <<sendRemote+sendRemote :: Server -> ProcessId -> PMessage -> STM ()+sendRemote Server{..} pid pmsg = writeTChan proxychan (send pid pmsg)+-- >>++-- <<sendMessage+sendMessage :: Server -> Client -> Message -> STM ()+sendMessage server (ClientLocal client) msg =+ sendLocal client msg+sendMessage server (ClientRemote client) msg =+ sendRemote server (clientHome client) (MsgSend (remoteName client) msg)+-- >>++-- <<sendToName+sendToName :: Server -> ClientName -> Message -> STM Bool+sendToName server@Server{..} name msg = do+ clientmap <- readTVar clients+ case Map.lookup name clientmap of+ Nothing -> return False+ Just client -> sendMessage server client msg >> return True+-- >>++-- <<sendRemoteAll+sendRemoteAll :: Server -> PMessage -> STM ()+sendRemoteAll server@Server{..} pmsg = do+ pids <- readTVar servers+ mapM_ (\pid -> sendRemote server pid pmsg) pids+-- >>++-- <<broadcastLocal+broadcastLocal :: Server -> Message -> STM ()+broadcastLocal server@Server{..} msg = do+ clientmap <- readTVar clients+ mapM_ sendIfLocal (Map.elems clientmap)+ where+ sendIfLocal (ClientLocal c) = sendLocal c msg+ sendIfLocal (ClientRemote _) = return ()+-- >>++-- <<broadcast+broadcast :: Server -> Message -> STM ()+broadcast server@Server{..} msg = do+ sendRemoteAll server (MsgBroadcast msg)+ broadcastLocal server msg+-- >>++-- <<tell+tell :: Server -> LocalClient -> ClientName -> String -> IO ()+tell server@Server{..} LocalClient{..} who msg = do+ ok <- atomically $ sendToName server who (Tell localName msg)+ if ok+ then return ()+ else hPutStrLn clientHandle (who ++ " is not connected.")+-- >>++-- <<kick+kick :: Server -> ClientName -> ClientName -> STM ()+kick server@Server{..} who by = do+ clientmap <- readTVar clients+ case Map.lookup who clientmap of+ Nothing ->+ void $ sendToName server by (Notice $ who ++ " is not connected")+ Just (ClientLocal victim) -> do+ writeTVar (clientKicked victim) $ Just ("by " ++ by)+ void $ sendToName server by (Notice $ "you kicked " ++ who)+ Just (ClientRemote victim) -> do+ sendRemote server (clientHome victim) (MsgKick who by)+-- >>++-- -----------------------------------------------------------------------------+-- Handle a local client++talk :: Server -> Handle -> IO ()+talk server@Server{..} handle = do+ hSetNewlineMode handle universalNewlineMode+ -- Swallow carriage returns sent by telnet clients+ hSetBuffering handle LineBuffering+ readName+ where+-- <<readName+ readName = do+ hPutStrLn handle "What is your name?"+ name <- hGetLine handle+ if null name+ then readName+ else mask $ \restore -> do+ client <- atomically $ newLocalClient name handle+ ok <- atomically $ checkAddClient server (ClientLocal client)+ if not ok+ then restore $ do+ hPrintf handle+ "The name %s is in use, please choose another\n" name+ readName+ else do+ atomically $ sendRemoteAll server (MsgNewClient name spid)+ restore (runClient server client)+ `finally` disconnectLocalClient server name+-- >>++checkAddClient :: Server -> Client -> STM Bool+checkAddClient server@Server{..} client = do+ clientmap <- readTVar clients+ let name = clientName client+ if Map.member name clientmap+ then return False+ else do writeTVar clients (Map.insert name client clientmap)+ broadcastLocal server $ Notice $ name ++ " has connected"+ return True++deleteClient :: Server -> ClientName -> STM ()+deleteClient server@Server{..} name = do+ modifyTVar' clients $ Map.delete name+ broadcastLocal server $ Notice $ name ++ " has disconnected"++disconnectLocalClient :: Server -> ClientName -> IO ()+disconnectLocalClient server@Server{..} name = atomically $ do+ deleteClient server name+ sendRemoteAll server (MsgClientDisconnected name spid)++-- <<runClient+runClient :: Server -> LocalClient -> IO ()+runClient serv@Server{..} client@LocalClient{..} = do+ race server receive+ return ()+ where+ receive = forever $ do+ msg <- hGetLine clientHandle+ atomically $ sendLocal client (Command msg)++ server = join $ atomically $ do+ k <- readTVar clientKicked+ case k of+ Just reason -> return $+ hPutStrLn clientHandle $ "You have been kicked: " ++ reason+ Nothing -> do+ msg <- readTChan clientSendChan+ return $ do+ continue <- handleMessage serv client msg+ when continue $ server+-- >>++-- <<handleMessage+handleMessage :: Server -> LocalClient -> Message -> IO Bool+handleMessage server client@LocalClient{..} message =+ case message of+ Notice msg -> output $ "*** " ++ msg+ Tell name msg -> output $ "*" ++ name ++ "*: " ++ msg+ Broadcast name msg -> output $ "<" ++ name ++ ">: " ++ msg+ Command msg ->+ case words msg of+ ["/kick", who] -> do+ atomically $ kick server who localName+ return True+ "/tell" : who : what -> do+ tell server client who (unwords what)+ return True+ ["/quit"] ->+ return False+ ('/':_):_ -> do+ hPutStrLn clientHandle $ "Unrecognised command: " ++ msg+ return True+ _ -> do+ atomically $ broadcast server $ Broadcast localName msg+ return True+ where+ output s = do hPutStrLn clientHandle s; return True+-- >>++-- -----------------------------------------------------------------------------+-- Main server++-- <<socketListener+socketListener :: Server -> Int -> IO ()+socketListener server port = withSocketsDo $ do+ sock <- listenOn (PortNumber (fromIntegral port))+ printf "Listening on port %d\n" port+ forever $ do+ (handle, host, port) <- accept sock+ printf "Accepted connection from %s: %s\n" host (show port)+ forkFinally (talk server handle)+ (\_ -> hClose handle)+-- >>++-- <<proxy+proxy :: Server -> Process ()+proxy Server{..} = forever $ join $ liftIO $ atomically $ readTChan proxychan+-- >>++chatServer :: Int -> Process ()+chatServer port = do+ server <- newServer []+ liftIO $ forkIO (socketListener server port)+ spawnLocal (proxy server)+ forever $+ receiveWait+ [ match $ handleRemoteMessage server+ , match $ handleMonitorNotification server+ , matchIf (\(WhereIsReply l _) -> l == "chatServer") $+ handleWhereIsReply server+ , matchAny $ \_ -> return () -- discard unknown messages+ ]++handleWhereIsReply _ (WhereIsReply _ Nothing) = return ()+handleWhereIsReply server@Server{..} (WhereIsReply _ (Just pid)) =+ liftIO $ atomically $ do+ clientmap <- readTVar clients+ -- send our own server info,and request a response:+ sendRemote server pid (MsgServerInfo True spid (localClientNames clientmap))++handleMonitorNotification :: Server -> ProcessMonitorNotification -> Process ()+handleMonitorNotification+ server@Server{..} (ProcessMonitorNotification _ pid _) = do+ say (printf "server on %s has died" (show pid))+ liftIO $ atomically $ do+ old_pids <- readTVar servers+ writeTVar servers (filter (/= pid) old_pids)+ clientmap <- readTVar clients+ let+ now_disconnected (ClientRemote RemoteClient{..}) = clientHome == pid+ now_disconnected _ = False++ disconnected_clients = Map.filter now_disconnected clientmap++ writeTVar clients (Map.filter (not . now_disconnected) clientmap)+ mapM_ (deleteClient server) (Map.keys disconnected_clients)++handleRemoteMessage :: Server -> PMessage -> Process ()+handleRemoteMessage server@Server{..} m =+ case m of+ MsgServerInfo rsvp pid clients -> newServerInfo server rsvp pid clients+ MsgSend name msg -> liftIO $ atomically $ void $ sendToName server name msg+ MsgBroadcast msg -> liftIO $ atomically $ broadcastLocal server msg+ MsgKick who by -> liftIO $ atomically $ kick server who by++ MsgNewClient name pid -> liftIO $ atomically $ do+ ok <- checkAddClient server (ClientRemote (RemoteClient name pid))+ when (not ok) $+ sendRemote server pid (MsgKick name "SYSTEM")++ MsgClientDisconnected name pid -> liftIO $ atomically $ do+ clientmap <- readTVar clients+ case Map.lookup name clientmap of+ Nothing -> return ()+ Just (ClientRemote (RemoteClient _ pid')) | pid == pid' ->+ deleteClient server name+ Just _ ->+ return ()++newServerInfo :: Server -> Bool -> ProcessId -> [ClientName] -> Process ()+newServerInfo server@Server{..} rsvp pid remote_clients = do+ liftIO $ printf "%s received server info from %s\n" (show spid) (show pid)+ join $ liftIO $ atomically $ do+ old_pids <- readTVar servers+ writeTVar servers (pid : filter (/= pid) old_pids)++ clientmap <- readTVar clients++ let new_clientmap = Map.union clientmap $ Map.fromList+ [ (n, ClientRemote (RemoteClient n pid)) | n <- remote_clients ]+ -- ToDo: should remove other remote clients with this pid+ -- ToDo: also deal with conflicts+ writeTVar clients new_clientmap++ when rsvp $ do+ sendRemote server pid+ (MsgServerInfo False spid (localClientNames new_clientmap))++ -- monitor the new server+ return (when (pid `notElem` old_pids) $ void $ monitor pid)++remotable ['chatServer]++port :: Int+port = 44444++master :: Backend -> String -> Process ()+master backend port = do++ mynode <- getSelfNode++ peers0 <- liftIO $ findPeers backend 1000000+ let peers = filter (/= mynode) peers0++ say ("peers are " ++ show peers)++ mypid <- getSelfPid+ register "chatServer" mypid++ forM_ peers $ \peer -> do+ whereisRemoteAsync peer "chatServer"++ chatServer (read port :: Int)++-- <<main+main = do+ [port, chat_port] <- getArgs+ backend <- initializeBackend "localhost" port+ (Main.__remoteTable initRemoteTable)+ node <- newLocalNode backend+ Node.runProcess node (master backend chat_port)+-- >>+
+ distrib-chat/chat.hs view
@@ -0,0 +1,355 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-}+import Control.Distributed.Process hiding (mask, finally)+import Control.Distributed.Process.Closure+import Control.Concurrent.Async+import Control.Monad.IO.Class+import Control.Monad+import Text.Printf+import Control.Concurrent+import GHC.Generics (Generic)+import Data.Binary+import Data.Typeable+import Network+import System.IO+import Control.Concurrent.STM+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Foldable as F+import Control.Exception++import ConcurrentUtils+import DistribUtils++-- ---------------------------------------------------------------------------+-- Data structures and initialisation++-- <<Client+type ClientName = String++data Client+ = ClientLocal LocalClient+ | ClientRemote RemoteClient++data RemoteClient = RemoteClient+ { remoteName :: ClientName+ , clientHome :: ProcessId+ }++data LocalClient = LocalClient+ { localName :: ClientName+ , clientHandle :: Handle+ , clientKicked :: TVar (Maybe String)+ , clientSendChan :: TChan Message+ }++clientName :: Client -> ClientName+clientName (ClientLocal c) = localName c+clientName (ClientRemote c) = remoteName c++newLocalClient :: ClientName -> Handle -> STM LocalClient+newLocalClient name handle = do+ c <- newTChan+ k <- newTVar Nothing+ return LocalClient { localName = name+ , clientHandle = handle+ , clientSendChan = c+ , clientKicked = k+ }+-- >>+++-- <<Message+data Message = Notice String+ | Tell ClientName String+ | Broadcast ClientName String+ | Command String+ deriving (Typeable, Generic)++instance Binary Message+-- >>+++-- <<PMessage+data PMessage+ = MsgServers [ProcessId]+ | MsgSend ClientName Message+ | MsgBroadcast Message+ | MsgKick ClientName ClientName+ | MsgNewClient ClientName ProcessId+ | MsgClientDisconnected ClientName ProcessId+ deriving (Typeable, Generic)++instance Binary PMessage+-- >>+++-- <<Server+data Server = Server+ { clients :: TVar (Map ClientName Client)+ , proxychan :: TChan (Process ())+ , servers :: TVar [ProcessId]+ , spid :: ProcessId+ }++newServer :: [ProcessId] -> Process Server+newServer pids = do+ pid <- getSelfPid+ liftIO $ do+ s <- newTVarIO pids+ c <- newTVarIO Map.empty+ o <- newTChanIO+ return Server { clients = c, servers = s, proxychan = o, spid = pid }+-- >>++-- -----------------------------------------------------------------------------+-- Basic operations++-- <<sendLocal+sendLocal :: LocalClient -> Message -> STM ()+sendLocal LocalClient{..} msg = writeTChan clientSendChan msg+-- >>++-- <<sendRemote+sendRemote :: Server -> ProcessId -> PMessage -> STM ()+sendRemote Server{..} pid pmsg = writeTChan proxychan (send pid pmsg)+-- >>++-- <<sendMessage+sendMessage :: Server -> Client -> Message -> STM ()+sendMessage server (ClientLocal client) msg =+ sendLocal client msg+sendMessage server (ClientRemote client) msg =+ sendRemote server (clientHome client) (MsgSend (remoteName client) msg)+-- >>++-- <<sendToName+sendToName :: Server -> ClientName -> Message -> STM Bool+sendToName server@Server{..} name msg = do+ clientmap <- readTVar clients+ case Map.lookup name clientmap of+ Nothing -> return False+ Just client -> sendMessage server client msg >> return True+-- >>++-- <<sendRemoteAll+sendRemoteAll :: Server -> PMessage -> STM ()+sendRemoteAll server@Server{..} pmsg = do+ pids <- readTVar servers+ mapM_ (\pid -> sendRemote server pid pmsg) pids+-- >>++-- <<broadcastLocal+broadcastLocal :: Server -> Message -> STM ()+broadcastLocal server@Server{..} msg = do+ clientmap <- readTVar clients+ mapM_ sendIfLocal (Map.elems clientmap)+ where+ sendIfLocal (ClientLocal c) = sendLocal c msg+ sendIfLocal (ClientRemote _) = return ()+-- >>++-- <<broadcast+broadcast :: Server -> Message -> STM ()+broadcast server@Server{..} msg = do+ sendRemoteAll server (MsgBroadcast msg)+ broadcastLocal server msg+-- >>++-- <<tell+tell :: Server -> LocalClient -> ClientName -> String -> IO ()+tell server@Server{..} LocalClient{..} who msg = do+ ok <- atomically $ sendToName server who (Tell localName msg)+ if ok+ then return ()+ else hPutStrLn clientHandle (who ++ " is not connected.")+-- >>++-- <<kick+kick :: Server -> ClientName -> ClientName -> STM ()+kick server@Server{..} who by = do+ clientmap <- readTVar clients+ case Map.lookup who clientmap of+ Nothing ->+ void $ sendToName server by (Notice $ who ++ " is not connected")+ Just (ClientLocal victim) -> do+ writeTVar (clientKicked victim) $ Just ("by " ++ by)+ void $ sendToName server by (Notice $ "you kicked " ++ who)+ Just (ClientRemote victim) -> do+ sendRemote server (clientHome victim) (MsgKick who by)+-- >>++-- -----------------------------------------------------------------------------+-- Handle a local client++talk :: Server -> Handle -> IO ()+talk server@Server{..} handle = do+ hSetNewlineMode handle universalNewlineMode+ -- Swallow carriage returns sent by telnet clients+ hSetBuffering handle LineBuffering+ readName+ where+-- <<readName+ readName = do+ hPutStrLn handle "What is your name?"+ name <- hGetLine handle+ if null name+ then readName+ else mask $ \restore -> do+ client <- atomically $ newLocalClient name handle+ ok <- atomically $ checkAddClient server (ClientLocal client)+ if not ok+ then restore $ do+ hPrintf handle+ "The name %s is in use, please choose another\n" name+ readName+ else do+ atomically $ sendRemoteAll server (MsgNewClient name spid)+ restore (runClient server client)+ `finally` disconnectLocalClient server name+-- >>++checkAddClient :: Server -> Client -> STM Bool+checkAddClient server@Server{..} client = do+ clientmap <- readTVar clients+ let name = clientName client+ if Map.member name clientmap+ then return False+ else do writeTVar clients (Map.insert name client clientmap)+ broadcastLocal server $ Notice $ name ++ " has connected"+ return True++deleteClient :: Server -> ClientName -> STM ()+deleteClient server@Server{..} name = do+ modifyTVar' clients $ Map.delete name+ broadcastLocal server $ Notice $ name ++ " has disconnected"++disconnectLocalClient :: Server -> ClientName -> IO ()+disconnectLocalClient server@Server{..} name = atomically $ do+ deleteClient server name+ sendRemoteAll server (MsgClientDisconnected name spid)++-- <<runClient+runClient :: Server -> LocalClient -> IO ()+runClient serv@Server{..} client@LocalClient{..} = do+ race server receive+ return ()+ where+ receive = forever $ do+ msg <- hGetLine clientHandle+ atomically $ sendLocal client (Command msg)++ server = join $ atomically $ do+ k <- readTVar clientKicked+ case k of+ Just reason -> return $+ hPutStrLn clientHandle $ "You have been kicked: " ++ reason+ Nothing -> do+ msg <- readTChan clientSendChan+ return $ do+ continue <- handleMessage serv client msg+ when continue $ server+-- >>++-- <<handleMessage+handleMessage :: Server -> LocalClient -> Message -> IO Bool+handleMessage server client@LocalClient{..} message =+ case message of+ Notice msg -> output $ "*** " ++ msg+ Tell name msg -> output $ "*" ++ name ++ "*: " ++ msg+ Broadcast name msg -> output $ "<" ++ name ++ ">: " ++ msg+ Command msg ->+ case words msg of+ ["/kick", who] -> do+ atomically $ kick server who localName+ return True+ "/tell" : who : what -> do+ tell server client who (unwords what)+ return True+ ["/quit"] ->+ return False+ ('/':_):_ -> do+ hPutStrLn clientHandle $ "Unrecognised command: " ++ msg+ return True+ _ -> do+ atomically $ broadcast server $ Broadcast localName msg+ return True+ where+ output s = do hPutStrLn clientHandle s; return True+-- >>++-- -----------------------------------------------------------------------------+-- Main server++-- <<socketListener+socketListener :: Server -> Int -> IO ()+socketListener server port = withSocketsDo $ do+ sock <- listenOn (PortNumber (fromIntegral port))+ printf "Listening on port %d\n" port+ forever $ do+ (handle, host, port) <- accept sock+ printf "Accepted connection from %s: %s\n" host (show port)+ forkFinally (talk server handle)+ (\_ -> hClose handle)+-- >>++-- <<proxy+proxy :: Server -> Process ()+proxy Server{..} = forever $ join $ liftIO $ atomically $ readTChan proxychan+-- >>++-- <<chatServer+chatServer :: Int -> Process ()+chatServer port = do+ server <- newServer []+ liftIO $ forkIO (socketListener server port) -- <1>+ spawnLocal (proxy server) -- <2>+ forever $ do m <- expect; handleRemoteMessage server m -- <3>+-- >>++-- <<handleRemoteMessage+handleRemoteMessage :: Server -> PMessage -> Process ()+handleRemoteMessage server@Server{..} m = liftIO $ atomically $+ case m of+ MsgServers pids -> writeTVar servers (filter (/= spid) pids) -- <1>+ MsgSend name msg -> void $ sendToName server name msg -- <2>+ MsgBroadcast msg -> broadcastLocal server msg -- <2>+ MsgKick who by -> kick server who by -- <2>++ MsgNewClient name pid -> do -- <3>+ ok <- checkAddClient server (ClientRemote (RemoteClient name pid))+ when (not ok) $+ sendRemote server pid (MsgKick name "SYSTEM")++ MsgClientDisconnected name pid -> do -- <4>+ clientmap <- readTVar clients+ case Map.lookup name clientmap of+ Nothing -> return ()+ Just (ClientRemote (RemoteClient _ pid')) | pid == pid' ->+ deleteClient server name+ Just _ ->+ return ()+-- >>++remotable ['chatServer]++-- <<main+port :: Int+port = 44444++master :: [NodeId] -> Process ()+master peers = do++ let run nid port = do+ say $ printf "spawning on %s" (show nid)+ spawn nid ($(mkClosure 'chatServer) port)++ pids <- zipWithM run peers [port+1..]+ mypid <- getSelfPid+ let all_pids = mypid : pids+ mapM_ (\pid -> send pid (MsgServers all_pids)) all_pids++ chatServer port++main = distribMain master Main.__remoteTable+-- >>
+ distrib-db/Database.hs view
@@ -0,0 +1,31 @@+module Database (+ Database,+ Key, Value,+ createDB,+ get, set,+ rcdata,+ ) where++import Control.Distributed.Process++import qualified Data.Map as Map+import Data.Map (Map)++type Key = String+type Value = String++type Database = ProcessId++createDB :: [NodeId] -> Process Database+createDB nodes = error "not implemented!" -- exercise++set :: Database -> Key -> Value -> Process ()+set db k v = error "not implemented!" -- exercise++get :: Database -> Key -> Process (Maybe Value)+get db k = error "not implemented!" -- exercise++rcdata :: RemoteTable -> RemoteTable+rcdata = id+ -- For the exercise, change this to include your+ -- remote metadata, e.g. rcdata = Database.__remoteTable
+ distrib-db/db.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Distributed.Process+import Control.Monad.IO.Class+import Control.Monad+import System.IO++import DistribUtils++import Database (Database, createDB, get, set, rcdata)++main = distribMain master rcdata++master :: [NodeId] -> Process ()+master peers = do+ db <- createDB peers++ f <- liftIO $ readFile "Database.hs"+ let ws = words f++ zipWithM_ (set db) ws (tail ws)++ get db "module" >>= liftIO . print+ get db "xxxx" >>= liftIO . print++ forever $ do+ l <- liftIO $ do putStr "key: "; hFlush stdout; getLine+ when (not (null l)) $ do+ r <- get db l+ liftIO $ putStrLn ("response: " ++ show r)++ return ()
+ distrib-ping/ping-fail.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, DeriveGeneric #-}+{-# OPTIONS_GHC -Wall #-}+import Control.Distributed.Process+import Control.Distributed.Process.Closure++import Text.Printf+import GHC.Generics (Generic)+import Data.Binary+import Data.Typeable++import DistribUtils++-- <<Message+data Message = Ping ProcessId+ | Pong ProcessId+ deriving (Typeable, Generic)++instance Binary Message+-- >>++-- <<pingServer+pingServer :: Process ()+pingServer = do+ Ping from <- expect+ say $ printf "ping received from %s" (show from)+ mypid <- getSelfPid+ send from (Pong mypid)+-- >>++-- <<remotable+remotable ['pingServer]+-- >>++master :: Process ()+master = do+ node <- getSelfNode++ say $ printf "spawning on %s" (show node)+ pid <- spawn node $(mkStaticClosure 'pingServer)++ mypid <- getSelfPid+ say $ printf "sending ping to %s" (show pid)++-- <<withMonitor+ withMonitor pid $ do+ send pid (Pong mypid) -- <1>+ receiveWait+ [ match $ \(Pong _) -> do+ say "pong."+ terminate+ , match $ \(ProcessMonitorNotification _ref deadpid reason) -> do+ say (printf "process %s died: %s" (show deadpid) (show reason))+ terminate+ ]+-- >>++-- <<main+main :: IO ()+main = distribMain (\_ -> master) Main.__remoteTable+-- >>
+ distrib-ping/ping-multi.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, DeriveGeneric #-}+{-# OPTIONS_GHC -Wall #-}+import Control.Distributed.Process+import Control.Distributed.Process.Closure++import Control.Monad+import Text.Printf+import GHC.Generics (Generic)+import Data.Binary+import Data.Typeable++import DistribUtils++-- <<Message+data Message = Ping ProcessId+ | Pong ProcessId+ deriving (Typeable, Generic) -- <1>++instance Binary Message -- <2>+-- >>++-- <<pingServer+pingServer :: Process ()+pingServer = do+ Ping from <- expect -- <1>+ say $ printf "ping received from %s" (show from) -- <2>+ mypid <- getSelfPid -- <3>+ send from (Pong mypid) -- <4>+-- >>++-- <<remotable+remotable ['pingServer]+-- >>++-- <<master+master :: [NodeId] -> Process () -- <1>+master peers = do++ ps <- forM peers $ \nid -> do -- <2>+ say $ printf "spawning on %s" (show nid)+ spawn nid $(mkStaticClosure 'pingServer)++ mypid <- getSelfPid++ forM_ ps $ \pid -> do -- <3>+ say $ printf "pinging %s" (show pid)+ send pid (Ping mypid)++ waitForPongs ps -- <4>++ say "All pongs successfully received"+ terminate++waitForPongs :: [ProcessId] -> Process () -- <5>+waitForPongs [] = return ()+waitForPongs ps = do+ m <- expect+ case m of+ Pong p -> waitForPongs (filter (/= p) ps)+ _ -> say "MASTER received ping" >> terminate+-- >>++-- <<main+main :: IO ()+main = distribMain master Main.__remoteTable+-- >>
+ distrib-ping/ping-tc-merge.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, DeriveGeneric #-}+{-# OPTIONS_GHC -Wall #-}+import Control.Distributed.Process+import Control.Distributed.Process.Closure++import Control.Monad+import Text.Printf+import GHC.Generics (Generic)+import Data.Binary+import Data.Typeable++import DistribUtils++-- <<Message+data Message = Ping (SendPort ProcessId)+ deriving (Typeable, Generic)++instance Binary Message+-- >>++-- <<pingServer+pingServer :: Process ()+pingServer = do+ Ping chan <- expect+ say $ printf "ping received from %s" (show chan)+ mypid <- getSelfPid+ sendChan chan mypid+-- >>++-- <<remotable+remotable ['pingServer]+-- >>++-- <<master+master :: [NodeId] -> Process ()+master peers = do++ ps <- forM peers $ \nid -> do+ say $ printf "spawning on %s" (show nid)+ spawn nid $(mkStaticClosure 'pingServer)++ ports <- forM ps $ \pid -> do+ say $ printf "pinging %s" (show pid)+ (sendport,recvport) <- newChan+ send pid (Ping sendport)+ return recvport++ oneport <- mergePortsBiased ports -- <1>+ waitForPongs oneport ps -- <2>++ say "All pongs successfully received"+ terminate++waitForPongs :: ReceivePort ProcessId -> [ProcessId] -> Process ()+waitForPongs _ [] = return ()+waitForPongs port ps = do+ pid <- receiveChan port+ waitForPongs port (filter (/= pid) ps)+-- >>++-- <<main+main :: IO ()+main = distribMain master Main.__remoteTable+-- >>
+ distrib-ping/ping-tc-notify.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, DeriveGeneric #-}+{-# OPTIONS_GHC -Wall #-}+import Control.Distributed.Process+import Control.Distributed.Process.Closure++import Control.Monad+import Text.Printf+import GHC.Generics (Generic)+import Data.Binary+import Data.Typeable++import DistribUtils++-- <<Message+data Message = Ping (SendPort ProcessId)+ deriving (Typeable, Generic)++instance Binary Message+-- >>++-- <<pingServer+pingServer :: Process ()+pingServer = do+ Ping chan <- expect+ say $ printf "ping received from %s" (show chan)+ mypid <- getSelfPid+ sendChan chan mypid+-- >>++-- <<remotable+remotable ['pingServer]+-- >>++-- <<master+master :: [NodeId] -> Process () -- <1>+master peers = do++ ps <- forM peers $ \nid -> do -- <2>+ say $ printf "spawning on %s" (show nid)+ spawn nid $(mkStaticClosure 'pingServer)++ mapM_ monitor ps++ mypid <- getSelfPid++ ports <- forM ps $ \pid -> do+ say $ printf "pinging %s" (show pid)+ (sendport,recvport) <- newChan+ send pid (Ping sendport)+ return recvport++ let loop [] = return ()+ loop (port:ps) = do+ receiveWait+ [ match $ \(ProcessMonitorNotification ref pid reason) -> do+ say (show pid ++ " died: " ++ show reason)+ loop (port:ps)+ , matchChan port $ \p -> do+ say "pong on channel"+ loop ps+ ]+ loop ports++ say "All pongs successfully received"+ terminate+-- >>++-- <<main+main :: IO ()+main = distribMain master Main.__remoteTable+-- >>
+ distrib-ping/ping-tc.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, DeriveGeneric #-}+{-# OPTIONS_GHC -Wall #-}+import Control.Distributed.Process+import Control.Distributed.Process.Closure++import Control.Monad+import Text.Printf+import GHC.Generics (Generic)+import Data.Binary+import Data.Typeable++import DistribUtils++-- <<Message+data Message = Ping (SendPort ProcessId)+ deriving (Typeable, Generic)++instance Binary Message+-- >>++-- <<pingServer+pingServer :: Process ()+pingServer = do+ Ping chan <- expect+ say $ printf "ping received from %s" (show chan)+ mypid <- getSelfPid+ sendChan chan mypid+-- >>++-- <<remotable+remotable ['pingServer]+-- >>++-- <<master+master :: [NodeId] -> Process ()+master peers = do++ ps <- forM peers $ \nid -> do+ say $ printf "spawning on %s" (show nid)+ spawn nid $(mkStaticClosure 'pingServer)++ mapM_ monitor ps++ ports <- forM ps $ \pid -> do+ say $ printf "pinging %s" (show pid)+ (sendport,recvport) <- newChan -- <1>+ send pid (Ping sendport) -- <2>+ return recvport++ forM_ ports $ \port -> do -- <3>+ _ <- receiveChan port+ return ()++ say "All pongs successfully received"+ terminate+-- >>++-- <<main+main :: IO ()+main = distribMain master Main.__remoteTable+-- >>
+ distrib-ping/ping.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, DeriveGeneric #-}+{-# OPTIONS_GHC -Wall #-}+import Control.Distributed.Process+import Control.Distributed.Process.Closure++import DistribUtils++import Text.Printf+import Data.Binary+import Data.Typeable+import GHC.Generics (Generic)++-- <<Message+data Message = Ping ProcessId+ | Pong ProcessId+ deriving (Typeable, Generic) -- <1>++instance Binary Message -- <2>+-- >>++-- <<pingServer+pingServer :: Process ()+pingServer = do+ Ping from <- expect -- <1>+ say $ printf "ping received from %s" (show from) -- <2>+ mypid <- getSelfPid -- <3>+ send from (Pong mypid) -- <4>+-- >>++-- <<remotable+remotable ['pingServer]+-- >>++-- <<master+master :: Process ()+master = do+ node <- getSelfNode -- <1>++ say $ printf "spawning on %s" (show node)+ pid <- spawn node $(mkStaticClosure 'pingServer) -- <2>++ mypid <- getSelfPid -- <3>+ say $ printf "sending ping to %s" (show pid)+ send pid (Ping mypid) -- <4>++ Pong _ <- expect -- <5>+ say "pong."++ terminate -- <6>+-- >>++-- <<main+main :: IO ()+main = distribMain (\_ -> master) Main.__remoteTable+-- >>
+ findpar.hs view
@@ -0,0 +1,43 @@+import System.Directory+import Control.Concurrent+import System.FilePath+import Control.Concurrent.Async+import System.Environment+import Data.List hiding (find)++main = do+ [s,d] <- getArgs+ find s d >>= print++-- <<find+find :: String -> FilePath -> IO (Maybe FilePath)+find s d = do+ fs <- getDirectoryContents d+ let fs' = sort $ filter (`notElem` [".",".."]) fs+ if any (== s) fs'+ then return (Just (d </> s))+ else do+ let ps = map (d </>) fs' -- <1>+ foldr (subfind s) dowait ps [] -- <2>+ where+ dowait as = loop (reverse as) -- <3>++ loop [] = return Nothing+ loop (a:as) = do -- <4>+ r <- wait a+ case r of+ Nothing -> loop as+ Just a -> return (Just a)+-- >>++-- <<subfind+subfind :: String -> FilePath+ -> ([Async (Maybe FilePath)] -> IO (Maybe FilePath))+ -> [Async (Maybe FilePath)] -> IO (Maybe FilePath)++subfind s p inner asyncs = do+ isdir <- doesDirectoryExist p+ if not isdir+ then inner asyncs+ else withAsync (find s p) $ \a -> inner (a:asyncs)+-- >>
+ findpar2.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE BangPatterns #-}+import System.Directory+import System.FilePath+import Control.Concurrent.Async+import System.Environment+import Data.List hiding (find)+import Control.Exception (finally)+import Data.Maybe (isJust)+import Control.Concurrent.MVar+import Data.IORef+import GHC.Conc (getNumCapabilities)++-- <<main+main = do+ [n,s,d] <- getArgs+ sem <- newNBSem (read n)+ find sem s d >>= print+-- >>++-- <<find+find :: NBSem -> String -> FilePath -> IO (Maybe FilePath)+find sem s d = do+ fs <- getDirectoryContents d+ let fs' = sort $ filter (`notElem` [".",".."]) fs+ if any (== s) fs'+ then return (Just (d </> s))+ else do+ let ps = map (d </>) fs' -- <1>+ foldr (subfind sem s) dowait ps [] -- <2>+ where+ dowait as = loop (reverse as) -- <3>++ loop [] = return Nothing+ loop (a:as) = do -- <4>+ r <- wait a -- <5>+ case r of+ Nothing -> loop as -- <6>+ Just a -> return (Just a) -- <7>+-- >>++-- <<subfind+subfind :: NBSem -> String -> FilePath+ -> ([Async (Maybe FilePath)] -> IO (Maybe FilePath))+ -> [Async (Maybe FilePath)] -> IO (Maybe FilePath)++subfind sem s p inner asyncs = do+ isdir <- doesDirectoryExist p+ if not isdir+ then inner asyncs+ else do+ q <- tryAcquireNBSem sem -- <1>+ if q+ then do+ let dofind = find sem s p `finally` releaseNBSem sem -- <2>+ withAsync dofind $ \a -> inner (a:asyncs)+ else do+ r <- find sem s p -- <3>+ case r of+ Nothing -> inner asyncs+ Just _ -> return r+-- >>++-- <<NBSem+newtype NBSem = NBSem (MVar Int)++newNBSem :: Int -> IO NBSem+newNBSem i = do+ m <- newMVar i+ return (NBSem m)++tryAcquireNBSem :: NBSem -> IO Bool+tryAcquireNBSem (NBSem m) =+ modifyMVar m $ \i ->+ if i == 0+ then return (i, False)+ else let !z = i-1 in return (z, True)++releaseNBSem :: NBSem -> IO ()+releaseNBSem (NBSem m) =+ modifyMVar m $ \i ->+ let !z = i+1 in return (z, ())+-- >>
+ findpar3.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE BangPatterns,CPP #-}+import System.Directory+import System.FilePath+import Control.Concurrent.Async+import System.Environment+import Data.List hiding (find)+import Control.Exception (finally)+import Data.Maybe (isJust)+import Control.Concurrent.MVar+import Control.Concurrent.STM+import Data.IORef+import GHC.Conc (getNumCapabilities)+import CasIORef++-- <<main+main = do+ [s,d] <- getArgs+ n <- getNumCapabilities+ sem <- newNBSem (if n == 1 then 0 else n * 4)+ find sem s d >>= print+-- >>++-- <<find+find :: NBSem -> String -> FilePath -> IO (Maybe FilePath)+find sem s d = do+ fs <- getDirectoryContents d+ let fs' = sort $ filter (`notElem` [".",".."]) fs+ if any (== s) fs'+ then return (Just (d </> s))+ else do+ let ps = map (d </>) fs' -- <1>+ foldr (subfind sem s) dowait ps [] -- <2>+ where+ dowait as = loop (reverse as) -- <3>++ loop [] = return Nothing+ loop (a:as) = do -- <4>+ r <- wait a -- <5>+ case r of+ Nothing -> loop as -- <6>+ Just a -> return (Just a) -- <7>+-- >>++-- <<subfind+subfind :: NBSem -> String -> FilePath+ -> ([Async (Maybe FilePath)] -> IO (Maybe FilePath))+ -> [Async (Maybe FilePath)] -> IO (Maybe FilePath)++subfind sem s p inner asyncs = do+ isdir <- doesDirectoryExist p+ if isdir+ then do+ q <- tryWaitNBSem sem+ if q+ then withAsync (find sem s p `finally` signalNBSem sem) $ \a ->+ inner (a:asyncs)+ else do r <- find sem s p+ if isJust r then return r else inner asyncs+ else inner asyncs+-- >>++-- <<NBSem+newtype NBSem = NBSem (IORef Int)++newNBSem :: Int -> IO NBSem+newNBSem i = do+ m <- newIORef i+ return (NBSem m)++tryWaitNBSem :: NBSem -> IO Bool+tryWaitNBSem (NBSem m) = do+ atomicModifyIORef m $ \i ->+ if i == 0+ then (i, False)+ else let !z = i-1 in (z, True)++signalNBSem :: NBSem -> IO ()+signalNBSem (NBSem m) =+ atomicModifyIORef m $ \i ->+ let !z = i+1 in (z, ())+-- >>
+ findpar4.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+import System.Directory+import Control.Concurrent+import System.FilePath+import System.Environment+import Data.List hiding (find)+import GHC.Conc (getNumCapabilities)+import Text.Printf++import Control.Monad.Par.IO+import Control.Monad.Par.Class+import Control.Monad.IO.Class++import Control.Exception++-- <<main+main = do+ [s,d] <- getArgs+ runParIO (find s d) >>= print+-- >>++-- <<find+find :: String -> FilePath -> ParIO (Maybe FilePath)+find s d = do+ fs <- liftIO $ getDirectoryContents d+ let fs' = sort $ filter (`notElem` [".",".."]) fs+ if any (== s) fs'+ then return (Just (d </> s))+ else do+ let ps = map (d </>) fs'+ foldr (subfind s) dowait ps []+ where+ dowait vs = loop (reverse vs)++ loop [] = return Nothing+ loop (v:vs) = do+ r <- get v+ case r of+ Nothing -> loop vs+ Just a -> return (Just a)+-- >>++-- <<subfind+subfind :: String -> FilePath+ -> ([IVar (Maybe FilePath)] -> ParIO (Maybe FilePath))+ -> [IVar (Maybe FilePath)] -> ParIO (Maybe FilePath)++subfind s p inner ivars = do+ isdir <- liftIO $ doesDirectoryExist p+ if not isdir+ then inner ivars+ else do v <- new -- <1>+ fork (find s p >>= put v) -- <2>+ inner (v : ivars) -- <3>+-- >>
+ findseq.hs view
@@ -0,0 +1,34 @@+{-# OPTIONS_GHC -Wall #-}+import System.Directory+import System.FilePath+import System.Environment+import Data.List hiding (find)++-- <<main+main :: IO ()+main = do+ [s,d] <- getArgs+ r <- find s d+ print r+-- >>++-- <<find+find :: String -> FilePath -> IO (Maybe FilePath)+find s d = do+ fs <- getDirectoryContents d -- <1>+ let fs' = sort $ filter (`notElem` [".",".."]) fs -- <2>+ if any (== s) fs' -- <3>+ then return (Just (d </> s))+ else loop fs' -- <4>+ where+ loop [] = return Nothing -- <5>+ loop (f:fs) = do+ let d' = d </> f -- <6>+ isdir <- doesDirectoryExist d' -- <7>+ if isdir+ then do r <- find s d' -- <8>+ case r of+ Just _ -> return r -- <9>+ Nothing -> loop fs -- <10>+ else loop fs -- <11>+-- >>
+ fork.hs view
@@ -0,0 +1,10 @@+-- <<fork+import Control.Concurrent+import Control.Monad+import System.IO++main = do+ hSetBuffering stdout NoBuffering -- <1>+ forkIO (replicateM_ 100000 (putChar 'A')) -- <2>+ replicateM_ 100000 (putChar 'B') -- <3>+-- >>
+ fwaccel.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE CPP, BangPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}++module Main ( main, test {-, maxDistances -} ) where++import Prelude+import System.Environment+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Interpreter++-- <<Graph+type Weight = Int32+type Graph = Array DIM2 Weight+-- >>++-- -----------------------------------------------------------------------------+-- shortestPaths++-- <<shortestPaths+shortestPaths :: Graph -> Graph+shortestPaths g0 = run (shortestPathsAcc n (use g0))+ where+ Z :. _ :. n = arrayShape g0+-- >>++-- <<shortestPathsAcc+shortestPathsAcc :: Int -> Acc Graph -> Acc Graph+shortestPathsAcc n g0 = foldl1 (>->) steps g0 -- <3>+ where+ steps :: [ Acc Graph -> Acc Graph ] -- <1>+ steps = [ step (unit (constant k)) | k <- [0 .. n-1] ] -- <2>+-- >>++-- <<step+step :: Acc (Scalar Int) -> Acc Graph -> Acc Graph+step k g = generate (shape g) sp -- <1>+ where+ k' = the k -- <2>++ sp :: Exp DIM2 -> Exp Weight+ sp ix = let+ (Z :. i :. j) = unlift ix -- <3>+ in+ A.min (g ! (index2 i j)) -- <4>+ (g ! (index2 i k') + g ! (index2 k' j))+-- >>++-- -----------------------------------------------------------------------------+-- Testing++-- <<inf+inf :: Weight+inf = 999+-- >>++testGraph :: Graph+testGraph = toAdjMatrix $+ [[ 0, inf, inf, 13, inf, inf],+ [inf, 0, inf, inf, 4, 9],+ [ 11, inf, 0, inf, inf, inf],+ [inf, 3, inf, 0, inf, 7],+ [ 15, 5, inf, 1, 0, inf],+ [ 11, inf, inf, 14, inf, 0]]++-- correct result:+expectedResult :: Graph+expectedResult = toAdjMatrix $+ [[0, 16, inf, 13, 20, 20],+ [19, 0, inf, 5, 4, 9],+ [11, 27, 0, 24, 31, 31],+ [18, 3, inf, 0, 7, 7],+ [15, 4, inf, 1, 0, 8],+ [11, 17, inf, 14, 21, 0] ]++test :: Bool+test = toList (shortestPaths testGraph) == toList expectedResult++toAdjMatrix :: [[Weight]] -> Graph+toAdjMatrix xs = A.fromList (Z :. k :. k) (concat xs)+ where k = length xs+++main :: IO ()+main = do+ (n:_) <- fmap (fmap read) getArgs+ print (run (let g :: Acc Graph+ g = generate (constant (Z:.n:.n) :: Exp DIM2) f++ f :: Exp DIM2 -> Exp Weight+ f ix = let i,j :: Exp Int+ Z:.i:.j = unlift ix+ in+ A.fromIntegral j ++ A.fromIntegral i * constant (Prelude.fromIntegral n)+ in+ A.foldAll (+) (constant 0) (shortestPathsAcc n g)))
+ fwdense.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE CPP, BangPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}++module Main ( main, test, maxDistances ) where++import System.Environment+import Data.Array.Repa++-- <<Graph+type Weight = Int+type Graph r = Array r DIM2 Weight+-- >>++-- -----------------------------------------------------------------------------+-- shortestPaths++-- <<shortestPaths+shortestPaths :: Graph U -> Graph U+shortestPaths g0 = go g0 0 -- <2>+ where+ Z :. _ :. n = extent g0 -- <1>++ go !g !k | k == n = g -- <3>+ | otherwise =+ let g' = computeS (fromFunction (Z:.n:.n) sp) -- <4>+ in go g' (k+1) -- <5>+ where+ sp (Z:.i:.j) = min (g ! (Z:.i:.j)) (g ! (Z:.i:.k) + g ! (Z:.k:.j)) -- <6>+-- >>++-- -----------------------------------------------------------------------------++-- <<maxDistance+maxDistance :: Weight -> Weight -> Weight+maxDistance x y+ | x == inf = y+ | y == inf = x+ | otherwise = max x y+-- >>++maxDistances :: Graph U -> Array U DIM1 Weight+maxDistances = foldS maxDistance inf++-- -----------------------------------------------------------------------------+-- Testing++-- <<inf+inf :: Weight+inf = 999+-- >>++testGraph :: Graph U+testGraph = toAdjMatrix $+ [[ 0, inf, inf, 13, inf, inf],+ [inf, 0, inf, inf, 4, 9],+ [ 11, inf, 0, inf, inf, inf],+ [inf, 3, inf, 0, inf, 7],+ [ 15, 5, inf, 1, 0, inf],+ [ 11, inf, inf, 14, inf, 0]]++-- correct result:+expectedResult :: Graph U+expectedResult = toAdjMatrix $+ [[0, 16, inf, 13, 20, 20],+ [19, 0, inf, 5, 4, 9],+ [11, 27, 0, 24, 31, 31],+ [18, 3, inf, 0, 7, 7],+ [15, 4, inf, 1, 0, 8],+ [11, 17, inf, 14, 21, 0] ]++test :: Bool+test = shortestPaths testGraph == expectedResult++toAdjMatrix :: [[Weight]] -> Graph U+toAdjMatrix xs = fromListUnboxed (Z :. k :. k) (concat xs)+ where k = length xs++main :: IO ()+main = do+ [n] <- fmap (fmap read) getArgs+ let g = fromListUnboxed (Z:.n:.n) [0..n^(2::Int)-1] :: Graph U+ print (sumAllS (shortestPaths g))+
+ fwdense1.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP, BangPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}++module Main ( main, test ) where++import System.Environment+import Data.Array.Repa+import Data.Functor.Identity++-- <<Graph+type Weight = Int+type Graph r = Array r DIM2 Weight+-- >>++-- -----------------------------------------------------------------------------+-- shortestPaths++-- <<shortestPaths+shortestPaths :: Graph U -> Graph U+shortestPaths g0 = runIdentity $ go g0 0 -- <1>+ where+ Z :. _ :. n = extent g0++ go !g !k | k == n = return g -- <2>+ | otherwise = do+ g' <- computeP (fromFunction (Z:.n:.n) sp) -- <3>+ go g' (k+1)+ where+ sp (Z:.i:.j) = min (g ! (Z:.i:.j)) (g ! (Z:.i:.k) + g ! (Z:.k:.j))+-- >>++-- -----------------------------------------------------------------------------+-- Testing++input :: [[Int]]+input = [[ 0, 999, 999, 13, 999, 999],+ [999, 0, 999, 999, 4, 9],+ [ 11, 999, 0, 999, 999, 999],+ [999, 3, 999, 0, 999, 7],+ [ 15, 5, 999, 1, 0, 999],+ [ 11, 999, 999, 14, 999, 0]]++-- correct result:+result :: [[Int]]+result = [[0, 16, 999, 13, 20, 20],+ [19, 0, 999, 5, 4, 9],+ [11, 27, 0, 24, 31, 31],+ [18, 3, 999, 0, 7, 7],+ [15, 4, 999, 1, 0, 8],+ [11, 17, 999, 14, 21, 0] ]++test :: Bool+test = fromAdjMatrix (shortestPaths (toAdjMatrix input)) == result++toAdjMatrix :: [[Int]] -> Graph U+toAdjMatrix xs = fromListUnboxed (Z :. k :. k) (concat xs)+ where k = length xs++fromAdjMatrix :: Graph U -> [[Int]]+fromAdjMatrix m = chunk k (toList m)+ where+ (Z :. _ :. k) = extent m++chunk :: Int -> [a] -> [[a]]+chunk _ [] = []+chunk n xs = as : chunk n bs+ where (as,bs) = splitAt n xs++main :: IO ()+main = do+ [n] <- fmap (fmap read) getArgs+ let g = fromListUnboxed (Z:.n:.n) [1..n^(2::Int)] :: Graph U+ print (sumAllS (shortestPaths g))+
+ fwsparse/MapCompat.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE CPP #-}++module MapCompat (module MapCompat, module Map) where++#if !MIN_VERSION_containers(0,5,0)++import Data.IntMap as Map+import Control.Applicative+import Data.Traversable++traverseWithKey :: Applicative f => (Int -> a -> f b) -> IntMap a -> f (IntMap b)+traverseWithKey f m =+ Map.fromList `fmap` traverse (\(k,v) -> (,) <$> pure k <*> f k v) (Map.toList m)++#else++import Data.IntMap.Strict as Map++#endif
+ fwsparse/SparseGraph.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE CPP #-}+module SparseGraph (+ Vertex, Weight,+ Graph,+ weight, insertEdge,+ randomGraph,+ mkGraph,+ toAdjMatrix,+ fromAdjMatrix,+ checksum+ ) where++#if MIN_VERSION_containers(0,5,0)+import qualified Data.IntMap.Strict as Map+#else+import qualified Data.IntMap as Map+#endif+import qualified Data.IntSet as IntSet+import Data.IntMap (IntMap)+import System.Random+import Data.Array.Unboxed++-- -----------------------------------------------------------------------------+-- Graph representation++-- <<Graph+type Vertex = Int+type Weight = Int++type Graph = IntMap (IntMap Weight)++weight :: Graph -> Vertex -> Vertex -> Maybe Weight+weight g i j = do+ jmap <- Map.lookup i g+ Map.lookup j jmap+-- >>++insertEdge :: Vertex -> Vertex -> Weight -> Graph -> Graph+insertEdge i j w m = Map.insertWith Map.union i (Map.singleton j w) m++-- -----------------------------------------------------------------------------+-- Testing++randomGraph :: StdGen -> Int -> Int -> Int -> (Graph, [Vertex])+randomGraph g max_vertex max_weight edges = (mat, vs)+ where+ (g1,g2) = split g+ (g3,g4) = split g2+ is = take edges $ randomRs (0,max_vertex) g1+ js = take edges $ randomRs (0,max_vertex) g3+ ws = take edges $ randomRs (1,max_weight) g4++ mat = foldr ins Map.empty (zip3 is js ws)+ where ins (i,j,w) = insertEdge i j w++ vs = IntSet.elems (IntSet.fromList (is ++ js))++mkGraph :: [[Int]] -> Graph+mkGraph xss = Map.fromList (zipWith row [0..] xss)+ where+ row i xs = (i, Map.fromList [ (j, w) | (j,w) <- zip [0..] xs, w /= 100 ])++type AdjMatrix = UArray (Int,Int) Weight++toAdjMatrix :: Int -> Graph -> AdjMatrix+toAdjMatrix k m = accumArray (\_ e -> e) 999 ((0,0),(k,k))+ [ ((i,j),w) | (i,jmap) <- Map.toList m, (j,w) <- Map.toList jmap ]++fromAdjMatrix :: AdjMatrix -> [[Int]]+fromAdjMatrix m = chunk (k+1) (elems m)+ where+ (_, (k,_)) = bounds m++chunk :: Int -> [a] -> [[a]]+chunk _ [] = []+chunk n xs = as : chunk n bs+ where (as,bs) = splitAt n xs++checksum :: Graph -> Int+checksum m = sum (concat (map Map.elems (Map.elems m)))++
+ fwsparse/fwsparse.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}++module Main ( main, runtest ) where++import System.Environment+import qualified MapCompat as Map+import MapCompat (IntMap)+import System.Random+import Data.List+import SparseGraph++-- -----------------------------------------------------------------------------+-- shortestPaths++-- <<shortestPaths+shortestPaths :: [Vertex] -> Graph -> Graph+shortestPaths vs g = foldl' update g vs -- <1>+ where+ update g k = Map.mapWithKey shortmap g -- <2>+ where+ shortmap :: Vertex -> IntMap Weight -> IntMap Weight+ shortmap i jmap = foldr shortest Map.empty vs -- <3>+ where shortest j m =+ case (old,new) of -- <6>+ (Nothing, Nothing) -> m+ (Nothing, Just w ) -> Map.insert j w m+ (Just w, Nothing) -> Map.insert j w m+ (Just w1, Just w2) -> Map.insert j (min w1 w2) m+ where+ old = Map.lookup j jmap -- <4>+ new = do w1 <- weight g i k -- <5>+ w2 <- weight g k j+ return (w1+w2)+-- >>++-- -----------------------------------------------------------------------------+-- Testing++test :: [[Int]]+test = [[ 0, 999, 999, 13, 999, 999],+ [999, 0, 999, 999, 4, 9],+ [ 11, 999, 0, 999, 999, 999],+ [999, 3, 999, 0, 999, 7],+ [ 15, 5, 999, 1, 0, 999],+ [ 11, 999, 999, 14, 999, 0]]++-- correct result:+-- [ [0, 16, 999, 13, 20, 20],+-- [19, 0, 999, 5, 4, 9],+-- [11, 27, 0, 24, 31, 31],+-- [18, 3, 999, 0, 7, 7],+-- [15, 4, 999, 1, 0, 8],+-- [11, 17, 999, 14, 21, 0] ]++runtest :: [[Int]]+runtest = fromAdjMatrix (toAdjMatrix 5 (shortestPaths [0..5] (mkGraph test)))++main :: IO ()+main = do+ [h,n] <- fmap (fmap read) getArgs+ let g = mkStdGen 9999+ let (mat,vs) = randomGraph g h 100 n+ print (checksum (shortestPaths vs mat))
+ fwsparse/fwsparse1.hs view
@@ -0,0 +1,70 @@+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}++module Main ( main, runtest ) where++import Control.Monad.Par.Scheds.Trace+ -- gives slightly better results than Control.Monad.Par with monad-par-0.3.4+import System.Environment+import qualified MapCompat as Map+import MapCompat (IntMap)+import System.Random+import Data.List+import Data.Traversable hiding (mapM)++import SparseGraph++-- -----------------------------------------------------------------------------+-- shortestPaths++shortestPaths :: [Vertex] -> Graph -> Graph+shortestPaths vs g = foldl' update g vs+ where+-- <<update+ update g k = runPar $ do+ m <- Map.traverseWithKey (\i jmap -> spawn (return (shortmap i jmap))) g+ traverse get m+-- >>+ where+ shortmap :: Vertex -> IntMap Weight -> IntMap Weight+ shortmap i jmap = foldr shortest Map.empty vs+ where shortest j m =+ case (old,new) of+ (Nothing, Nothing) -> m+ (Nothing, Just w ) -> Map.insert j w m+ (Just w, Nothing) -> Map.insert j w m+ (Just w1, Just w2) -> Map.insert j (min w1 w2) m+ where+ old = Map.lookup j jmap+ new = do w1 <- weight g i k+ w2 <- weight g k j+ return (w1+w2)++-- -----------------------------------------------------------------------------+-- Testing++test :: [[Int]]+test = [[ 0, 999, 999, 13, 999, 999],+ [999, 0, 999, 999, 4, 9],+ [ 11, 999, 0, 999, 999, 999],+ [999, 3, 999, 0, 999, 7],+ [ 15, 5, 999, 1, 0, 999],+ [ 11, 999, 999, 14, 999, 0]]++-- correct result:+-- [ [0, 16, 999, 13, 20, 20],+-- [19, 0, 999, 5, 4, 9],+-- [11, 27, 0, 24, 31, 31],+-- [18, 3, 999, 0, 7, 7],+-- [15, 4, 999, 1, 0, 8],+-- [11, 17, 999, 14, 21, 0] ]++runtest :: [[Int]]+runtest = fromAdjMatrix (toAdjMatrix 5 (shortestPaths [0..5] (mkGraph test)))++main :: IO ()+main = do+ [h,n] <- fmap (fmap read) getArgs+ let g = mkStdGen 9999+ let (mat,vs) = randomGraph g h 100 n+ print (checksum (shortestPaths vs mat))+
+ geturls1.hs view
@@ -0,0 +1,21 @@+-- <<geturls+import Control.Concurrent+import Data.ByteString as B+import GetURL++main = do+ m1 <- newEmptyMVar -- <1>+ m2 <- newEmptyMVar -- <1>++ forkIO $ do -- <2>+ r <- getURL "http://www.wikipedia.org/wiki/Shovel"+ putMVar m1 r++ forkIO $ do -- <3>+ r <- getURL "http://www.wikipedia.org/wiki/Spade"+ putMVar m2 r++ r1 <- takeMVar m1 -- <4>+ r2 <- takeMVar m2 -- <5>+ print (B.length r1, B.length r2) -- <6>+-- >>
+ geturls2.hs view
@@ -0,0 +1,31 @@+import GetURL++import Control.Concurrent+import qualified Data.ByteString as B++-----------------------------------------------------------------------------+-- Our Async API:++-- <<async+data Async a = Async (MVar a)++async :: IO a -> IO (Async a)+async action = do+ var <- newEmptyMVar+ forkIO (do r <- action; putMVar var r)+ return (Async var)++wait :: Async a -> IO a+wait (Async var) = readMVar var+-- >>++-----------------------------------------------------------------------------++-- <<main+main = do+ a1 <- async (getURL "http://www.wikipedia.org/wiki/Shovel")+ a2 <- async (getURL "http://www.wikipedia.org/wiki/Spade")+ r1 <- wait a1+ r2 <- wait a2+ print (B.length r1, B.length r2)+-- >>
+ geturls3.hs view
@@ -0,0 +1,50 @@+-- (c) Simon Marlow 2011, see the file LICENSE for copying terms.+--+-- Sample geturls.hs (CEFP summer school notes, 2011)+--+-- Downloading multiple URLs concurrently, timing the downloads+--+-- Compile with:+-- ghc -threaded --make geturls.hs++import GetURL+import TimeIt++import Control.Concurrent+import Text.Printf+import qualified Data.ByteString as B++-----------------------------------------------------------------------------+-- Our Async API:++-- <<async+data Async a = Async (MVar a)++async :: IO a -> IO (Async a)+async action = do+ var <- newEmptyMVar+ forkIO (do r <- action; putMVar var r)+ return (Async var)++wait :: Async a -> IO a+wait (Async var) = readMVar var+-- >>++-----------------------------------------------------------------------------++-- <<main+sites = ["http://www.google.com",+ "http://www.bing.com",+ "http://www.yahoo.com",+ "http://www.wikipedia.com/wiki/Spade",+ "http://www.wikipedia.com/wiki/Shovel"]++timeDownload :: String -> IO ()+timeDownload url = do+ (page, time) <- timeit $ getURL url -- <1>+ printf "downloaded: %s (%d bytes, %.2fs)\n" url (B.length page) time++main = do+ as <- mapM (async . timeDownload) sites -- <2>+ mapM_ wait as -- <3>+-- >>
+ geturls4.hs view
@@ -0,0 +1,39 @@+import GetURL++import Control.Concurrent+import Control.Exception+import qualified Data.ByteString as B++-----------------------------------------------------------------------------+-- Our Async API:++-- <<async+data Async a = Async (MVar (Either SomeException a)) -- <1>++async :: IO a -> IO (Async a)+async action = do+ var <- newEmptyMVar+ forkIO (do r <- try action; putMVar var r) -- <2>+ return (Async var)++waitCatch :: Async a -> IO (Either SomeException a) -- <3>+waitCatch (Async var) = readMVar var++wait :: Async a -> IO a -- <4>+wait a = do+ r <- waitCatch a+ case r of+ Left e -> throwIO e+ Right a -> return a+-- >>++-----------------------------------------------------------------------------++-- <<main+main = do+ a1 <- async (getURL "http://www.wikipedia.org/wiki/Shovel")+ a2 <- async (getURL "http://www.wikipedia.org/wiki/Spade")+ r1 <- wait a1+ r2 <- wait a2+ print (B.length r1, B.length r2)+-- >>
+ geturls5.hs view
@@ -0,0 +1,28 @@+import Control.Concurrent+import GetURL+import qualified Data.ByteString as B+import Text.Printf+import Control.Monad++-- <<main+sites = ["http://www.google.com",+ "http://www.bing.com",+ "http://www.yahoo.com",+ "http://www.wikipedia.com/wiki/Spade",+ "http://www.wikipedia.com/wiki/Shovel"]++main :: IO ()+main = do+ m <- newEmptyMVar+ let+ download url = do+ r <- getURL url+ putMVar m (url, r)++ mapM_ (forkIO . download) sites++ (url, r) <- takeMVar m+ printf "%s was first (%d bytes)\n" url (B.length r)+ replicateM_ (length sites - 1) (takeMVar m)+-- >>+
+ geturls6.hs view
@@ -0,0 +1,70 @@+import GetURL+import TimeIt++import Control.Monad+import Control.Concurrent+import Control.Exception+import Text.Printf+import qualified Data.ByteString as B++-----------------------------------------------------------------------------+-- Our Async API:++data Async a = Async (MVar (Either SomeException a))++async :: IO a -> IO (Async a)+async action = do+ var <- newEmptyMVar+ forkIO (do r <- try action; putMVar var r) -- <1>+ return (Async var)++waitCatch :: Async a -> IO (Either SomeException a) -- <2>+waitCatch (Async var) = readMVar var++wait :: Async a -> IO a -- <3>+wait a = do+ r <- waitCatch a+ case r of+ Left e -> throwIO e+ Right a -> return a++-- <<waitEither+waitEither :: Async a -> Async b -> IO (Either a b)+waitEither a b = do+ m <- newEmptyMVar+ forkIO $ do r <- try (fmap Left (wait a)); putMVar m r+ forkIO $ do r <- try (fmap Right (wait b)); putMVar m r+ wait (Async m)+-- >>++-- <<waitAny+waitAny :: [Async a] -> IO a+waitAny as = do+ m <- newEmptyMVar+ let forkwait a = forkIO $ do r <- try (wait a); putMVar m r+ mapM_ forkwait as+ wait (Async m)+-- >>++-----------------------------------------------------------------------------++sites = ["http://www.google.com",+ "http://www.bing.com",+ "http://www.yahoo.com",+ "http://www.wikipedia.com/wiki/Spade",+ "http://www.wikipedia.com/wiki/Shovel"]++-- <<main+main :: IO ()+main = do+ let+ download url = do+ r <- getURL url+ return (url, r)++ as <- mapM (async . download) sites++ (url, r) <- waitAny as+ printf "%s was first (%d bytes)\n" url (B.length r)+ mapM_ wait as+-- >>
+ geturls7.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE CPP #-}++import GetURL++import Control.Concurrent+#if __GLASGOW_HASKELL__ < 706+import ConcurrentUtils (forkFinally)+#endif+import Control.Exception+import qualified Data.ByteString as B+import Control.Concurrent.STM++-----------------------------------------------------------------------------+-- Our Async API:++-- <<Async+data Async a = Async ThreadId (TMVar (Either SomeException a))+-- >>++-- <<async+async :: IO a -> IO (Async a)+async action = do+ var <- newEmptyTMVarIO+ t <- forkFinally action (atomically . putTMVar var)+ return (Async t var)+-- >>++--- <<watchCatch+waitCatch :: Async a -> IO (Either SomeException a)+waitCatch = atomically . waitCatchSTM+-- >>++-- <<waitCatchSTM+waitCatchSTM :: Async a -> STM (Either SomeException a)+waitCatchSTM (Async _ var) = readTMVar var+-- >>++-- <<waitSTM+waitSTM :: Async a -> STM a+waitSTM a = do+ r <- waitCatchSTM a+ case r of+ Left e -> throwSTM e+ Right a -> return a+-- >>++-- <<wait+wait :: Async a -> IO a+wait = atomically . waitSTM+-- >>++-- <<cancel+cancel :: Async a -> IO ()+cancel (Async t _) = throwTo t ThreadKilled+-- >>++-- <<waitEither+waitEither :: Async a -> Async b -> IO (Either a b)+waitEither a b = atomically $+ fmap Left (waitSTM a)+ `orElse`+ fmap Right (waitSTM b)+-- >>++-- <<waitAny+waitAny :: [Async a] -> IO a+waitAny asyncs =+ atomically $ foldr orElse retry $ map waitSTM asyncs+-- >>++-- <<withAsync+withAsync :: IO a -> (Async a -> IO b) -> IO b+withAsync io operation = bracket (async io) cancel operation+-- >>++-----------------------------------------------------------------------------++-- <<main+main =+ withAsync (getURL "http://www.wikipedia.org/wiki/Shovel") $ \a1 ->+ withAsync (getURL "http://www.wikipedia.org/wiki/Spade") $ \a2 -> do+ r1 <- wait a1+ r2 <- wait a2+ print (B.length r1, B.length r2)+-- >>
+ geturls8.hs view
@@ -0,0 +1,15 @@+import GetURL++import Async++import qualified Data.ByteString as B++-----------------------------------------------------------------------------++-- <<main+main = do+ (r1,r2) <- concurrently+ (getURL "http://www.wikipedia.org/wiki/Shovel")+ (getURL "http://www.wikipedia.org/wiki/Spade")+ print (B.length r1, B.length r2)+-- >>
+ geturls9.hs view
@@ -0,0 +1,23 @@+import GetURL++import Async++import qualified Data.ByteString as B++-----------------------------------------------------------------------------++sites = ["http://www.google.com",+ "http://www.bing.com",+ "http://www.yahoo.com",+ "http://www.wikipedia.com/wiki/Spade",+ "http://www.wikipedia.com/wiki/Shovel"]++-- <<main+main = do+ xs <- foldr conc (return []) (map getURL sites)+ print (map B.length xs)+ where+ conc ioa ioas = do+ (a,as) <- concurrently ioa ioas+ return (a:as)+-- >>
+ geturlscancel.hs view
@@ -0,0 +1,74 @@+-- (c) Simon Marlow 2011, see the file LICENSE for copying terms.+--+-- Sample geturls.hs (CEFP summer school notes, 2011)+--+-- Downloading multiple URLs concurrently, timing the downloads,+-- and the user may press 'q' to stop the downloads at any time.+--+-- Compile with:+-- ghc -threaded --make geturlscancel.hs++import GetURL+import TimeIt++import Data.Either+import System.IO+import Control.Monad+import Control.Concurrent+import Control.Exception+import Text.Printf+import qualified Data.ByteString as B+import Prelude hiding (catch)++-----------------------------------------------------------------------------+-- Our Async API:++-- <<Async+data Async a = Async ThreadId (MVar (Either SomeException a))+-- >>++-- <<async+async :: IO a -> IO (Async a)+async action = do+ m <- newEmptyMVar+ t <- forkIO (do r <- try action; putMVar m r)+ return (Async t m)+-- >>++-- <<waitCatch+waitCatch :: Async a -> IO (Either SomeException a)+waitCatch (Async _ var) = readMVar var+-- >>++-- <<cancel+cancel :: Async a -> IO ()+cancel (Async t var) = throwTo t ThreadKilled+-- >>++-----------------------------------------------------------------------------++sites = ["http://www.google.com",+ "http://www.bing.com",+ "http://www.yahoo.com",+ "http://www.wikipedia.com/wiki/Spade",+ "http://www.wikipedia.com/wiki/Shovel"]++timeDownload :: String -> IO ()+timeDownload url = do+ (page, time) <- timeit $ getURL url+ printf "downloaded: %s (%d bytes, %.2fs)\n" url (B.length page) time++-- <<main+main = do+ as <- mapM (async . timeDownload) sites -- <1>++ forkIO $ do -- <2>+ hSetBuffering stdin NoBuffering+ forever $ do+ c <- getChar+ when (c == 'q') $ mapM_ cancel as++ rs <- mapM waitCatch as -- <3>+ printf "%d/%d succeeded\n" (length (rights rs)) (length rs) -- <4>+-- >>+
+ geturlscancel2.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE DeriveDataTypeable, CPP #-}+-- (c) Simon Marlow 2011, see the file LICENSE for copying terms.+--+-- Sample geturls.hs (CEFP summer school notes, 2011)+--+-- Downloading multiple URLs concurrently, timing the downloads,+-- and the user may press 'q' to stop the downloads at any time.+--+-- Compile with:+-- ghc -threaded --make geturlscancel.hs++import GetURL+import TimeIt++import Data.Either+import System.IO+import Control.Monad+#if __GLASGOW_HASKELL__ < 706+import Control.Concurrent+#else+-- forkFinally was added in GHC 7.6+import Control.Concurrent hiding (forkFinally)+#endif+import Control.Exception+import Text.Printf+import qualified Data.ByteString as B+import Data.Typeable+import Prelude hiding (catch)++-----------------------------------------------------------------------------+-- Our Async API:++-- <<Async+data Async a = Async ThreadId (MVar (Either SomeException a))+-- >>++-- <<forkFinally+forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId+forkFinally action fun =+ mask $ \restore ->+ forkIO (do r <- try (restore action); fun r)+-- >>++-- <<async+async :: IO a -> IO (Async a)+async action = do+ m <- newEmptyMVar+ t <- forkFinally action (putMVar m)+ return (Async t m)+-- >>++-- <<waitCatch+waitCatch :: Async a -> IO (Either SomeException a)+waitCatch (Async _ var) = readMVar var+-- >>++-- <<cancel+cancel :: Async a -> IO ()+cancel (Async t var) = throwTo t ThreadKilled+-- >>++-----------------------------------------------------------------------------++sites = ["http://www.google.com",+ "http://www.bing.com",+ "http://www.yahoo.com",+ "http://www.wikipedia.com/wiki/Spade",+ "http://www.wikipedia.com/wiki/Shovel"]++timeDownload :: String -> IO ()+timeDownload url = do+ (page, time) <- timeit $ getURL url+ printf "downloaded: %s (%d bytes, %.2fs)\n" url (B.length page) time++-- <<main+main = do+ as <- mapM (async . timeDownload) sites -- <1>++ forkIO $ do -- <2>+ hSetBuffering stdin NoBuffering+ forever $ do+ c <- getChar+ when (c == 'q') $ mapM_ cancel as++ rs <- mapM waitCatch as -- <3>+ printf "%d/%d succeeded\n" (length (rights rs)) (length rs) -- <4>+-- >>+
+ geturlsfirst.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE CPP #-}+-- STM Async API used in \secref{stm-async}++module Main where++import GetURL++#if __GLASGOW_HASKELL__ < 706+import ConcurrentUtils (forkFinally)+#endif+import Control.Concurrent+import Control.Exception+import Control.Concurrent.STM+import Text.Printf+import qualified Data.ByteString as B++-- -----------------------------------------------------------------------------+-- STM Async API++-- <<Async+data Async a = Async ThreadId (TMVar (Either SomeException a))+-- >>++-- <<async+async :: IO a -> IO (Async a)+async action = do+ var <- newEmptyTMVarIO+ t <- forkFinally action (atomically . putTMVar var)+ return (Async t var)+-- >>++--- <<watchCatch+waitCatch :: Async a -> IO (Either SomeException a)+waitCatch = atomically . waitCatchSTM+-- >>++-- <<waitCatchSTM+waitCatchSTM :: Async a -> STM (Either SomeException a)+waitCatchSTM (Async _ var) = readTMVar var+-- >>++-- <<waitSTM+waitSTM :: Async a -> STM a+waitSTM a = do+ r <- waitCatchSTM a+ case r of+ Left e -> throwSTM e+ Right a -> return a+-- >>++-- <<wait+wait :: Async a -> IO a+wait = atomically . waitSTM+-- >>++-- <<cancel+cancel :: Async a -> IO ()+cancel (Async t _) = throwTo t ThreadKilled+-- >>++-- <<waitEither+waitEither :: Async a -> Async b -> IO (Either a b)+waitEither a b = atomically $+ fmap Left (waitSTM a)+ `orElse`+ fmap Right (waitSTM b)+-- >>++-- <<waitAny+waitAny :: [Async a] -> IO a+waitAny asyncs =+ atomically $ foldr orElse retry $ map waitSTM asyncs+-- >>++-----------------------------------------------------------------------------++sites = ["http://www.google.com",+ "http://www.bing.com",+ "http://www.yahoo.com",+ "http://www.wikipedia.com/wiki/Spade",+ "http://www.wikipedia.com/wiki/Shovel"]++-- <<main+main :: IO ()+main = do+ let+ download url = do+ r <- getURL url+ return (url, r)++ as <- mapM (async . download) sites++ (url, r) <- waitAny as+ printf "%s was first (%d bytes)\n" url (B.length r)+ mapM_ wait as+-- >>
+ geturlsstm.hs view
@@ -0,0 +1,50 @@+-- (c) Simon Marlow 2011, see the file LICENSE for copying terms.+--+-- Sample geturls.hs (CEFP summer school notes, 2011)+--+-- Downloading multiple URLs concurrently, timing the downloads+--+-- Compile with:+-- ghc -threaded --make geturls.hs++import GetURL+import TimeIt++import Control.Monad+import Control.Concurrent+import Control.Exception+import Text.Printf+import Control.Concurrent.STM+import qualified Data.ByteString as B++-----------------------------------------------------------------------------+-- Our Async API:++data Async a = Async (TVar (Maybe a))++async :: IO a -> IO (Async a)+async action = do+ var <- atomically $ newTVar Nothing+ forkIO (do a <- action; atomically (writeTVar var (Just a)))+ return (Async var)++wait :: Async a -> IO a+wait (Async var) = atomically $ do+ m <- readTVar var+ case m of+ Nothing -> retry+ Just a -> return a++-----------------------------------------------------------------------------++sites = ["http://www.google.com",+ "http://www.bing.com",+ "http://www.yahoo.com",+ "http://www.wikipedia.com/wiki/Spade",+ "http://www.wikipedia.com/wiki/Shovel"]++main = mapM (async.http) sites >>= mapM wait+ where+ http url = do+ (page, time) <- timeit $ getURL url+ printf "downloaded: %s (%d bytes, %.2fs)\n" url (B.length page) time
+ kmeans/GenSamples.hs view
@@ -0,0 +1,75 @@+import KMeansCore+import Data.Random.Normal+import System.Random+import System.IO+import Data.Array+import System.Environment+import Control.Monad+import Data.List+import Data.Binary++minX, maxX, minY, maxY, minSD, maxSD :: Double+minX = -10+maxX = 10+minY = -10+maxY = 10+minSD = 1.5+maxSD = 2.0++main = do+ n: minp: maxp: rest <- fmap (fmap read) getArgs++ case rest of+ [seed] -> setStdGen (mkStdGen seed)+ _ -> return ()++ nps <- replicateM n (randomRIO (minp, maxp))+ xs <- replicateM n (randomRIO (minX, maxY))+ ys <- replicateM n (randomRIO (minX, maxY))+ sds <- replicateM n (randomRIO (minSD, maxSD))++ let params = zip5 nps xs ys sds sds++ -- first generate a set of points for each set of sample parameters+ ss <- mapM (\(a,b,c,d,e) -> generate2DSamples a b c d e) params+ let points = concat ss++ -- dump all the points into the file "points"+ hsamp <- openFile "points" WriteMode+ mapM_ (printPoint hsamp) points+ hClose hsamp++ encodeFile "points.bin" points++ -- generate the initial clusters by assigning each point to random+ -- cluster.+ gen <- newStdGen+ let+ rand_clusters = randomRs (0,n-1) gen :: [Int]+ arr = accumArray (flip (:)) [] (0,n-1) $+ zip rand_clusters points+ clusters = map (uncurry makeCluster) (assocs arr)+ writeFile "clusters" (show clusters)++ -- so we can tell what the answer should be:+ writeFile "params" (show params)+++printPoint :: Handle -> Point -> IO ()+printPoint h (Point x y) = do+ hPutStr h (show x)+ hPutChar h ' '+ hPutStr h (show y)+ hPutChar h '\n'++generate2DSamples :: Int -- number of samples to generate+ -> Double -> Double -- X and Y of the mean+ -> Double -> Double -- X and Y standard deviations+ -> IO [Point]++generate2DSamples n mx my sdx sdy = do+ gen <- newStdGen+ let (genx, geny) = split gen+ xsamples = normals' (mx,sdx) genx+ ysamples = normals' (my,sdy) geny+ return (zipWith Point (take n xsamples) ysamples)
+ kmeans/KMeansCore.hs view
@@ -0,0 +1,67 @@+--+-- Adapted from the K-Means example in the remote-0.1.1 package,+-- (c) Jeff Epstein <jepst79@gmail.com>+--++{-# LANGUAGE DeriveDataTypeable #-}+module KMeansCore where++import Data.List+import Data.Typeable (Typeable)+import Data.Data (Data)+import qualified Data.ByteString.Char8 as B+import Data.Binary+import Control.DeepSeq++-- -----------------------------------------------------------------------------+-- Points++data Point = Point {-#UNPACK#-}!Double {-#UNPACK#-}!Double+ deriving (Show,Read,Eq)++instance NFData Point++-- <<point-ops+zeroPoint :: Point+zeroPoint = Point 0 0++sqDistance :: Point -> Point -> Double+sqDistance (Point x1 y1) (Point x2 y2) = ((x1-x2)^2) + ((y1-y2)^2)+-- >>++instance Binary Point where+ put (Point a b) = put a >> put b+ get = do a <- get; b <- get; return (Point a b)++readPoints :: FilePath -> IO [Point]+readPoints f = do+ s <- B.readFile f+ let ls = map B.words $ B.lines s+ points = [ Point (read (B.unpack sx)) (read (B.unpack sy))+ | (sx:sy:_) <- ls ]+ --+ return points++-----------------------------------------------------------------------------+-- Clusters++data Cluster+ = Cluster { clId :: {-# UNPACK #-} !Int+ , clCent :: {-# UNPACK #-} !Point+ }+ deriving (Show,Read,Eq)++instance NFData Cluster -- default is ok, all the fields are strict+++makeCluster :: Int -> [Point] -> Cluster+makeCluster clid points =+ Cluster { clId = clid+ , clCent = Point (a / fromIntegral count) (b / fromIntegral count)+ }+ where+ pointsum@(Point a b) = foldl' addPoint zeroPoint points+ count = length points++ addPoint :: Point -> Point -> Point+ addPoint (Point a b) (Point c d) = Point (a+c) (b+d)
+ kmeans/kmeans.hs view
@@ -0,0 +1,310 @@+{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}++-- K-Means sample from "Parallel and Concurrent Programming in Haskell"+--+-- With three versions:+-- [ kmeans_seq ] a sequential version+-- [ kmeans_strat ] a parallel version using Control.Parallel.Strategies+-- [ kmeans_par ] a parallel version using Control.Monad.Par+--+-- Usage (sequential):+-- $ ./kmeans seq+--+-- Usage (Strategies):+-- $ ./kmeans strat 600 +RTS -N4+--+-- Usage (Par monad):+-- $ ./kmeans par 600 +RTS -N4+--+-- Usage (divide-and-conquer / Par monad):+-- $ ./kmeans divpar 7 +RTS -N4+--+-- Usage (divide-and-conquer / Eval monad):+-- $ ./kmeans diveval 7 +RTS -N4++import System.IO+import KMeansCore+import Data.Array+import Data.Array.Unsafe as Unsafe+import Text.Printf+import Data.List+import Data.Function+import Data.Binary (decodeFile)+import Debug.Trace+import Control.Parallel.Strategies as Strategies+import Control.Monad.Par as Par+import Control.DeepSeq+import System.Environment+import Data.Time.Clock+import Control.Exception+import Control.Concurrent+import Control.Monad.ST+import Data.Array.ST+import System.Mem+import Data.Maybe++import qualified Data.Vector as Vector+import Data.Vector (Vector)+import qualified Data.Vector.Mutable as MVector++-- -----------------------------------------------------------------------------+-- main: read input files, time calculation++main = runInUnboundThread $ do+ points <- decodeFile "points.bin"+ clusters <- read `fmap` readFile "clusters"+ let nclusters = length clusters+ args <- getArgs+ npoints <- evaluate (length points)+ performGC+ t0 <- getCurrentTime+ final_clusters <- case args of+ ["seq" ] -> kmeans_seq nclusters points clusters+ ["strat", n] -> kmeans_strat (read n) nclusters points clusters+ ["par", n] -> kmeans_par (read n) nclusters points clusters+ ["divpar", n] -> kmeans_div_par (read n) nclusters points clusters npoints+ ["diveval", n] -> kmeans_div_eval (read n) nclusters points clusters npoints+ _other -> error "args"+ t1 <- getCurrentTime+ print final_clusters+ printf "Total time: %.2f\n" (realToFrac (diffUTCTime t1 t0) :: Double)++-- -----------------------------------------------------------------------------+-- K-Means: repeatedly step until convergence (sequential)++-- <<kmeans_seq+kmeans_seq :: Int -> [Point] -> [Cluster] -> IO [Cluster]+kmeans_seq nclusters points clusters =+ let+ loop :: Int -> [Cluster] -> IO [Cluster]+ loop n clusters | n > tooMany = do -- <1>+ putStrLn "giving up."+ return clusters+ loop n clusters = do+ printf "iteration %d\n" n+ putStr (unlines (map show clusters))+ let clusters' = step nclusters clusters points -- <2>+ if clusters' == clusters -- <3>+ then return clusters+ else loop (n+1) clusters'+ in+ loop 0 clusters++tooMany = 80+-- >>++-- -----------------------------------------------------------------------------+-- K-Means: repeatedly step until convergence (Strategies)++-- <<kmeans_strat+kmeans_strat :: Int -> Int -> [Point] -> [Cluster] -> IO [Cluster]+kmeans_strat numChunks nclusters points clusters =+ let+ chunks = split numChunks points -- <1>++ loop :: Int -> [Cluster] -> IO [Cluster]+ loop n clusters | n > tooMany = do+ printf "giving up."+ return clusters+ loop n clusters = do+ printf "iteration %d\n" n+ putStr (unlines (map show clusters))+ let clusters' = parSteps_strat nclusters clusters chunks -- <2>+ if clusters' == clusters+ then return clusters+ else loop (n+1) clusters'+ in+ loop 0 clusters+-- >>++-- <<split+split :: Int -> [a] -> [[a]]+split numChunks xs = chunk (length xs `quot` numChunks) xs++chunk :: Int -> [a] -> [[a]]+chunk n [] = []+chunk n xs = as : chunk n bs+ where (as,bs) = splitAt n xs+-- >>++-- -----------------------------------------------------------------------------+-- K-Means: repeatedly step until convergence (Par monad)++kmeans_par :: Int -> Int -> [Point] -> [Cluster] -> IO [Cluster]+kmeans_par mappers nclusters points clusters =+ let+ chunks = split mappers points++ loop :: Int -> [Cluster] -> IO [Cluster]+ loop n clusters | n > tooMany = do printf "giving up."; return clusters+ loop n clusters = do+ printf "iteration %d\n" n+ putStr (unlines (map show clusters))+ let+ clusters' = steps_par nclusters clusters chunks++ if clusters' == clusters+ then return clusters+ else loop (n+1) clusters'+ in+ loop 0 clusters++-- -----------------------------------------------------------------------------+-- kmeans_div_par: Use divide-and-conquer, and the Par monad for parallellism.++kmeans_div_par :: Int -> Int -> [Point] -> [Cluster] -> Int -> IO [Cluster]+kmeans_div_par threshold nclusters points clusters npoints =+ let+ tree = mkPointTree threshold points npoints++ loop :: Int -> [Cluster] -> IO [Cluster]+ loop n clusters | n > tooMany = do printf "giving up."; return clusters+ loop n clusters = do+ hPrintf stderr "iteration %d\n" n+ hPutStr stderr (unlines (map show clusters))+ let+ divconq :: Tree [Point] -> Par (Vector PointSum)+ divconq (Leaf points) = return $ assign nclusters clusters points+ divconq (Node left right) = do+ i1 <- spawn $ divconq left+ i2 <- spawn $ divconq right+ c1 <- get i1+ c2 <- get i2+ return $! combine c1 c2++ clusters' = makeNewClusters $ runPar $ divconq tree++ if clusters' == clusters+ then return clusters+ else loop (n+1) clusters'+ in+ loop 0 clusters++data Tree a = Leaf a+ | Node (Tree a) (Tree a)+++mkPointTree :: Int -> [Point] -> Int -> Tree [Point]+mkPointTree threshold points npoints = go 0 points npoints+ where+ go depth points npoints+ | depth >= threshold = Leaf points+ | otherwise = Node (go (depth+1) xs half)+ (go (depth+1) ys half)+ where+ half = npoints `quot` 2+ (xs,ys) = splitAt half points++-- -----------------------------------------------------------------------------+-- kmeans_div_eval: Use divide-and-conquer, and the Eval monad for parallellism.++kmeans_div_eval :: Int -> Int -> [Point] -> [Cluster] -> Int -> IO [Cluster]+kmeans_div_eval threshold nclusters points clusters npoints =+ let+ tree = mkPointTree threshold points npoints++ loop :: Int -> [Cluster] -> IO [Cluster]+ loop n clusters | n > tooMany = do printf "giving up."; return clusters+ loop n clusters = do+ hPrintf stderr "iteration %d\n" n+ hPutStr stderr (unlines (map show clusters))+ let+ divconq :: Tree [Point] -> Vector PointSum+ divconq (Leaf points) = assign nclusters clusters points+ divconq (Node left right) = runEval $ do+ c1 <- rpar $ divconq left+ c2 <- rpar $ divconq right+ rdeepseq c1+ rdeepseq c2+ return $! combine c1 c2++ clusters' = makeNewClusters $ divconq tree++ if clusters' == clusters+ then return clusters+ else loop (n+1) clusters'+ in+ loop 0 clusters++-- -----------------------------------------------------------------------------+-- Perform one step of the K-Means algorithm++-- <<step+step :: Int -> [Cluster] -> [Point] -> [Cluster]+step nclusters clusters points+ = makeNewClusters (assign nclusters clusters points)+-- >>++-- <<assign+assign :: Int -> [Cluster] -> [Point] -> Vector PointSum+assign nclusters clusters points = Vector.create $ do+ vec <- MVector.replicate nclusters (PointSum 0 0 0)+ let+ addpoint p = do+ let c = nearest p; cid = clId c+ ps <- MVector.read vec cid+ MVector.write vec cid $! addToPointSum ps p++ mapM_ addpoint points+ return vec+ where+ nearest p = fst $ minimumBy (compare `on` snd)+ [ (c, sqDistance (clCent c) p) | c <- clusters ]+-- >>++data PointSum = PointSum {-# UNPACK #-} !Int {-# UNPACK #-} !Double {-# UNPACK #-} !Double++instance NFData PointSum++-- <<addToPointSum+addToPointSum :: PointSum -> Point -> PointSum+addToPointSum (PointSum count xs ys) (Point x y)+ = PointSum (count+1) (xs + x) (ys + y)+-- >>++-- <<pointSumToCluster+pointSumToCluster :: Int -> PointSum -> Cluster+pointSumToCluster i (PointSum count xs ys) =+ Cluster { clId = i+ , clCent = Point (xs / fromIntegral count) (ys / fromIntegral count)+ }+-- >>++-- <<addPointSums+addPointSums :: PointSum -> PointSum -> PointSum+addPointSums (PointSum c1 x1 y1) (PointSum c2 x2 y2)+ = PointSum (c1+c2) (x1+x2) (y1+y2)+-- >>++-- <<combine+combine :: Vector PointSum -> Vector PointSum -> Vector PointSum+combine = Vector.zipWith addPointSums+-- >>++-- <<parSteps_strat+parSteps_strat :: Int -> [Cluster] -> [[Point]] -> [Cluster]+parSteps_strat nclusters clusters pointss+ = makeNewClusters $+ foldr1 combine $+ (map (assign nclusters clusters) pointss+ `using` parList rseq)+-- >>++steps_par :: Int -> [Cluster] -> [[Point]] -> [Cluster]+steps_par nclusters clusters pointss+ = makeNewClusters $+ foldl1' combine $+ (runPar $ Par.parMap (assign nclusters clusters) pointss)++-- <<makeNewClusters+makeNewClusters :: Vector PointSum -> [Cluster]+makeNewClusters vec =+ [ pointSumToCluster i ps+ | (i,ps@(PointSum count _ _)) <- zip [0..] (Vector.toList vec)+ , count > 0+ ]+-- >>+ -- v. important: filter out any clusters that have+ -- no points. This can happen when a cluster is not+ -- close to any points. If we leave these in, then+ -- the NaNs mess up all the future calculations.
+ logger.hs view
@@ -0,0 +1,56 @@+import Control.Concurrent+import Control.Monad++-- -----------------------------------------------------------------------------++-- <<Logger+data Logger = Logger (MVar LogCommand)++data LogCommand = Message String | Stop (MVar ())+-- >>++-- <<initLogger+initLogger :: IO Logger+initLogger = do+ m <- newEmptyMVar+ let l = Logger m+ forkIO (logger l)+ return l+-- >>++-- <<logger+logger :: Logger -> IO ()+logger (Logger m) = loop+ where+ loop = do+ cmd <- takeMVar m+ case cmd of+ Message msg -> do+ putStrLn msg+ loop+ Stop s -> do+ putStrLn "logger: stop"+ putMVar s ()+-- >>++-- <<logMessage+logMessage :: Logger -> String -> IO ()+logMessage (Logger m) s = putMVar m (Message s)+-- >>++-- <<logStop+logStop :: Logger -> IO ()+logStop (Logger m) = do+ s <- newEmptyMVar+ putMVar m (Stop s)+ takeMVar s+-- >>++-- <<main+main :: IO ()+main = do+ l <- initLogger+ logMessage l "hello"+ logMessage l "bye"+ logStop l+-- >>
+ mandel/Config.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TemplateHaskell #-}++module Config (++ Options, optBackend, optSize, optLimit, optBench,+ processArgs, run, run1++) where++import Data.Label+import System.Exit+import System.Console.GetOpt+import Data.Array.Accelerate ( Arrays, Acc )+import qualified Data.Array.Accelerate.Interpreter as Interp+#ifdef ACCELERATE_CUDA_BACKEND+import qualified Data.Array.Accelerate.CUDA as CUDA+#endif++data Backend = Interpreter+#ifdef ACCELERATE_CUDA_BACKEND+ | CUDA+#endif+ deriving (Bounded, Show)++data Options = Options+ {+ optBackend :: Backend+ , optSize :: Int+ , optLimit :: Int+ , optBench :: Bool+ , optHelp :: Bool+ }+ deriving Show++defaultOptions :: Options+defaultOptions = Options+ { optBackend = maxBound+ , optSize = 512+ , optLimit = 255+ , optBench = False+ , optHelp = False+ }+++run :: Arrays a => Options -> Acc a -> a+run opts = case optBackend opts of+ Interpreter -> Interp.run+#ifdef ACCELERATE_CUDA_BACKEND+ CUDA -> CUDA.run+#endif++run1 :: (Arrays a, Arrays b) => Options -> (Acc a -> Acc b) -> a -> b+run1 opts f = case optBackend opts of+ Interpreter -> head . Interp.stream f . return+#ifdef ACCELERATE_CUDA_BACKEND+ CUDA -> CUDA.run1 f+#endif+++options :: [OptDescr (Options -> Options)]+options =+ [ Option [] ["interpreter"] (NoArg (\o -> o{optBackend=Interpreter})) "reference implementation (sequential)"+#ifdef ACCELERATE_CUDA_BACKEND+ , Option [] ["cuda"] (NoArg (\o -> o{optBackend = CUDA})) "implementation for NVIDIA GPUs (parallel)"+#endif+ , Option [] ["size"] (ReqArg (\i o -> o{optSize = read i}) "INT") "visualisation size (512)"+ , Option [] ["limit"] (ReqArg (\i o -> o{optLimit = read i}) "INT") "iteration limit for escape (255)"+ , Option [] ["benchmark"] (NoArg (\o -> o{optBench = True})) "benchmark instead of displaying animation (False)"+ , Option "h?" ["help"] (NoArg (\o -> o{optHelp = True})) "show help message"+ ]+++processArgs :: [String] -> IO (Options, [String])+processArgs argv =+ case getOpt' Permute options argv of+ (o,_,n,[]) -> case foldl (flip id) defaultOptions o of+ opts | False <- optHelp opts -> return (opts, n)+ opts | True <- optBench opts -> return (opts, "--help":n)+ _ -> putStrLn (helpMsg []) >> exitSuccess+ (_,_,_,err) -> error (helpMsg err)+ where+ helpMsg err = concat err ++ usageInfo header options+ header = unlines+ [ "accelerate-mandelbrot (c) [2011..2012] The Accelerate Team"+ , ""+ , "Usage: accelerate-mandelbrot [OPTIONS]"+ ]+
+ mandel/mandel.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE TypeOperators #-}+--+-- A Mandelbrot set generator. Submitted by Simon Marlow as part of Issue #49.+--+++import Config+import Control.Monad+import Control.Exception+import Foreign.Ptr+import Foreign.ForeignPtr+import System.IO.Unsafe+import System.Environment+import Data.Array.Accelerate.Array.Data ( ptrsOfArrayData )+import Data.Array.Accelerate.Array.Sugar ( Array(..) )++import Prelude as P+import Data.Array.Accelerate as A hiding ( size )+import Data.Array.Accelerate.IO+import qualified Data.Array.Repa as R+import qualified Data.Array.Repa.Repr.ForeignPtr as R+import Data.Array.Repa.IO.DevIL+++-- Mandelbrot Set --------------------------------------------------------------++-- <<types+type F = Float+type Complex = (F,F)+type ComplexPlane = Array DIM2 Complex+-- >>++-- <<mandelbrot+mandelbrot :: F -> F -> F -> F -> Int -> Int -> Int+ -> Acc (Array DIM2 (Complex,Int))++mandelbrot x y x' y' screenX screenY max_depth+ = iterate go zs0 !! max_depth -- <4>+ where+ cs = genPlane x y x' y' screenX screenY -- <1>+ zs0 = mkinit cs -- <2>++ go :: Acc (Array DIM2 (Complex,Int))+ -> Acc (Array DIM2 (Complex,Int))+ go = A.zipWith iter cs -- <3>+-- >>+++-- <<genPlane+genPlane :: F -> F+ -> F -> F+ -> Int+ -> Int+ -> Acc ComplexPlane+-- >>+genPlane lowx lowy highx highy viewx viewy+ = generate (constant (Z:.viewy:.viewx))+ (\ix -> let pr = unindex2 ix+ x = A.fromIntegral (A.fst pr)+ y = A.fromIntegral (A.snd pr)+ in+ lift ( elowx + (x * exsize) / eviewx+ , elowy + (y * eysize) / eviewy))+ where+ elowx, elowy, exsize, eysize, eviewx, eviewy :: Exp F++ elowx = constant lowx+ elowy = constant lowy++ exsize = constant (highx - lowx)+ eysize = constant (highy - lowy)++ eviewx = constant (P.fromIntegral viewx)+ eviewy = constant (P.fromIntegral viewy)+++-- <<next+next :: Exp Complex -> Exp Complex -> Exp Complex+next c z = c `plus` (z `times` z)+-- >>++-- <<plus+plus :: Exp Complex -> Exp Complex -> Exp Complex+plus = lift2 f+ where f :: (Exp F, Exp F) -> (Exp F, Exp F) -> (Exp F, Exp F)+ f (x1,y1) (x2,y2) = (x1+x2,y1+y2)+-- >>++-- <<times+times :: Exp Complex -> Exp Complex -> Exp Complex+times = lift2 f+ where f :: (Exp F, Exp F) -> (Exp F, Exp F) -> (Exp F, Exp F)+ f (ax,ay) (bx,by) = (ax*bx-ay*by, ax*by+ay*bx)+-- >>++-- <<dot+dot :: Exp Complex -> Exp F+dot = lift1 f+ where f :: (Exp F, Exp F) -> Exp F+ f (x,y) = x*x + y*y+-- >>+++-- <<iter0+iter :: Exp Complex -> Exp (Complex,Int) -> Exp (Complex,Int)+iter c p =+ let+ (z,i) = unlift p :: (Exp Complex, Exp Int)+ z' = next c z+ in+ (dot z' >* 4.0) ?+ ( p+ , lift (z', i+1)+ )+-- >>++-- <<mkinit+mkinit :: Acc ComplexPlane -> Acc (Array DIM2 (Complex,Int))+mkinit cs = A.map (lift1 f) cs+ where f :: (Exp F, Exp F) -> ((Exp F, Exp F), Exp Int)+ f (x,y) = ((x,y),0)+-- >>+++-- Rendering -------------------------------------------------------------------++type RGBA = Word32++prettyRGBA :: Exp Int -> Exp (Complex, Int) -> Exp RGBA+prettyRGBA lIMIT s' = r + g + b + a+ where+ (_, s) = unlift s' :: (Exp (F, F), Exp Int)+ t = A.fromIntegral $ ((lIMIT - s) * 255) `quot` lIMIT+ r = (t `mod` 128 + 64)+ g = (t * 2 `mod` 128 + 64) * 0x100+ b = (t * 3 `mod` 256 ) * 0x10000+ a = 0xFF000000+++makePicture :: Options -> Int -> Acc (Array DIM2 (Complex, Int))+ -> R.Array R.F R.DIM3 Word8+makePicture opt limit zs = R.fromForeignPtr (R.Z R.:. h R.:. w R.:. 4) rawData+ where+ arrPixels = run opt $ A.map (prettyRGBA (constant limit)) zs+ (Z:.h:.w) = arrayShape arrPixels++ {-# NOINLINE rawData #-}+ rawData = let (Array _ adata) = arrPixels+ ((), ptr) = ptrsOfArrayData adata+ in+ unsafePerformIO $ newForeignPtr_ (castPtr ptr)++++-- Main ------------------------------------------------------------------------++main :: IO ()+main+ = do (config, nops) <- processArgs =<< getArgs+ let size = optSize config+ limit = optLimit config+ --+ x = -0.25 -- should get this from command line as well+ y = -1.0+ x' = 0.0+ y' = -0.75+ --+ image = makePicture config limit+ $ mandelbrot x y x' y' size size limit++ runIL $ writeImage "out.png" (RGBA image)
+ modifytwo.hs view
@@ -0,0 +1,15 @@+import Control.Concurrent++-- <<modifyTwo+modifyTwo :: MVar a -> MVar b -> (a -> b -> IO (a,b)) -> IO ()+modifyTwo ma mb f =+ modifyMVar_ mb $ \b ->+ modifyMVar ma $ \a -> f a b+-- >>++main = do+ ma <- newMVar 'a'+ mb <- newMVar 'b'+ modifyTwo ma mb (\a b -> return (succ a, succ b))+ readMVar ma >>= print+ readMVar mb >>= print
+ mvar1.hs view
@@ -0,0 +1,10 @@+import Control.Concurrent++-- <<main+main = do+ m <- newEmptyMVar+ forkIO $ putMVar m 'x'+ r <- takeMVar m+ print r+-- >>+
+ mvar2.hs view
@@ -0,0 +1,11 @@+import Control.Concurrent++-- <<main+main = do+ m <- newEmptyMVar+ forkIO $ do putMVar m 'x'; putMVar m 'y'+ r <- takeMVar m+ print r+ r <- takeMVar m+ print r+-- >>
+ mvar3.hs view
@@ -0,0 +1,7 @@+import Control.Concurrent++-- <<main+main = do+ m <- newEmptyMVar+ takeMVar m+-- >>
+ mvar4.hs view
@@ -0,0 +1,17 @@+import Control.Concurrent+import GHC.Conc+import Debug.Trace++-- <<main+main = do+ t <- myThreadId+ labelThread t "main"+ m <- newEmptyMVar+ t <- forkIO $ putMVar m 'a'+ labelThread t "a"+ t <- forkIO $ putMVar m 'b'+ labelThread t "b"+ traceEventIO "before takeMVar"+ takeMVar m+ takeMVar m+-- >>
+ other/BingTranslate.hs view
@@ -0,0 +1,73 @@+module BingTranslate (+ detectLanguage,+ getLanguages,+ translateText+ ) where++import GetURL+import Text.XML.Light+import Text.Printf+import Data.ByteString.UTF8 as UTF8++-- Simon Marlow's AppId, please get your own from http://msdn.microsoft.com/en-us/library/ff512386.aspx+myAppId = "3157F269F56493B5581BAA4AE7B99C35052DA38B"++-- New v2 API:+getlanguagesUri = "http://api.microsofttranslator.com/v2/Http.svc/GetLanguagesForTranslate?appId=" ++ myAppId+detectUri = "http://api.microsofttranslator.com/v2/Http.svc/Detect?appId=" ++ myAppId+translateUri = "http://api.microsofttranslator.com/v2/Http.svc/Translate?appId=" ++ myAppId++getLanguages :: IO [String]+getLanguages = do+ r <- getURL getlanguagesUri+ return (getLangs (parseXML r))++detectLanguage :: String -> IO String+detectLanguage text = do+ r <- getURL (detectUri ++ "&text=" ++ text)+ return (head (map getString (parseXML r)))++translateText :: String -> String -> String -> IO String+translateText text fromLang toLang = do+ r <- getURL (printf "%s&text=%s&from=%s&to=%s" translateUri text fromLang toLang)+ return (concat (map getString (parseXML (UTF8.toString r))))++-----------------------------------------------------------------------------+-- Hacky XML decoding++-- This will fail utterly if the input is not in the right form.++getLangs :: [Content] -> [String]+getLangs [Elem (Element {elName = QName { qName = "ArrayOfstring" }, elContent = strs })]+ = map getString strs++getString :: Content -> String+getString (Elem (Element {elName = QName { qName = "string" }, elContent = [Text (CData { cdData = str })]})) = str+++-- OLD stuff that we might need later:++-- httpRequestUTF8 :: String -> Maybe ByteString -> IO String+-- httpRequestUTF8 url body = do+-- let request_hdr = postRequest url+-- request | Just text <- body = request_hdr `addRequestContent` text+-- | otherwise = request_hdr+-- s <- simpleHTTP request >>= getResponseBody+-- return (chopBOM (UTF8.toString s))+-- +-- chopBOM ('\xfeff' : s) = s+-- chopBOM s = s+-- +-- postRequest :: HStream a => String -> Request a+-- postRequest urlString = +-- case parseURI urlString of+-- Nothing -> error ("postRequest: Not a valid URL - " ++ urlString)+-- Just u -> mkRequest POST u+-- +-- addRequestContent :: Request ByteString -> ByteString -> Request ByteString+-- addRequestContent rq content+-- = rq {rqBody = content,+-- rqHeaders = +-- mkHeader HdrContentType "text/plain" :+-- mkHeader HdrContentLength (show (B.length content)) : rqHeaders rq+-- }
+ other/bingtranslator.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE PatternGuards #-}++import Control.Concurrent+import Control.Exception+import Control.Monad+import Text.Printf+import qualified Data.ByteString.UTF8 as UTF8+import qualified Data.ByteString.Char8 as B+import System.Environment+import Prelude hiding (catch)++import BingTranslate as Bing++main = do+ [text] <- fmap (fmap (B.unpack . UTF8.fromString)) getArgs++ languages <- Bing.getLanguages++ fromLang <- Bing.detectLanguage text+ printf "\"%s\" appears to be in language \"%s\"\n" text fromLang++ forM_ (filter (/= fromLang) languages) $ \toLang -> do+ str <- Bing.translateText text fromLang toLang+ printf "%s: %s\n" toLang str++-----------------------------------------------------------------------------+-- Our Async API:++data Async a = Async ThreadId (MVar (Either SomeException a))++async :: IO a -> IO (Async a)+async action = do+ var <- newEmptyMVar+ t <- forkIO ((do r <- action; putMVar var (Right r))+ `catch` \e -> putMVar var (Left e))+ return (Async t var)++wait :: Async a -> IO (Either SomeException a)+wait (Async t var) = readMVar var++cancel :: Async a -> IO ()+cancel (Async t var) = throwTo t ThreadKilled
+ other/bingtranslatorconc.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE PatternGuards #-}+import Network.HTTP hiding (postRequest)+import Control.Exception+import Control.Monad+import Text.Printf+import Data.ByteString (ByteString)+import qualified Data.ByteString.UTF8 as UTF8+import Network.URI+import System.Environment+import Control.Concurrent+import Prelude hiding (catch)+import Network.HTTP+import Network.Browser+import Network.URI+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import Text.XML.Light++import BingTranslate as Bing++main = do+ [text] <- fmap (fmap (B.unpack . UTF8.fromString)) getArgs++ languages <- Bing.getLanguages++ fromLang <- Bing.detectLanguage text+ printf "\"%s\" appears to be in language \"%s\"\n" text fromLang++ translations <- concurrently $+ map (\lang -> do r <- Bing.translateText text fromLang lang; return (lang,r))+ (filter (/= fromLang) languages)++ forM_ translations $ \(lang,str) ->+ printf "%s: %s\n" lang str++-----------------------------------------------------------------------------+-- Our Async API:++data Async a = Async ThreadId (MVar (Either SomeException a))++async :: IO a -> IO (Async a)+async action = do+ var <- newEmptyMVar+ t <- forkIO ((do r <- action; putMVar var (Right r))+ `catch` \e -> putMVar var (Left e))+ return (Async t var)++wait :: Async a -> IO (Either SomeException a)+wait (Async t var) = readMVar var++waitFail :: Async a -> IO a+waitFail (Async t var) = do+ e <- readMVar var+ case e of+ Left err -> throw err+ Right a -> return a++cancel :: Async a -> IO ()+cancel (Async t var) = throwTo t ThreadKilled++concurrently :: [IO a] -> IO [a]+concurrently ios = mapM async ios >>= mapM waitFail++-- httpRequestUTF8 :: String -> Maybe ByteString -> IO String+-- httpRequestUTF8 url body = do+-- let request_hdr = postRequest url+-- request | Just text <- body = request_hdr `addRequestContent` text+-- | otherwise = request_hdr+-- s <- simpleHTTP request >>= getResponseBody+-- return (chopBOM (UTF8.toString s))+-- +-- chopBOM ('\xfeff' : s) = s+-- chopBOM s = s+-- +-- postRequest :: HStream a => String -> Request a+-- postRequest urlString = +-- case parseURI urlString of+-- Nothing -> error ("postRequest: Not a valid URL - " ++ urlString)+-- Just u -> mkRequest POST u+-- +-- addRequestContent :: Request ByteString -> ByteString -> Request ByteString+-- addRequestContent rq content+-- = rq {rqBody = content,+-- rqHeaders = +-- mkHeader HdrContentType "text/plain" :+-- mkHeader HdrContentLength (show (B.length content)) : rqHeaders rq+-- }
+ parconc-examples.cabal view
@@ -0,0 +1,883 @@+name: parconc-examples+version: 0.1+synopsis: Examples to accompany the book "Parallel and Concurrent Programming in Haskell"+-- description: +license: BSD3+license-file: LICENSE+author: Simon Marlow+maintainer: Simon Marlow <marlowsd@gmail.com>+copyright: (c) Simon Marlow 2011-2013+category: Sample Code+build-type: Simple+cabal-version: >=1.10++-- -----------------------------------------------------------------------------+-- Flags++-- -f llvm: enable -fllvm to GHC; requires LLVM to be installed, but+-- makes the Repa programs faster++flag llvm+ default: False++-- -f devil: Enable the image-maniputation programs, which are+-- disabled by default because they require the devil library which+-- needs to be installed separately.++flag devil+ default: False++-- -f cuda: Build the examples that require accelerate-cuda. These+-- need the NVidia CUDA tools installed.++flag cuda+ default: False++-- -----------------------------------------------------------------------------+-- par-eval++executable sudoku1+ main-is: sudoku1.hs+ other-modules: Sudoku+ build-depends: base >= 4.5 && < 4.7+ , parallel ==3.2.*+ , array ==0.4.*+ default-language: Haskell2010++executable sudoku2+ main-is: sudoku2.hs+ other-modules: Sudoku+ build-depends: base >= 4.5 && < 4.7+ , parallel ==3.2.*+ , array ==0.4.*+ , deepseq ==1.3.*+ ghc-options: -threaded+ default-language: Haskell2010++executable sudoku3+ main-is: sudoku3.hs+ other-modules: Sudoku+ build-depends: base >= 4.5 && < 4.7+ , parallel ==3.2.*+ , array ==0.4.*+ ghc-options: -threaded+ default-language: Haskell2010++executable sudoku4+ main-is: sudoku4.hs+ other-modules: Sudoku+ build-depends: base >= 4.5 && < 4.7+ , parallel ==3.2.*+ , array ==0.4.*+ ghc-options: -threaded+ default-language: Haskell2010++-- -----------------------------------------------------------------------------+-- par-strat++executable strat+ main-is: strat.hs+ build-depends: base >= 4.5 && < 4.7+ , parallel ==3.2.*+ ghc-options: -threaded+ default-language: Haskell2010++executable strat2+ main-is: strat2.hs+ build-depends: base >= 4.5 && < 4.7+ , parallel ==3.2.*+ ghc-options: -threaded+ default-language: Haskell2010++executable strat3+ main-is: strat3.hs+ build-depends: base >= 4.5 && < 4.7+ , parallel ==3.2.*+ ghc-options: -threaded+ default-language: Haskell2010++executable rsa+ main-is: rsa.hs+ other-modules: ByteStringCompat+ build-depends: base >= 4.5 && < 4.7+ , bytestring >= 0.9 && < 0.11+ , deepseq ==1.3.*+ default-language: Haskell2010++executable rsa1+ main-is: rsa1.hs+ other-modules: ByteStringCompat+ build-depends: base >= 4.5 && < 4.7+ , bytestring >= 0.9 && < 0.11+ , parallel ==3.2.*+ , deepseq ==1.3.*+ ghc-options: -threaded+ default-language: Haskell2010++executable rsa2+ main-is: rsa2.hs+ other-modules: ByteStringCompat+ build-depends: base >= 4.5 && < 4.7+ , bytestring >= 0.9 && < 0.11+ , parallel ==3.2.*+ , deepseq ==1.3.*+ ghc-options: -threaded+ default-language: Haskell2010++executable kmeans+ hs-source-dirs: kmeans+ main-is: kmeans.hs+ other-modules: KMeansCore+ build-depends: base >= 4.5 && < 4.7+ , parallel ==3.2.*+ , time ==1.4.*+ , deepseq ==1.3.*+ , monad-par >= 0.3.4 && < 0.4+ -- monad-par 0.3 has a bug:+ -- https://github.com/simonmar/monad-par/issues/23+ , binary >= 0.5 && < 0.7+ , array ==0.4.*+ , bytestring >= 0.9 && < 0.11+ , vector >= 0.10 && < 0.11+ ghc-options: -threaded+ default-language: Haskell2010++executable GenSamples+ hs-source-dirs: kmeans+ main-is: GenSamples.hs+ build-depends: base >= 4.5 && < 4.7+ , binary >= 0.5 && < 0.7+ , array ==0.4.*+ , vector >= 0.10 && < 0.11+ , random >= 1.0 && < 1.1+ , normaldistribution >= 1.1 && < 1.2+ , deepseq ==1.3.*+ , bytestring >= 0.9 && < 0.11+ default-language: Haskell2010++-- -----------------------------------------------------------------------------+-- par-monad++executable parmonad+ main-is: parmonad.hs+ build-depends: base >= 4.5 && < 4.7+ , monad-par >= 0.3.4 && < 0.4+ ghc-options: -threaded+ default-language: Haskell2010++executable rsa-pipeline+ main-is: rsa-pipeline.hs+ other-modules: ByteStringCompat Stream+ build-depends: base >= 4.5 && < 4.7+ , bytestring >= 0.9 && < 0.11+ , monad-par >= 0.3.4 && < 0.4+ , deepseq ==1.3.*+ ghc-options: -threaded+ default-language: Haskell2010++executable fwsparse+ main-is: fwsparse.hs+ other-modules: SparseGraph MapCompat+ hs-source-dirs: fwsparse+ build-depends: base >= 4.5 && < 4.7+ , random >= 1.0 && < 1.1+ , array ==0.4.*+ , containers >= 0.4 && < 0.6+ default-language: Haskell2010++executable fwsparse1+ main-is: fwsparse1.hs+ other-modules: SparseGraph MapCompat+ hs-source-dirs: fwsparse+ build-depends: base >= 4.5 && < 4.7+ , random >= 1.0 && < 1.1+ , array ==0.4.*+ , containers >= 0.4 && < 0.6+ , monad-par >= 0.3.4 && < 0.4+ , deepseq ==1.3.*+ ghc-options: -threaded+ default-language: Haskell2010++executable timetable+ main-is: timetable.hs+ build-depends: base >= 4.5 && < 4.7+ , containers >= 0.4 && < 0.6+ , deepseq ==1.3.*+ , random >= 1.0 && < 1.1+ default-language: Haskell2010++executable timetable1+ main-is: timetable1.hs+ build-depends: base >= 4.5 && < 4.7+ , containers >= 0.4 && < 0.6+ , deepseq ==1.3.*+ , monad-par >= 0.3.4 && < 0.4+ , random >= 1.0 && < 1.1+ default-language: Haskell2010++executable timetable2+ main-is: timetable2.hs+ build-depends: base >= 4.5 && < 4.7+ , containers >= 0.4 && < 0.6+ , deepseq ==1.3.*+ , monad-par >= 0.3.4 && < 0.4+ , random >= 1.0 && < 1.1+ default-language: Haskell2010++executable timetable3+ main-is: timetable3.hs+ build-depends: base >= 4.5 && < 4.7+ , containers >= 0.4 && < 0.6+ , deepseq ==1.3.*+ , monad-par >= 0.3.4 && < 0.4+ , random >= 1.0 && < 1.1+ default-language: Haskell2010++-- -----------------------------------------------------------------------------+-- par-repa++executable fwdense+ main-is: fwdense.hs+ build-depends: base >= 4.5 && < 4.7+ , repa == 3.2.*+ ghc-options: -O2+ if flag(llvm)+ ghc-options: -fllvm+ default-language: Haskell2010++executable fwdense1+ main-is: fwdense1.hs+ build-depends: base >= 4.5 && < 4.7+ , repa == 3.2.*+ , transformers ==0.3.*+ ghc-options: -O2 -threaded+ if flag(llvm)+ ghc-options: -fllvm+ default-language: Haskell2010++executable rotateimage+ main-is: rotateimage.hs+ build-depends: base >= 4.5 && < 4.7+ , repa == 3.2.*+ ghc-options: -O2 -threaded+ if flag(devil)+ build-depends: repa-devil == 0.3.*+ else+ buildable: False+ if flag(llvm)+ ghc-options: -fllvm+ default-language: Haskell2010++-- -----------------------------------------------------------------------------+-- par-accel++executable fwaccel+ main-is: fwaccel.hs+ build-depends: base >= 4.5 && < 4.7+ , accelerate >= 0.12+ ghc-options: -O2+ default-language: Haskell2010++executable fwaccel-gpu+ main-is: fwaccel.hs+ build-depends: base >= 4.5 && < 4.7+ , accelerate >= 0.12+ if flag(cuda)+ build-depends: accelerate-cuda >= 0.12+ else+ buildable: False+ ghc-options: -O2+ default-language: Haskell2010++executable mandel+ main-is: mandel.hs+ other-modules: Config+ hs-source-dirs: mandel+ build-depends: base >= 4.5 && < 4.7+ , accelerate >= 0.12+ , fclabels+ , accelerate-io+ if flag(cuda)+ build-depends: accelerate-cuda >= 0.12+ else+ buildable: False+ ghc-options: -O2+ default-language: Haskell2010++-- -----------------------------------------------------------------------------+-- conc-fork++executable fork+ main-is: fork.hs+ build-depends: base >= 4.5 && < 4.7+ default-language: Haskell2010++executable reminders+ main-is: reminders.hs+ build-depends: base >= 4.5 && < 4.7+ default-language: Haskell2010++executable reminders2+ main-is: reminders2.hs+ build-depends: base >= 4.5 && < 4.7+ default-language: Haskell2010++-- -----------------------------------------------------------------------------+-- conc-mvar++executable mvar1+ main-is: mvar1.hs+ build-depends: base >= 4.5 && < 4.7+ default-language: Haskell2010++executable mvar2+ main-is: mvar2.hs+ build-depends: base >= 4.5 && < 4.7+ default-language: Haskell2010++executable mvar3+ main-is: mvar3.hs+ build-depends: base >= 4.5 && < 4.7+ default-language: Haskell2010++executable logger+ main-is: logger.hs+ build-depends: base >= 4.5 && < 4.7+ default-language: Haskell2010++executable phonebook+ main-is: phonebook.hs+ build-depends: base >= 4.5 && < 4.7+ , containers >= 0.4 && < 0.6+ default-language: Haskell2010++executable chan+ main-is: chan.hs+ build-depends: base >= 4.5 && < 4.7+ default-language: Haskell2010++executable chan2+ main-is: chan2.hs+ build-depends: base >= 4.5 && < 4.7+ default-language: Haskell2010++-- -----------------------------------------------------------------------------+-- conc-overlap++executable geturls1+ main-is: geturls1.hs+ other-modules: GetURL+ build-depends: base >= 4.5 && < 4.7+ , containers >= 0.4 && < 0.6+ , network >= 2.3 && < 2.5+ , HTTP ==4000.2.*+ , bytestring >= 0.9 && < 0.11+ default-language: Haskell2010++executable geturls2+ main-is: geturls2.hs+ other-modules: GetURL+ build-depends: base >= 4.5 && < 4.7+ , stm ==2.4.*+ , bytestring >= 0.9 && < 0.11+ , time ==1.4.*+ , network >= 2.3 && < 2.5+ , HTTP ==4000.2.*+ default-language: Haskell2010++executable geturls3+ main-is: geturls3.hs+ other-modules: TimeIt GetURL+ build-depends: base >= 4.5 && < 4.7+ , stm ==2.4.*+ , bytestring >= 0.9 && < 0.11+ , time ==1.4.*+ , network >= 2.3 && < 2.5+ , HTTP ==4000.2.*+ default-language: Haskell2010++executable geturls4+ main-is: geturls4.hs+ other-modules: GetURL+ build-depends: base >= 4.5 && < 4.7+ , stm ==2.4.*+ , bytestring >= 0.9 && < 0.11+ , time ==1.4.*+ , network >= 2.3 && < 2.5+ , HTTP ==4000.2.*+ default-language: Haskell2010++executable geturls5+ main-is: geturls5.hs+ other-modules: GetURL+ build-depends: base >= 4.5 && < 4.7+ , stm ==2.4.*+ , bytestring >= 0.9 && < 0.11+ , time ==1.4.*+ , network >= 2.3 && < 2.5+ , HTTP ==4000.2.*+ default-language: Haskell2010++executable geturls6+ main-is: geturls6.hs+ other-modules: TimeIt GetURL+ build-depends: base >= 4.5 && < 4.7+ , stm ==2.4.*+ , bytestring >= 0.9 && < 0.11+ , time ==1.4.*+ , network >= 2.3 && < 2.5+ , HTTP ==4000.2.*+ default-language: Haskell2010++-- -----------------------------------------------------------------------------+-- conc-asyncex++executable geturlscancel+ main-is: geturlscancel.hs+ other-modules: TimeIt GetURL+ build-depends: base >= 4.5 && < 4.7+ , stm ==2.4.*+ , bytestring >= 0.9 && < 0.11+ , time ==1.4.*+ , network >= 2.3 && < 2.5+ , HTTP ==4000.2.*+ default-language: Haskell2010++executable geturlscancel2+ main-is: geturlscancel2.hs+ other-modules: TimeIt GetURL+ build-depends: base >= 4.5 && < 4.7+ , stm ==2.4.*+ , bytestring >= 0.9 && < 0.11+ , time ==1.4.*+ , network >= 2.3 && < 2.5+ , HTTP ==4000.2.*+ default-language: Haskell2010++executable modifytwo+ main-is: modifytwo.hs+ build-depends: base >= 4.5 && < 4.7+ default-language: Haskell2010++executable chan3+ main-is: chan3.hs+ build-depends: base >= 4.5 && < 4.7+ default-language: Haskell2010++executable timeout+ main-is: timeout.hs+ build-depends: base >= 4.5 && < 4.7+ default-language: Haskell2010++executable catch-mask+ main-is: catch-mask.hs+ build-depends: base >= 4.5 && < 4.7+ default-language: Haskell2010++executable catch-mask2+ main-is: catch-mask2.hs+ build-depends: base >= 4.5 && < 4.7+ default-language: Haskell2010++-- -----------------------------------------------------------------------------+-- conc-stm++-- not mentioned in the text?+executable windowman+ main-is: windowman.hs+ build-depends: base >= 4.5 && < 4.7+ , containers >= 0.4 && < 0.6+ , stm ==2.4.*+ default-language: Haskell2010++executable tmvar+ main-is: tmvar.hs+ build-depends: base >= 4.5 && < 4.7+ , stm ==2.4.*+ default-language: Haskell2010++executable geturlsfirst+ main-is: geturlsfirst.hs+ other-modules: ConcurrentUtils+ build-depends: base >= 4.5 && < 4.7+ , stm ==2.4.*+ , bytestring >= 0.9 && < 0.11+ , time ==1.4.*+ , HTTP ==4000.2.*+ , network >= 2.3 && < 2.5+ default-language: Haskell2010++executable TChan+ main-is: TChan.hs+ build-depends: base >= 4.5 && < 4.7+ , stm ==2.4.*+ default-language: Haskell2010++executable TList+ main-is: TList.hs+ build-depends: base >= 4.5 && < 4.7+ , stm ==2.4.*+ default-language: Haskell2010++executable TQueue+ main-is: TQueue.hs+ build-depends: base >= 4.5 && < 4.7+ , stm ==2.4.*+ default-language: Haskell2010++executable TBQueue+ main-is: TBQueue.hs+ build-depends: base >= 4.5 && < 4.7+ , stm ==2.4.*+ default-language: Haskell2010++-- -----------------------------------------------------------------------------+-- conc-higher++executable geturls7+ main-is: geturls7.hs+ other-modules: ConcurrentUtils+ build-depends: base >= 4.5 && < 4.7+ , stm ==2.4.*+ , bytestring >= 0.9 && < 0.11+ , time ==1.4.*+ , network >= 2.3 && < 2.5+ , HTTP ==4000.2.*+ default-language: Haskell2010++executable geturls8+ main-is: geturls8.hs+ build-depends: base >= 4.5 && < 4.7+ , stm ==2.4.*+ , bytestring >= 0.9 && < 0.11+ , time ==1.4.*+ , network >= 2.3 && < 2.5+ , HTTP ==4000.2.*+ default-language: Haskell2010++executable geturls9+ main-is: geturls9.hs+ build-depends: base >= 4.5 && < 4.7+ , stm ==2.4.*+ , bytestring >= 0.9 && < 0.11+ , time ==1.4.*+ , network >= 2.3 && < 2.5+ , HTTP ==4000.2.*+ default-language: Haskell2010++executable timeout2+ main-is: timeout.hs+ build-depends: base >= 4.5 && < 4.7+ , async ==2.0.*+ default-language: Haskell2010++-- -----------------------------------------------------------------------------+-- conc-par++executable findseq+ main-is: findseq.hs+ build-depends: base >= 4.5 && < 4.7+ , filepath ==1.3.*+ , directory >= 1.1 && < 1.3+ default-language: Haskell2010++executable findpar+ main-is: findpar.hs+ build-depends: base >= 4.5 && < 4.7+ , filepath ==1.3.*+ , directory >= 1.1 && < 1.3+ , async ==2.0.*+ default-language: Haskell2010++executable findpar2+ main-is: findpar2.hs+ build-depends: base >= 4.5 && < 4.7+ , filepath ==1.3.*+ , directory >= 1.1 && < 1.3+ , async ==2.0.*+ default-language: Haskell2010++executable findpar3+ main-is: findpar3.hs+ other-modules: CasIORef+ build-depends: base >= 4.5 && < 4.7+ , filepath ==1.3.*+ , directory >= 1.1 && < 1.3+ , async ==2.0.*+ , stm ==2.4.*+ default-language: Haskell2010++executable findpar4+ main-is: findpar4.hs+ build-depends: base >= 4.5 && < 4.7+ , filepath ==1.3.*+ , directory >= 1.1 && < 1.3+ , async ==2.0.*+ , stm ==2.4.*+ , transformers ==0.3.*+ , abstract-par ==0.3.*+ , monad-par >= 0.3.4 && < 0.4+ default-language: Haskell2010++-- -----------------------------------------------------------------------------+-- conc-server++executable server+ main-is: server.hs+ other-modules: ConcurrentUtils+ build-depends: base >= 4.5 && < 4.7+ , stm ==2.4.*+ , network >= 2.3 && < 2.5+ default-language: Haskell2010++executable server2+ main-is: server2.hs+ other-modules: ConcurrentUtils+ build-depends: base >= 4.5 && < 4.7+ , stm ==2.4.*+ , async ==2.0.*+ , network >= 2.3 && < 2.5+ default-language: Haskell2010++executable chat+ main-is: chat.hs+ other-modules: ConcurrentUtils+ build-depends: base >= 4.5 && < 4.7+ , containers >= 0.4 && < 0.6+ , async ==2.0.*+ , stm ==2.4.*+ , network >= 2.3 && < 2.5+ default-language: Haskell2010++-- -----------------------------------------------------------------------------+-- conc-distrib++executable ping+ main-is: distrib-ping/ping.hs+ other-modules: DistribUtils+ build-depends: base >= 4.5 && < 4.7+ , network >= 2.3 && < 2.5+ , binary >= 0.5 && < 0.7+ , distributed-process >= 0.4.2 && < 0.5+ , distributed-process-simplelocalnet ==0.2.*+ , distributed-static ==0.2.*+ , template-haskell >= 2.7 && < 2.9+ if impl(ghc <= 7.6)+ -- prior to ghc-7.4 generics lived in ghc-prim+ build-depends: ghc-prim+ default-language: Haskell2010++executable ping-multi+ main-is: distrib-ping/ping-multi.hs+ other-modules: DistribUtils+ build-depends: base >= 4.5 && < 4.7+ , network >= 2.3 && < 2.5+ , binary >= 0.5 && < 0.7+ , distributed-process >= 0.4.2 && < 0.5+ , distributed-process-simplelocalnet ==0.2.*+ , distributed-static ==0.2.*+ , template-haskell >= 2.7 && < 2.9+ if impl(ghc <= 7.6)+ -- prior to ghc-7.4 generics lived in ghc-prim+ build-depends: ghc-prim+ default-language: Haskell2010++executable ping-tc+ main-is: distrib-ping/ping-tc.hs+ other-modules: DistribUtils+ build-depends: base >= 4.5 && < 4.7+ , network >= 2.3 && < 2.5+ , binary >= 0.5 && < 0.7+ , distributed-process >= 0.4.2 && < 0.5+ , distributed-process-simplelocalnet ==0.2.*+ , distributed-static ==0.2.*+ , template-haskell >= 2.7 && < 2.9+ if impl(ghc <= 7.6)+ -- prior to ghc-7.4 generics lived in ghc-prim+ build-depends: ghc-prim+ default-language: Haskell2010++executable ping-tc-merge+ main-is: distrib-ping/ping-tc-merge.hs+ other-modules: DistribUtils+ build-depends: base >= 4.5 && < 4.7+ , network >= 2.3 && < 2.5+ , binary >= 0.5 && < 0.7+ , distributed-process >= 0.4.2 && < 0.5+ , distributed-process-simplelocalnet ==0.2.*+ , distributed-static ==0.2.*+ , template-haskell >= 2.7 && < 2.9+ if impl(ghc <= 7.6)+ -- prior to ghc-7.4 generics lived in ghc-prim+ build-depends: ghc-prim+ default-language: Haskell2010++-- extra, not in the text?+executable ping-tc-notify+ main-is: distrib-ping/ping-tc-notify.hs+ other-modules: DistribUtils+ build-depends: base >= 4.5 && < 4.7+ , network >= 2.3 && < 2.5+ , binary >= 0.5 && < 0.7+ , distributed-process >= 0.4.2 && < 0.5+ , distributed-process-simplelocalnet ==0.2.*+ , distributed-static ==0.2.*+ , template-haskell >= 2.7 && < 2.9+ if impl(ghc <= 7.6)+ -- prior to ghc-7.4 generics lived in ghc-prim+ build-depends: ghc-prim+ default-language: Haskell2010++executable ping-fail+ main-is: distrib-ping/ping-fail.hs+ build-depends: base >= 4.5 && < 4.7+ , network >= 2.3 && < 2.5+ , binary >= 0.5 && < 0.7+ , distributed-process >= 0.4.2 && < 0.5+ , distributed-process-simplelocalnet ==0.2.*+ , distributed-static ==0.2.*+ , template-haskell >= 2.7 && < 2.9+ if impl(ghc <= 7.6)+ -- prior to ghc-7.4 generics lived in ghc-prim+ build-depends: ghc-prim+ default-language: Haskell2010++executable distrib-chat+ main-is: distrib-chat/chat.hs+ other-modules: ConcurrentUtils DistribUtils+ build-depends: base >= 4.5 && < 4.7+ , containers >= 0.4 && < 0.6+ , stm ==2.4.*+ , async ==2.0.*+ , network >= 2.3 && < 2.5+ , binary >= 0.5 && < 0.7+ , distributed-process >= 0.4.2 && < 0.5+ , distributed-process-simplelocalnet ==0.2.*+ , distributed-static ==0.2.*+ , transformers ==0.3.*+ , template-haskell >= 2.7 && < 2.9+ if impl(ghc <= 7.6)+ -- prior to ghc-7.4 generics lived in ghc-prim+ build-depends: ghc-prim+ default-language: Haskell2010++executable distrib-chat-noslave+ main-is: distrib-chat/chat-noslave.hs+ other-modules: ConcurrentUtils+ build-depends: base >= 4.5 && < 4.7+ , containers >= 0.4 && < 0.6+ , stm ==2.4.*+ , async ==2.0.*+ , network >= 2.3 && < 2.5+ , binary >= 0.5 && < 0.7+ , distributed-process >= 0.4.2 && < 0.5+ , distributed-process-simplelocalnet ==0.2.*+ , distributed-static ==0.2.*+ , transformers ==0.3.*+ , template-haskell >= 2.7 && < 2.9+ if impl(ghc <= 7.6)+ -- prior to ghc-7.4 generics lived in ghc-prim+ build-depends: ghc-prim+ default-language: Haskell2010++executable distrib-db+ main-is: db.hs+ hs-source-dirs: . distrib-db+ other-modules: DistribUtils Database+ build-depends: base >= 4.5 && < 4.7+ , containers >= 0.4 && < 0.6+ , stm ==2.4.*+ , async ==2.0.*+ , network >= 2.3 && < 2.5+ , binary >= 0.5 && < 0.7+ , distributed-process >= 0.4.2 && < 0.5+ , distributed-process-simplelocalnet ==0.2.*+ , distributed-static ==0.2.*+ , transformers ==0.3.*+ , template-haskell >= 2.7 && < 2.9+ if impl(ghc <= 7.6)+ -- prior to ghc-7.4 generics lived in ghc-prim+ build-depends: ghc-prim+ default-language: Haskell2010++-- -----------------------------------------------------------------------------+-- conc-debugging-tuning++executable mvar4+ main-is: mvar4.hs+ build-depends: base >= 4.5 && < 4.7+ default-language: Haskell2010++executable deadlock1+ main-is: deadlock1.hs+ build-depends: base >= 4.5 && < 4.7+ default-language: Haskell2010++executable deadlock2+ main-is: deadlock2.hs+ build-depends: base >= 4.5 && < 4.7+ default-language: Haskell2010++executable threadperf1+ main-is: threadperf1.hs+ build-depends: base >= 4.5 && < 4.7+ default-language: Haskell2010++executable threadperf2+ main-is: threadperf2.hs+ build-depends: base >= 4.5 && < 4.7+ ghc-options: -rtsopts+ default-language: Haskell2010++-- -----------------------------------------------------------------------------+-- Extras (exercises etc.)++executable bingtranslator+ main-is: bingtranslator.hs+ other-modules: BingTranslate GetURL+ hs-source-dirs: other .+ build-depends: base >= 4.5 && < 4.7+ , bytestring >= 0.9 && < 0.11+ , time ==1.4.*+ , HTTP ==4000.2.*+ , network >= 2.3 && < 2.5+ , utf8-string ==0.3.*+ , xml ==1.3.*+ default-language: Haskell2010++executable bingtranslatorconc+ main-is: bingtranslatorconc.hs+ other-modules: BingTranslate GetURL+ hs-source-dirs: other .+ build-depends: base >= 4.5 && < 4.7+ , bytestring >= 0.9 && < 0.11+ , time ==1.4.*+ , HTTP ==4000.2.*+ , network >= 2.3 && < 2.5+ , utf8-string ==0.3.*+ , xml ==1.3.*+ default-language: Haskell2010++executable geturlsstm+ main-is: geturlsstm.hs+ other-modules: TimeIt GetURL+ build-depends: base >= 4.5 && < 4.7+ , stm ==2.4.*+ , bytestring >= 0.9 && < 0.11+ , time ==1.4.*+ , network >= 2.3 && < 2.5+ , HTTP ==4000.2.*+ default-language: Haskell2010++executable Async+ main-is: Async.hs+ build-depends: base >= 4.5 && < 4.7+ , stm ==2.4.*+ default-language: Haskell2010++-- ToDo:+-- euler35+-- index+-- sudoku-par{1,2,3,4,5}+-- parinfer+
+ parmonad.hs view
@@ -0,0 +1,27 @@+import Control.Exception+import System.Environment+import Control.Monad.Par.Scheds.Trace+-- NB. using Trace here, Direct is too strict and forces the fibs in+-- the parent; see https://github.com/simonmar/monad-par/issues/27++-- <<fib+fib :: Integer -> Integer+fib 0 = 1+fib 1 = 1+fib n = fib (n-1) + fib (n-2)+-- >>++main = do+ args <- getArgs+ let [n,m] = map read args+ print $+-- <<runPar+ runPar $ do+ i <- new -- <1>+ j <- new -- <1>+ fork (put i (fib n)) -- <2>+ fork (put j (fib m)) -- <2>+ a <- get i -- <3>+ b <- get j -- <3>+ return (a+b) -- <4>+-- >>
+ phonebook.hs view
@@ -0,0 +1,42 @@+import Data.Map (Map)+import qualified Data.Map as Map+import Control.Concurrent+import Prelude hiding (lookup)++-- <<types+type Name = String+type PhoneNumber = String+type PhoneBook = Map Name PhoneNumber++newtype PhoneBookState = PhoneBookState (MVar PhoneBook)+-- >>++-- <<new+new :: IO PhoneBookState+new = do+ m <- newMVar Map.empty+ return (PhoneBookState m)+-- >>++-- <<insert+insert :: PhoneBookState -> Name -> PhoneNumber -> IO ()+insert (PhoneBookState m) name number = do+ book <- takeMVar m+ putMVar m (Map.insert name number book)+-- >>++-- <<lookup+lookup :: PhoneBookState -> Name -> IO (Maybe PhoneNumber)+lookup (PhoneBookState m) name = do+ book <- takeMVar m+ putMVar m book+ return (Map.lookup name book)+-- >>++-- <<main+main = do+ s <- new+ sequence_ [ insert s ("name" ++ show n) (show n) | n <- [1..10000] ]+ lookup s "name999" >>= print+ lookup s "unknown" >>= print+-- >>
+ reminders.hs view
@@ -0,0 +1,17 @@+-- <<reminders+import Control.Concurrent+import Text.Printf+import Control.Monad++main =+ forever $ do+ s <- getLine -- <1>+ forkIO $ setReminder s -- <2>++setReminder :: String -> IO ()+setReminder s = do+ let t = read s :: Int+ printf "Ok, I'll remind you in %d seconds\n" t+ threadDelay (10^6 * t) -- <3>+ printf "%d seconds is up! BING!\BEL\n" t -- <4>+-- >>
+ reminders2.hs view
@@ -0,0 +1,21 @@+import Control.Concurrent+import Text.Printf+import Control.Monad++-- <<main+main = loop+ where+ loop = do+ s <- getLine+ if s == "exit"+ then return ()+ else do forkIO $ setReminder s+ loop+-- >>++setReminder :: String -> IO ()+setReminder s = do+ let t = read s :: Int+ printf "Ok, I'll remind you in %d seconds\n" t+ threadDelay (10^6 * t) -- <3>+ printf "%d seconds is up! BING!\BEL\n" t -- <4>
+ rotateimage.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE FlexibleContexts, BangPatterns #-}++import Data.Array.Repa+import Data.Array.Repa.IO.DevIL+import System.Environment+import Data.Array.Repa.Repr.ForeignPtr+import Data.Word++-- <<main+main :: IO ()+main = do+ [n, f1,f2] <- getArgs+ runIL $ do+ (RGB v) <- readImage f1 -- <1>+ rotated <- computeP $ rotate (read n) v :: IL (Array F DIM3 Word8) -- <2>+ writeImage f2 (RGB rotated) -- <3>+-- >>++-- <<rotate+rotate :: Double -> Array F DIM3 Word8 -> Array D DIM3 Word8+rotate deg g = fromFunction (Z :. y :. x :. k) f -- <1>+ where+ sh@(Z :. y :. x :. k) = extent g++ !theta = pi/180 * deg -- <2>++ !st = sin theta -- <3>+ !ct = cos theta++ !cy = fromIntegral y / 2 :: Double -- <4>+ !cx = fromIntegral x / 2 :: Double++ f (Z :. i :. j :. k) -- <5>+ | inShape sh old = g ! old -- <6>+ | otherwise = 0 -- <7>+ where+ fi = fromIntegral i - cy -- <8>+ fj = fromIntegral j - cx++ i' = round (st * fj + ct * fi + cy) -- <9>+ j' = round (ct * fj - st * fi + cx)++ old = Z :. i' :. j' :. k -- <10>+-- >>+
+ rsa-pipeline.hs view
@@ -0,0 +1,103 @@+--+-- Derived from a program believed to be originally written by John+-- Launchbury, and incorporating the RSA algorithm which is in the+-- public domain.+--++import System.Environment+import Data.List+import qualified Data.ByteString.Lazy.Char8 as B+import Data.ByteString.Lazy.Char8 (ByteString)+import ByteStringCompat+import Control.Monad.Par.Scheds.Trace++import Stream++main = do+ [f] <- getArgs+ text <- case f of+ "-" -> B.getContents+ _ -> B.readFile f+ B.putStr (pipeline n e d text)++-- example keys, created by makeKey below+n, d, e :: Integer+(n,d,e) = (3539517541822645630044332546732747854710141643130106075585179940882036712515975698104695392573887034788933523673604280427152984392565826058380509963039612419361429882234327760449752708861159361414595229,121492527803044541056704751360974487724009957507650761043424679483464778334890045929773805597614290949,216244483337223224019000724904989828660716358310562600433314577442746058361727768326718965949745599136958260211917551718034992348233259083876505235987999070191048638795502931877693189179113255689722281)+++-- <<encrypt+encrypt :: Integer -> Integer -> Stream ByteString -> Par (Stream ByteString)+encrypt n e s = streamMap (B.pack . show . power e n . code) s++decrypt :: Integer -> Integer -> Stream ByteString -> Par (Stream ByteString)+decrypt n d s = streamMap (B.pack . decode . power d n . integer) s+-- >>++integer :: ByteString -> Integer+integer b | Just (i,_) <- B.readInteger b = i++-- <<pipeline+pipeline :: Integer -> Integer -> Integer -> ByteString -> ByteString+pipeline n e d b = runPar $ do+ s0 <- streamFromList (chunk (size n) b)+ s1 <- encrypt n e s0+ s2 <- decrypt n d s1+ xs <- streamFold (\x y -> (y : x)) [] s2+ return (B.unlines (reverse xs))+-- >>++integers :: [ByteString] -> [Integer]+integers bs = [ i | Just (i,_) <- map B.readInteger bs ]++-------- Converting between Strings and Integers -----------++code :: ByteString -> Integer+code = B.foldl' accum 0+ where accum x y = (128 * x) + fromIntegral (fromEnum y)++decode :: Integer -> String+decode n = reverse (expand n)+ where expand 0 = []+ expand x = toEnum (fromIntegral (x `mod` 128)) : expand (x `div` 128)++chunk :: Int -> ByteString -> [ByteString]+chunk n xs | B.null xs = []+chunk n xs = as : chunk n bs+ where (as,bs) = B.splitAt (fromIntegral n) xs++size :: Integer -> Int+size n = (length (show n) * 47) `div` 100 -- log_128 10 = 0.4745++------- Constructing keys -------------------------++makeKeys :: Integer -> Integer -> (Integer, Integer, Integer)+makeKeys r s = (p*q, d, invert ((p-1)*(q-1)) d)+ where p = nextPrime r+ q = nextPrime s+ d = nextPrime (p+q+1)++nextPrime :: Integer -> Integer+nextPrime a = head (filter prime [odd,odd+2..])+ where odd | even a = a+1+ | True = a+ prime p = and [power (p-1) p x == 1 | x <- [3,5,7]]++invert :: Integer -> Integer -> Integer+invert n a = if e<0 then e+n else e+ where e=iter n 0 a 1++iter :: Integer -> Integer -> Integer -> Integer -> Integer+iter g v 0 w = v+iter g v h w = iter h w (g `mod` h) (v - (g `div` h)*w)++------- Fast exponentiation, mod m -----------------++power :: Integer -> Integer -> Integer -> Integer+power 0 m x = 1+power n m x | even n = sqr (power (n `div` 2) m x) `mod` m+ | True = (x * power (n-1) m x) `mod` m++sqr :: Integer -> Integer+sqr x = x * x++
+ rsa.hs view
@@ -0,0 +1,94 @@+--+-- Derived from a program believed to be originally written by John+-- Launchbury, and incorporating the RSA algorithm which is in the+-- public domain.+--++import System.Environment+import Data.List+import qualified Data.ByteString.Lazy.Char8 as B+import Data.ByteString.Lazy.Char8 (ByteString)+import ByteStringCompat++main = do+ [cmd,f] <- getArgs+ text <- case f of+ "-" -> B.getContents+ _ -> B.readFile f+ case cmd of+ "encrypt" -> B.putStr (encrypt n e text)+ "decrypt" -> B.putStr (decrypt n d text)++-- example keys, created by makeKey below+n, d, e :: Integer+(n,d,e) = (3539517541822645630044332546732747854710141643130106075585179940882036712515975698104695392573887034788933523673604280427152984392565826058380509963039612419361429882234327760449752708861159361414595229,121492527803044541056704751360974487724009957507650761043424679483464778334890045929773805597614290949,216244483337223224019000724904989828660716358310562600433314577442746058361727768326718965949745599136958260211917551718034992348233259083876505235987999070191048638795502931877693189179113255689722281)+++encrypt, decrypt :: Integer -> Integer -> ByteString -> ByteString++-- <<encrypt+encrypt n e = B.unlines -- <3>+ . map (B.pack . show . power e n . code) -- <2>+ . chunk (size n) -- <1>+-- >>++decrypt n d = B.concat+ . map (B.pack . decode . power d n)+ . integers+ . B.lines++integers :: [ByteString] -> [Integer]+integers bs = [ i | Just (i,_) <- map B.readInteger bs ]++-------- Converting between Strings and Integers -----------++code :: ByteString -> Integer+code = B.foldl' accum 0+ where accum x y = (128 * x) + fromIntegral (fromEnum y)++decode :: Integer -> String+decode n = reverse (expand n)+ where expand 0 = []+ expand x = toEnum (fromIntegral (x `mod` 128)) : expand (x `div` 128)++chunk :: Int -> ByteString -> [ByteString]+chunk n xs | B.null xs = []+chunk n xs = as : chunk n bs+ where (as,bs) = B.splitAt (fromIntegral n) xs++size :: Integer -> Int+size n = (length (show n) * 47) `div` 100 -- log_128 10 = 0.4745++------- Constructing keys -------------------------++makeKeys :: Integer -> Integer -> (Integer, Integer, Integer)+makeKeys r s = (p*q, d, invert ((p-1)*(q-1)) d)+ where p = nextPrime r+ q = nextPrime s+ d = nextPrime (p+q+1)++nextPrime :: Integer -> Integer+nextPrime a = head (filter prime [odd,odd+2..])+ where odd | even a = a+1+ | True = a+ prime p = and [power (p-1) p x == 1 | x <- [3,5,7]]++invert :: Integer -> Integer -> Integer+invert n a = if e<0 then e+n else e+ where e=iter n 0 a 1++iter :: Integer -> Integer -> Integer -> Integer -> Integer+iter g v 0 w = v+iter g v h w = iter h w (g `mod` h) (v - (g `div` h)*w)++------- Fast exponentiation, mod m -----------------++power :: Integer -> Integer -> Integer -> Integer+power 0 m x = 1+power n m x | even n = sqr (power (n `div` 2) m x) `mod` m+ | True = (x * power (n-1) m x) `mod` m++sqr :: Integer -> Integer+sqr x = x * x++
+ rsa1.hs view
@@ -0,0 +1,96 @@+--+-- Derived from a program believed to be originally written by John+-- Launchbury, and incorporating the RSA algorithm which is in the+-- public domain.+--++import System.Environment+import Control.Parallel.Strategies+import Data.List+import qualified Data.ByteString.Lazy.Char8 as B+import Data.ByteString.Lazy.Char8 (ByteString)+import ByteStringCompat++main = do+ [cmd,f] <- getArgs+ text <- case f of+ "-" -> B.getContents+ _ -> B.readFile f+ case cmd of+ "encrypt" -> B.putStr (encrypt n e text)+ "decrypt" -> B.putStr (decrypt n d text)++-- example keys, created by makeKey below+n, d, e :: Integer+(n,d,e) = (3539517541822645630044332546732747854710141643130106075585179940882036712515975698104695392573887034788933523673604280427152984392565826058380509963039612419361429882234327760449752708861159361414595229,121492527803044541056704751360974487724009957507650761043424679483464778334890045929773805597614290949,216244483337223224019000724904989828660716358310562600433314577442746058361727768326718965949745599136958260211917551718034992348233259083876505235987999070191048638795502931877693189179113255689722281)+++encrypt, decrypt :: Integer -> Integer -> ByteString -> ByteString++-- <<encrypt+encrypt n e = B.unlines+ . withStrategy (parList rdeepseq) -- <1>+ . map (B.pack . show . power e n . code)+ . chunk (size n)+-- >>++decrypt n d = B.concat+ . map (B.pack . decode . power d n)+ . integers+ . B.lines++integers :: [ByteString] -> [Integer]+integers bs = [ i | Just (i,_) <- map B.readInteger bs ]++-------- Converting between Strings and Integers -----------++code :: ByteString -> Integer+code = B.foldl' accum 0+ where accum x y = (128 * x) + fromIntegral (fromEnum y)++decode :: Integer -> String+decode n = reverse (expand n)+ where expand 0 = []+ expand x = toEnum (fromIntegral (x `mod` 128)) : expand (x `div` 128)++chunk :: Int -> ByteString -> [ByteString]+chunk n xs | B.null xs = []+chunk n xs = as : chunk n bs+ where (as,bs) = B.splitAt (fromIntegral n) xs++size :: Integer -> Int+size n = (length (show n) * 47) `div` 100 -- log_128 10 = 0.4745++------- Constructing keys -------------------------++makeKeys :: Integer -> Integer -> (Integer, Integer, Integer)+makeKeys r s = (p*q, d, invert ((p-1)*(q-1)) d)+ where p = nextPrime r+ q = nextPrime s+ d = nextPrime (p+q+1)++nextPrime :: Integer -> Integer+nextPrime a = head (filter prime [odd,odd+2..])+ where odd | even a = a+1+ | True = a+ prime p = and [power (p-1) p x == 1 | x <- [3,5,7]]++invert :: Integer -> Integer -> Integer+invert n a = if e<0 then e+n else e+ where e=iter n 0 a 1++iter :: Integer -> Integer -> Integer -> Integer -> Integer+iter g v 0 w = v+iter g v h w = iter h w (g `mod` h) (v - (g `div` h)*w)++------- Fast exponentiation, mod m -----------------++power :: Integer -> Integer -> Integer -> Integer+power 0 m x = 1+power n m x | even n = sqr (power (n `div` 2) m x) `mod` m+ | True = (x * power (n-1) m x) `mod` m++sqr :: Integer -> Integer+sqr x = x * x++
+ rsa2.hs view
@@ -0,0 +1,96 @@+--+-- Derived from a program believed to be originally written by John+-- Launchbury, and incorporating the RSA algorithm which is in the+-- public domain.+--++import System.Environment+import Control.Parallel.Strategies+import Data.List+import qualified Data.ByteString.Lazy.Char8 as B+import Data.ByteString.Lazy.Char8 (ByteString)+import ByteStringCompat++main = do+ [cmd,f] <- getArgs+ text <- case f of+ "-" -> B.getContents+ _ -> B.readFile f+ case cmd of+ "encrypt" -> B.putStr (encrypt n e text)+ "decrypt" -> B.putStr (decrypt n d text)++-- example keys, created by makeKey below+n, d, e :: Integer+(n,d,e) = (3539517541822645630044332546732747854710141643130106075585179940882036712515975698104695392573887034788933523673604280427152984392565826058380509963039612419361429882234327760449752708861159361414595229,121492527803044541056704751360974487724009957507650761043424679483464778334890045929773805597614290949,216244483337223224019000724904989828660716358310562600433314577442746058361727768326718965949745599136958260211917551718034992348233259083876505235987999070191048638795502931877693189179113255689722281)+++encrypt, decrypt :: Integer -> Integer -> ByteString -> ByteString++-- <<encrypt+encrypt n e = B.unlines+ . withStrategy (parBuffer 100 rdeepseq) -- <1>+ . map (B.pack . show . power e n . code)+ . chunk (size n)+-- >>++decrypt n d = B.concat+ . map (B.pack . decode . power d n)+ . integers+ . B.lines++integers :: [ByteString] -> [Integer]+integers bs = [ i | Just (i,_) <- map B.readInteger bs ]++-------- Converting between Strings and Integers -----------++code :: ByteString -> Integer+code = B.foldl' accum 0+ where accum x y = (128 * x) + fromIntegral (fromEnum y)++decode :: Integer -> String+decode n = reverse (expand n)+ where expand 0 = []+ expand x = toEnum (fromIntegral (x `mod` 128)) : expand (x `div` 128)++chunk :: Int -> ByteString -> [ByteString]+chunk n xs | B.null xs = []+chunk n xs = as : chunk n bs+ where (as,bs) = B.splitAt (fromIntegral n) xs++size :: Integer -> Int+size n = (length (show n) * 47) `div` 100 -- log_128 10 = 0.4745++------- Constructing keys -------------------------++makeKeys :: Integer -> Integer -> (Integer, Integer, Integer)+makeKeys r s = (p*q, d, invert ((p-1)*(q-1)) d)+ where p = nextPrime r+ q = nextPrime s+ d = nextPrime (p+q+1)++nextPrime :: Integer -> Integer+nextPrime a = head (filter prime [odd,odd+2..])+ where odd | even a = a+1+ | True = a+ prime p = and [power (p-1) p x == 1 | x <- [3,5,7]]++invert :: Integer -> Integer -> Integer+invert n a = if e<0 then e+n else e+ where e=iter n 0 a 1++iter :: Integer -> Integer -> Integer -> Integer -> Integer+iter g v 0 w = v+iter g v h w = iter h w (g `mod` h) (v - (g `div` h)*w)++------- Fast exponentiation, mod m -----------------++power :: Integer -> Integer -> Integer -> Integer+power 0 m x = 1+power n m x | even n = sqr (power (n `div` 2) m x) `mod` m+ | True = (x * power (n-1) m x) `mod` m++sqr :: Integer -> Integer+sqr x = x * x++
+ server.hs view
@@ -0,0 +1,35 @@+import ConcurrentUtils+import Network+import Control.Monad+import Control.Concurrent (forkIO)+import System.IO+import Text.Printf+import Control.Exception++-- <<main+main = withSocketsDo $ do+ sock <- listenOn (PortNumber (fromIntegral port)) -- <1>+ printf "Listening on port %d\n" port+ forever $ do -- <2>+ (handle, host, port) <- accept sock -- <3>+ printf "Accepted connection from %s: %s\n" host (show port)+ forkFinally (talk handle) (\_ -> hClose handle) -- <4>++port :: Int+port = 44444+-- >>++-- <<talk+talk :: Handle -> IO ()+talk h = do+ hSetBuffering h LineBuffering -- <1>+ loop -- <2>+ where+ loop = do+ line <- hGetLine h -- <3>+ if line == "end" -- <4>+ then hPutStrLn h ("Thank you for using the " ++ -- <5>+ "Haskell doubling service.")+ else do hPutStrLn h (show (2 * (read line :: Integer))) -- <6>+ loop -- <7>+-- >>
+ server2.hs view
@@ -0,0 +1,74 @@+import Network+import Control.Monad+import Control.Concurrent+import System.IO+import Text.Printf+import Control.Exception+import Control.Concurrent.Async+import Control.Concurrent.STM+import ConcurrentUtils (forkFinally)++-- <<main+main = withSocketsDo $ do+ sock <- listenOn (PortNumber (fromIntegral port))+ printf "Listening on port %d\n" port+ factor <- atomically $ newTVar 2 -- <1>+ forever $ do+ (handle, host, port) <- accept sock+ printf "Accepted connection from %s: %s\n" host (show port)+ forkFinally (talk handle factor) (\_ -> hClose handle) -- <2>++port :: Int+port = 44444+-- >>++-- <<talk+talk :: Handle -> TVar Integer -> IO ()+talk h factor = do+ hSetBuffering h LineBuffering+ c <- atomically newTChan -- <1>+ race (server h factor c) (receive h c) -- <2>+ return ()+-- >>++-- <<receive+receive :: Handle -> TChan String -> IO ()+receive h c = forever $ do+ line <- hGetLine h+ atomically $ writeTChan c line+-- >>++-- <<server+server :: Handle -> TVar Integer -> TChan String -> IO ()+server h factor c = do+ f <- atomically $ readTVar factor -- <1>+ hPrintf h "Current factor: %d\n" f -- <2>+ loop f -- <3>+ where+ loop f = do+ action <- atomically $ do -- <4>+ f' <- readTVar factor -- <5>+ if (f /= f') -- <6>+ then return (newfactor f') -- <7>+ else do+ l <- readTChan c -- <8>+ return (command f l) -- <9>+ action++ newfactor f = do -- <10>+ hPrintf h "new factor: %d\n" f+ loop f++ command f s -- <11>+ = case s of+ "end" ->+ hPutStrLn h ("Thank you for using the " +++ "Haskell doubling service.") -- <12>+ '*':s -> do+ atomically $ writeTVar factor (read s :: Integer) -- <13>+ loop f+ line -> do+ hPutStrLn h (show (f * (read line :: Integer)))+ loop f+-- >>+
+ strat.hs view
@@ -0,0 +1,26 @@+import Control.Parallel+import Control.Parallel.Strategies (rpar, Strategy, using)+import Text.Printf+import System.Environment++-- <<fib+fib :: Integer -> Integer+fib 0 = 1+fib 1 = 1+fib n = fib (n-1) + fib (n-2)+-- >>++main = print pair+ where+ pair =+-- <<pair+ (fib 35, fib 36) `using` parPair+-- >>++-- <<parPair+parPair :: Strategy (a,b)+parPair (a,b) = do+ a' <- rpar a+ b' <- rpar b+ return (a',b')+-- >>
+ strat2.hs view
@@ -0,0 +1,31 @@+import Control.Parallel+import Control.Parallel.Strategies (rpar, Strategy, using)+import Text.Printf+import System.Environment++-- <<fib+fib :: Integer -> Integer+fib 0 = 1+fib 1 = 1+fib n = fib (n-1) + fib (n-2)+-- >>++main = print pair+ where+ pair =+-- <<pair+ (fib 35, fib 36) `using` parPair+-- >>++-- <<evalPair+evalPair :: Strategy a -> Strategy b -> Strategy (a,b)+evalPair sa sb (a,b) = do+ a' <- sa a+ b' <- sb b+ return (a',b')+-- >>++-- <<parPair+parPair :: Strategy (a,b)+parPair = evalPair rpar rpar+-- >>
+ strat3.hs view
@@ -0,0 +1,32 @@+import Control.Parallel+import Control.Parallel.Strategies (rpar, rseq, Strategy, using, rparWith)+import Control.Exception+import Text.Printf+import System.Environment++-- <<fib+fib :: Integer -> Integer+fib 0 = 1+fib 1 = 1+fib n = fib (n-1) + fib (n-2)+-- >>++main = print pair+ where+ pair =+-- <<pair+ (fib 35, fib 36) `using` parPair rseq rseq+-- >>++-- <<evalPair+evalPair :: Strategy a -> Strategy b -> Strategy (a,b)+evalPair sa sb (a,b) = do+ a' <- sa a+ b' <- sb b+ return (a',b')+-- >>++-- <<parPair+parPair :: Strategy a -> Strategy b -> Strategy (a,b)+parPair sa sb = evalPair (rparWith sa) (rparWith sb)+-- >>
+ sudoku1.hs view
@@ -0,0 +1,16 @@+-- <<all+import Sudoku+import Control.Exception+import System.Environment+import Data.Maybe++main :: IO ()+main = do+ [f] <- getArgs -- <1>+ file <- readFile f -- <2>++ let puzzles = lines file -- <3>+ solutions = map solve puzzles -- <4>++ print (length (filter isJust solutions)) -- <5>+-- >>
+ sudoku2.hs view
@@ -0,0 +1,27 @@+import Sudoku+import Control.Exception+import System.Environment+import Control.Parallel.Strategies+import Control.DeepSeq+import Data.Maybe++-- <<main+main :: IO ()+main = do+ [f] <- getArgs+ file <- readFile f++ let puzzles = lines file++ (as,bs) = splitAt (length puzzles `div` 2) puzzles -- <1>++ solutions = runEval $ do+ as' <- rpar (force (map solve as)) -- <2>+ bs' <- rpar (force (map solve bs)) -- <2>+ rseq as' -- <3>+ rseq bs' -- <3>+ return (as' ++ bs') -- <4>++ print (length (filter isJust solutions))+-- >>+
+ sudoku3.hs view
@@ -0,0 +1,26 @@+import Sudoku+import Control.Exception+import System.Environment+import Control.Parallel.Strategies hiding (parMap)+import Data.Maybe++-- <<main+main :: IO ()+main = do+ [f] <- getArgs+ file <- readFile f++ let puzzles = lines file+ solutions = runEval (parMap solve puzzles)++ print (length (filter isJust solutions))+-- >>++-- <<parMap+parMap :: (a -> b) -> [a] -> Eval [b]+parMap f [] = return []+parMap f (a:as) = do+ b <- rpar (f a)+ bs <- parMap f as+ return (b:bs)+-- >>
+ sudoku4.hs view
@@ -0,0 +1,25 @@+import Sudoku+import Control.Exception+import System.Environment+import Control.Parallel.Strategies hiding (parMap)+import Data.Maybe++-- <<main+main :: IO ()+main = do+ [f] <- getArgs+ file <- readFile f++ let puzzles = lines file+ solutions = runEval (parMap solve puzzles)++ evaluate (length puzzles)+ print (length (filter isJust solutions))+-- >>++parMap :: (a -> b) -> [a] -> Eval [b]+parMap f [] = return []+parMap f (a:as) = do+ b <- rpar (f a)+ bs <- parMap f as+ return (b:bs)
+ threadperf1.hs view
@@ -0,0 +1,11 @@+import Control.Concurrent+import Control.Monad++-- <<main+numThreads = 1000000++main = do+ m <- newEmptyMVar+ replicateM_ numThreads $ forkIO (putMVar m ())+ replicateM_ numThreads $ takeMVar m+-- >>
+ threadperf2.hs view
@@ -0,0 +1,13 @@+import Control.Concurrent+import Control.Monad++-- <<main+numThreads = 1000000++main = do+ ms <- replicateM numThreads $ do+ m <- newEmptyMVar+ forkIO (putMVar m ())+ return m+ mapM_ takeMVar ms+-- >>
+ timeout.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DeriveDataTypeable #-}+import Control.Concurrent+import Data.Unique+import Control.Exception+import Data.Typeable++data Timeout = Timeout Unique deriving (Eq, Typeable)++instance Show Timeout where+ show (Timeout _) = "timeout"++instance Exception Timeout++-- <<timeout-sig+timeout :: Int -> IO a -> IO (Maybe a)+-- >>++-- <<timeout+timeout t m+ | t < 0 = fmap Just m -- <1>+ | t == 0 = return Nothing -- <1>+ | otherwise = do+ pid <- myThreadId -- <2>+ u <- newUnique -- <3>+ let ex = Timeout u -- <3>+ handleJust -- <4>+ (\e -> if e == ex then Just () else Nothing) -- <5>+ (\_ -> return Nothing) -- <6>+ (bracket (forkIO $ do threadDelay t -- <7>+ throwTo pid ex)+ (\tid -> throwTo tid ThreadKilled) -- <8>+ (\_ -> fmap Just m)) -- <9>+-- >>++main = (timeout 200000 $ timeout 100000 $ timeout 300000 $ threadDelay 1000000) >>= print
+ timetable.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE OverloadedStrings #-}++import System.Random+import System.Environment+import Debug.Trace+import Data.List+import Control.DeepSeq++import Data.Map (Map)+import qualified Data.Map as Map++-- ----------------------------------------------------------------------------++-- <<Talk+newtype Talk = Talk Int+ deriving (Eq,Ord)++instance NFData Talk++instance Show Talk where+ show (Talk t) = show t+-- >>++-- <<Person+data Person = Person+ { name :: String+ , talks :: [Talk]+ }+ deriving (Show)+-- >>++-- <<TimeTable+type TimeTable = [[Talk]]+-- >>++-- ----------------------------------------------------------------------------++-- <<timetable+timetable :: [Person] -> [Talk] -> Int -> Int -> [TimeTable]+timetable people allTalks maxTrack maxSlot =+-- >>+-- <<generate_call+ generate 0 0 [] [] allTalks allTalks+-- >>+ where+-- <<generate_type+ generate :: Int -- current slot number+ -> Int -- current track number+ -> [[Talk]] -- slots allocated so far+ -> [Talk] -- talks in this slot+ -> [Talk] -- talks that can be allocated in this slot+ -> [Talk] -- all talks remaining to be allocated+ -> [TimeTable] -- all possible solutions+-- >>++-- <<generate+ generate slotNo trackNo slots slot slotTalks talks+ | slotNo == maxSlot = [slots] -- <1>+ | trackNo == maxTrack =+ generate (slotNo+1) 0 (slot:slots) [] talks talks -- <2>+ | otherwise = concat -- <3>+ [ generate slotNo (trackNo+1) slots (t:slot) slotTalks' talks' -- <8>+ | (t, ts) <- selects slotTalks -- <4>+ , let clashesWithT = Map.findWithDefault [] t clashes -- <5>+ , let slotTalks' = filter (`notElem` clashesWithT) ts -- <6>+ , let talks' = filter (/= t) talks -- <7>+ ]+-- >>++-- <<clashes+ clashes :: Map Talk [Talk]+ clashes = Map.fromListWith union+ [ (t, ts)+ | s <- people+ , (t, ts) <- selects (talks s) ]+-- >>++-- ----------------------------------------------------------------------------+-- Utils++-- <<selects+selects :: [a] -> [(a,[a])]+selects xs0 = go [] xs0+ where+ go xs [] = []+ go xs (y:ys) = (y,xs++ys) : go (y:xs) ys+-- >>++-- ----------------------------------------------------------------------------+-- Benchmarking / Testing++bench :: Int -> Int -> Int -> Int -> Int -> StdGen+ -> ([Person],[Talk],[TimeTable])++bench nslots ntracks ntalks npersons c_per_s gen =+ (persons,talks, timetable persons talks ntracks nslots)+ where+ total_talks = nslots * ntracks++ talks = map Talk [1..total_talks]+ persons = mkpersons npersons gen++ mkpersons :: Int -> StdGen -> [Person]+ mkpersons 0 g = []+ mkpersons n g = Person ('P':show n) (take c_per_s cs) : rest+ where+ (g1,g2) = split g+ rest = mkpersons (n-1) g2+ cs = nub [ talks !! n | n <- randomRs (0,ntalks-1) g ]++main = do+ [ a, b, c, d, e ] <- fmap (fmap read) getArgs+ let g = mkStdGen 1001+ let (ss,cs,ts) = bench a b c d e g+ print ss+ print (length ts)+-- [ a, b ] <- fmap (fmap read) getArgs+-- print (head (test2 a b))++test = timetable testPersons cs 2 2+ where+ cs@[c1,c2,c3,c4] = map Talk [1..4]++ testPersons =+ [ Person "P" [c1,c2]+ , Person "Q" [c2,c3]+ , Person "R" [c3,c4]+ , Person "S" [c1,c4]+ ]++test2 n m = timetable testPersons cs m n+ where+ cs = map Talk [1 .. (n * m)]++ testPersons =+ [ Person "1" (take n cs)+ ]
+ timetable1.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE OverloadedStrings #-}++import System.Random+import System.Environment+import Debug.Trace+import Data.List+import Control.DeepSeq++import Data.Map (Map)+import qualified Data.Map as Map++-- ----------------------------------------------------------------------------++-- <<Talk+newtype Talk = Talk Int+ deriving (Eq,Ord)++instance NFData Talk++instance Show Talk where+ show (Talk t) = show t+-- >>++-- <<Person+data Person = Person+ { name :: String+ , talks :: [Talk]+ }+ deriving (Show)+-- >>++-- <<TimeTable+type TimeTable = [[Talk]]+-- >>++-- ----------------------------------------------------------------------------+-- The parallel skeleton++-- <<search_type+search :: ( partial -> Maybe solution ) -- <1>+ -> ( partial -> [ partial ] ) -- <2>+ -> partial -- <3>+ -> [solution] -- <4>+-- >>++-- <<search+search finished refine emptysoln = generate emptysoln+ where+ generate partial+ | Just soln <- finished partial = [soln]+ | otherwise = concat (map generate (refine partial))+-- >>++-- ----------------------------------------------------------------------------++-- <<Partial+type Partial = (Int, Int, [[Talk]], [Talk], [Talk], [Talk])+-- >>++-- <<timetable+timetable :: [Person] -> [Talk] -> Int -> Int -> [TimeTable]+timetable people allTalks maxTrack maxSlot =+ search finished refine emptysoln+ where+ emptysoln = (0, 0, [], [], allTalks, allTalks)++ finished (slotNo, trackNo, slots, slot, slotTalks, talks)+ | slotNo == maxSlot = Just slots+ | otherwise = Nothing++ clashes :: Map Talk [Talk]+ clashes = Map.fromListWith union+ [ (t, ts)+ | s <- people+ , (t, ts) <- selects (talks s) ]++ refine (slotNo, trackNo, slots, slot, slotTalks, talks)+ | trackNo == maxTrack = [(slotNo+1, 0, slot:slots, [], talks, talks)]+ | otherwise =+ [ (slotNo, trackNo+1, slots, t:slot, slotTalks', talks')+ | (t, ts) <- selects slotTalks+ , let clashesWithT = Map.findWithDefault [] t clashes+ , let slotTalks' = filter (`notElem` clashesWithT) ts+ , let talks' = filter (/= t) talks+ ]+-- >>++-- ----------------------------------------------------------------------------+-- Utils++-- <<selects+selects :: [a] -> [(a,[a])]+selects xs0 = go [] xs0+ where+ go xs [] = []+ go xs (y:ys) = (y,xs++ys) : go (y:xs) ys+-- >>++-- ----------------------------------------------------------------------------+-- Benchmarking / Testing++bench :: Int -> Int -> Int -> Int -> Int -> StdGen+ -> ([Person],[Talk],[TimeTable])++bench nslots ntracks ntalks npersons c_per_s gen =+ (persons,talks, timetable persons talks ntracks nslots)+ where+ total_talks = nslots * ntracks++ talks = map Talk [1..total_talks]+ persons = mkpersons npersons gen++ mkpersons :: Int -> StdGen -> [Person]+ mkpersons 0 g = []+ mkpersons n g = Person ('P':show n) (take c_per_s cs) : rest+ where+ (g1,g2) = split g+ rest = mkpersons (n-1) g2+ cs = nub [ talks !! n | n <- randomRs (0,ntalks-1) g ]++main = do+ [ a, b, c, d, e ] <- fmap (fmap read) getArgs+ let g = mkStdGen 1001+ let (ss,cs,ts) = bench a b c d e g+ print ss+ print (length ts)+-- [ a, b ] <- fmap (fmap read) getArgs+-- print (head (test2 a b))++test = timetable testPersons cs 2 2+ where+ cs@[c1,c2,c3,c4] = map Talk [1..4]++ testPersons =+ [ Person "P" [c1,c2]+ , Person "Q" [c2,c3]+ , Person "R" [c3,c4]+ ]++test2 n m = timetable testPersons cs m n+ where+ cs = map Talk [1 .. (n * m)]++ testPersons =+ [ Person "1" (take n cs)+ ]
+ timetable2.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE OverloadedStrings #-}++import System.Random+import System.Environment+import Debug.Trace+import Data.List+import Control.Monad.Par+import Control.DeepSeq++import Data.Map (Map)+import qualified Data.Map as Map++-- ----------------------------------------------------------------------------++-- <<Talk+newtype Talk = Talk Int+ deriving (Eq,Ord)++instance NFData Talk++instance Show Talk where+ show (Talk t) = show t+-- >>++-- <<Person+data Person = Person+ { name :: String+ , talks :: [Talk]+ }+ deriving (Show)+-- >>++-- <<TimeTable+type TimeTable = [[Talk]]+-- >>++-- ----------------------------------------------------------------------------+-- The parallel skeleton++-- <<search_type+search :: ( partial -> Maybe solution ) -- <1>+ -> ( partial -> [ partial ] ) -- <2>+ -> partial -- <3>+ -> [solution] -- <4>+-- >>++-- <<search+search finished refine emptysoln = generate emptysoln+ where+ generate partial+ | Just soln <- finished partial = [soln]+ | otherwise = concat (map generate (refine partial))+-- >>++-- <<parsearch+parsearch :: NFData solution+ => ( partial -> Maybe solution )+ -> ( partial -> [ partial ] )+ -> partial+ -> [solution]++parsearch finished refine emptysoln+ = runPar $ generate emptysoln+ where+ generate partial+ | Just soln <- finished partial = return [soln]+ | otherwise = do+ solnss <- parMapM generate (refine partial)+ return (concat solnss)+-- >>++-- ----------------------------------------------------------------------------++-- <<Partial+type Partial = (Int, Int, [[Talk]], [Talk], [Talk], [Talk])+-- >>++-- <<timetable+timetable :: [Person] -> [Talk] -> Int -> Int -> [TimeTable]+timetable people allTalks maxTrack maxSlot =+ parsearch finished refine emptysoln+ where+ emptysoln = (0, 0, [], [], allTalks, allTalks)++ finished (slotNo, trackNo, slots, slot, slotTalks, talks)+ | slotNo == maxSlot = Just slots+ | otherwise = Nothing++ clashes :: Map Talk [Talk]+ clashes = Map.fromListWith union+ [ (t, ts)+ | s <- people+ , (t, ts) <- selects (talks s) ]++ refine (slotNo, trackNo, slots, slot, slotTalks, talks)+ | trackNo == maxTrack = [(slotNo+1, 0, slot:slots, [], talks, talks)]+ | otherwise =+ [ (slotNo, trackNo+1, slots, t:slot, slotTalks', talks')+ | (t, ts) <- selects slotTalks+ , let clashesWithT = Map.findWithDefault [] t clashes+ , let slotTalks' = filter (`notElem` clashesWithT) ts+ , let talks' = filter (/= t) talks+ ]+-- >>++-- ----------------------------------------------------------------------------+-- Utils++-- <<selects+selects :: [a] -> [(a,[a])]+selects xs0 = go [] xs0+ where+ go xs [] = []+ go xs (y:ys) = (y,xs++ys) : go (y:xs) ys+-- >>++-- ----------------------------------------------------------------------------+-- Benchmarking / Testing++bench :: Int -> Int -> Int -> Int -> Int -> StdGen+ -> ([Person],[Talk],[TimeTable])++bench nslots ntracks ntalks npersons c_per_s gen =+ (persons,talks, timetable persons talks ntracks nslots)+ where+ total_talks = nslots * ntracks++ talks = map Talk [1..total_talks]+ persons = mkpersons npersons gen++ mkpersons :: Int -> StdGen -> [Person]+ mkpersons 0 g = []+ mkpersons n g = Person ('P':show n) (take c_per_s cs) : rest+ where+ (g1,g2) = split g+ rest = mkpersons (n-1) g2+ cs = nub [ talks !! n | n <- randomRs (0,ntalks-1) g ]++main = do+ [ a, b, c, d, e ] <- fmap (fmap read) getArgs+ let g = mkStdGen 1001+ let (ss,cs,ts) = bench a b c d e g+ print ss+ print (length ts)+-- [ a, b ] <- fmap (fmap read) getArgs+-- print (head (test2 a b))++test = timetable testPersons cs 2 2+ where+ cs@[c1,c2,c3,c4] = map Talk [1..4]++ testPersons =+ [ Person "P" [c1,c2]+ , Person "Q" [c2,c3]+ , Person "R" [c3,c4]+ ]++test2 n m = timetable testPersons cs m n+ where+ cs = map Talk [1 .. (n * m)]++ testPersons =+ [ Person "1" (take n cs)+ ]
+ timetable3.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE OverloadedStrings #-}++import System.Random+import System.Environment+import Debug.Trace+import Data.List+import Control.Monad.Par+import Control.DeepSeq++import Data.Map (Map)+import qualified Data.Map as Map++-- ----------------------------------------------------------------------------++-- <<Talk+newtype Talk = Talk Int+ deriving (Eq,Ord)++instance NFData Talk++instance Show Talk where+ show (Talk t) = show t+-- >>++-- <<Person+data Person = Person+ { name :: String+ , talks :: [Talk]+ }+ deriving (Show)+-- >>++-- <<TimeTable+type TimeTable = [[Talk]]+-- >>++-- ----------------------------------------------------------------------------+-- The parallel skeleton++-- <<search_type+search :: ( partial -> Maybe solution ) -- <1>+ -> ( partial -> [ partial ] ) -- <2>+ -> partial -- <3>+ -> [solution] -- <4>+-- >>++-- <<search+search finished refine emptysoln = generate emptysoln+ where+ generate partial+ | Just soln <- finished partial = [soln]+ | otherwise = concat (map generate (refine partial))+-- >>++-- <<parsearch+parsearch :: NFData solution+ => Int+ -> ( partial -> Maybe solution ) -- finished?+ -> ( partial -> [ partial ] ) -- refine a solution+ -> partial -- initial solution+ -> [solution]++parsearch maxdepth finished refine emptysoln+ = runPar $ generate 0 emptysoln+ where+ generate d partial | d >= maxdepth -- <1>+ = return (search finished refine partial)+ generate d partial+ | Just soln <- finished partial = return [soln]+ | otherwise = do+ solnss <- parMapM (generate (d+1)) (refine partial)+ return (concat solnss)+-- >>++-- ----------------------------------------------------------------------------++-- <<Partial+type Partial = (Int, Int, [[Talk]], [Talk], [Talk], [Talk])+-- >>++-- <<timetable+timetable :: [Person] -> [Talk] -> Int -> Int -> [TimeTable]+timetable people allTalks maxTrack maxSlot =+ parsearch 3 finished refine emptysoln+ where+ emptysoln = (0, 0, [], [], allTalks, allTalks)++ finished (slotNo, trackNo, slots, slot, slotTalks, talks)+ | slotNo == maxSlot = Just slots+ | otherwise = Nothing++ clashes :: Map Talk [Talk]+ clashes = Map.fromListWith union+ [ (t, ts)+ | s <- people+ , (t, ts) <- selects (talks s) ]++ refine (slotNo, trackNo, slots, slot, slotTalks, talks)+ | trackNo == maxTrack = [(slotNo+1, 0, slot:slots, [], talks, talks)]+ | otherwise =+ [ (slotNo, trackNo+1, slots, t:slot, slotTalks', talks')+ | (t, ts) <- selects slotTalks+ , let clashesWithT = Map.findWithDefault [] t clashes+ , let slotTalks' = filter (`notElem` clashesWithT) ts+ , let talks' = filter (/= t) talks+ ]+-- >>++-- ----------------------------------------------------------------------------+-- Utils++-- <<selects+selects :: [a] -> [(a,[a])]+selects xs0 = go [] xs0+ where+ go xs [] = []+ go xs (y:ys) = (y,xs++ys) : go (y:xs) ys+-- >>++-- ----------------------------------------------------------------------------+-- Benchmarking / Testing++bench :: Int -> Int -> Int -> Int -> Int -> StdGen+ -> ([Person],[Talk],[TimeTable])++bench nslots ntracks ntalks npersons c_per_s gen =+ (persons,talks, timetable persons talks ntracks nslots)+ where+ total_talks = nslots * ntracks++ talks = map Talk [1..total_talks]+ persons = mkpersons npersons gen++ mkpersons :: Int -> StdGen -> [Person]+ mkpersons 0 g = []+ mkpersons n g = Person ('P':show n) (take c_per_s cs) : rest+ where+ (g1,g2) = split g+ rest = mkpersons (n-1) g2+ cs = nub [ talks !! n | n <- randomRs (0,ntalks-1) g ]++main = do+ [ a, b, c, d, e ] <- fmap (fmap read) getArgs+ let g = mkStdGen 1001+ let (ss,cs,ts) = bench a b c d e g+ print ss+ print (length ts)+-- [ a, b ] <- fmap (fmap read) getArgs+-- print (head (test2 a b))++test = timetable testPersons cs 2 2+ where+ cs@[c1,c2,c3,c4] = map Talk [1..4]++ testPersons =+ [ Person "P" [c1,c2]+ , Person "Q" [c2,c3]+ , Person "R" [c3,c4]+ ]++test2 n m = timetable testPersons cs m n+ where+ cs = map Talk [1 .. (n * m)]++ testPersons =+ [ Person "1" (take n cs)+ ]
+ tmvar.hs view
@@ -0,0 +1,49 @@+module TMVar where++import Control.Concurrent.STM hiding (TMVar, takeTMVar)++-- <<TMVar+newtype TMVar a = TMVar (TVar (Maybe a))+-- >>++newTMVar :: a -> STM (TMVar a)+newTMVar a = do+ t <- newTVar (Just a)+ return (TMVar t)++-- <<newEmptyTMVar+newEmptyTMVar :: STM (TMVar a)+newEmptyTMVar = do+ t <- newTVar Nothing+ return (TMVar t)+-- >>++-- <<takeTMVar+takeTMVar :: TMVar a -> STM a+takeTMVar (TMVar t) = do+ m <- readTVar t -- <1>+ case m of+ Nothing -> retry -- <2>+ Just a -> do+ writeTVar t Nothing -- <3>+ return a+-- >>++-- <<putTMVar+putTMVar :: TMVar a -> a -> STM ()+putTMVar (TMVar t) a = do+ m <- readTVar t+ case m of+ Nothing -> do+ writeTVar t (Just a)+ return ()+ Just _ -> retry+-- >>++-- <<takeEitherTMVar+takeEitherTMVar :: TMVar a -> TMVar b -> STM (Either a b)+takeEitherTMVar ma mb =+ fmap Left (takeTMVar ma)+ `orElse`+ fmap Right (takeTMVar mb)+-- >>
+ windowman.hs view
@@ -0,0 +1,74 @@+module WindowManager where++import Control.Concurrent.STM+import Data.Map as Map+import Data.Set as Set+import Data.Maybe++data Window+instance Eq Window+instance Ord Window++data Desktop+instance Eq Desktop+instance Ord Desktop++type Display = Map Desktop (TVar (Set Window))++-- <<moveWindowSTM+moveWindowSTM :: Display -> Window -> Desktop -> Desktop -> STM ()+moveWindowSTM disp win a b = do+ wa <- readTVar ma+ wb <- readTVar mb+ writeTVar ma (Set.delete win wa)+ writeTVar mb (Set.insert win wb)+ where+ ma = disp ! a+ mb = disp ! b+-- >>++-- <<moveWindow+moveWindow :: Display -> Window -> Desktop -> Desktop -> IO ()+moveWindow disp win a b = atomically $ moveWindowSTM disp win a b+-- >>++-- <<swapWindows+swapWindows :: Display+ -> Window -> Desktop+ -> Window -> Desktop+ -> IO ()+swapWindows disp w a v b = atomically $ do+ moveWindowSTM disp w a b+ moveWindowSTM disp v b a+-- >>++render :: Set Window -> IO ()+render = undefined++-- <<UserFocus+type UserFocus = TVar Desktop+-- >>++-- <<getWindows+getWindows :: Display -> UserFocus -> STM (Set Window)+getWindows disp focus = do+ desktop <- readTVar focus+ readTVar (disp ! desktop)+-- >>++-- <<renderThread+renderThread :: Display -> UserFocus -> IO ()+renderThread disp focus = do+ wins <- atomically $ getWindows disp focus -- <1>+ loop wins -- <2>+ where+ loop wins = do -- <3>+ render wins -- <4>+ next <- atomically $ do+ wins' <- getWindows disp focus -- <5>+ if (wins == wins') -- <6>+ then retry -- <7>+ else return wins' -- <8>+ loop next+-- >>+